1#
2# Ffidl interface to GNU dbm database library version 1.8
3#
4# design, and documentation, taken from Tclgdbm0.6
5#
6# gdbm open <file> [r|rw|rwc|rwn]
7#
8# Opens a gdbm database <file> with an optional mode. If the mode is not
9# given it is opened for reading (r). The mode can be (r) (read only),
10# (rw) (read,write), (rwc) (read,write and create if not already
11# existent), and (rwn) (read,write and create a new database regardless
12# if one exists). The command returns a handle <name> which is used to
13# refer to the open database.
14#
15# gdbm close <name>
16#
17# Close a gdbm database with the name <name>.
18#
19# gdbm insert <name> <key> <content>
20#
21# <name> is the name of a gdbm database previously opened with gdbm
22# open.  Inserts the data <content> giving it the key <key>.  If data
23# with <key> is already in the database an error is generated. Nothing
24# returned.
25#
26# gdbm store  <name> <key> <content>
27#
28# <name> is the name of a gdbm database previously opened with gdbm
29# open.  Inserts <content> to the database. If <key> already exists
30# the new <content> replaces the old. Nothing returned.
31#
32# gdbm fetch  <name> <key>
33#
34# <name> is the name of a gdbm database previously opened with gdbm
35# open.  Searches for <key> in the database and returns the associated
36# contents, or returns a tcl error if the key is not found.
37#
38# gdbm delete  <name> <key>
39#
40# <name> is the name of a gdbm database previously opened with gdbm
41# open.  Searches for <key> and deletes it in the database.  If <key> is
42# not found an error is generated.  Nothing returned.
43#
44# gdbm list  <name>
45#
46# <name> is the name of a gdbm database previously opened with gdbm
47# open.  Returns a list of all keys in the database.
48#
49# gdbm reorganize  <name>
50#
51# <name> is the name of a gdbm database previously opened with gdbm
52# open.  This routine can be used to shrink the size of the database
53# file if there have been a lot of deletions.  Nothing returned.
54#
55# gdbm exists <name> <key>
56#
57# Returns "0" if <key> is not found within the previously opened
58# database <name>, "1" otherwise.
59#
60# gdbm firstkey <name>
61# gdbm nextkey <name> <lastkey>
62#
63# A first/next scheme permits retrieving all keys from a database in
64# sequential (but unsorted!) order. gdbm firstkey <name> returns a
65# starting key, which may be used to retrieve the following key with
66# nextkey. nextkey returns the next key to a given previous key. When no
67# next key is available, the empty string is returned.
68#
69
70package provide Gdbm 1.8
71package require Ffidl 0.1
72package require Ffidlrt 0.1
73
74namespace eval ::gdbm:: {
75    set lib gdbm
76    set nhandle 0
77    array set handles {
78    }
79    array set writemodes {
80    }
81    array set symbols {
82    }
83    array set modes {
84	r GDBM_READER
85	rw GDBM_WRITER
86	rwc GDBM_WRCREAT
87	rwn GDBM_NEWDB
88    }
89    array set constants {
90	GDBM_INSERT 0
91	GDBM_REPLACE 1
92	GDBM_READER 0
93	GDBM_WRITER 1
94	GDBM_WRCREAT 2
95	GDBM_NEWDB 3
96    }
97}
98
99#
100# find library
101#
102set ::gdbm::lib [::ffidl::find-lib gdbm]
103
104#
105# typedefs
106#
107::ffidl::typedef GDBM_FILE pointer
108::ffidl::typedef gdbm_datum pointer int
109
110#
111# symbols
112#
113set ::gdbm::symbols(gdbm_errno) [::ffidl::symbol $::gdbm::lib gdbm_errno]
114
115#
116# bindings
117#
118::ffidl::callout ::gdbm::gdbm_open {pointer-utf8 int int int pointer} GDBM_FILE [::ffidl::symbol $::gdbm::lib gdbm_open]
119::ffidl::callout ::gdbm::gdbm_close {GDBM_FILE} void [::ffidl::symbol $::gdbm::lib gdbm_close]
120::ffidl::callout ::gdbm::gdbm_store {GDBM_FILE gdbm_datum gdbm_datum int} int [::ffidl::symbol $::gdbm::lib gdbm_store]
121::ffidl::callout ::gdbm::gdbm_fetch {GDBM_FILE gdbm_datum} gdbm_datum [::ffidl::symbol $::gdbm::lib gdbm_fetch]
122::ffidl::callout ::gdbm::gdbm_delete {GDBM_FILE gdbm_datum} int [::ffidl::symbol $::gdbm::lib gdbm_delete]
123::ffidl::callout ::gdbm::gdbm_firstkey {GDBM_FILE} gdbm_datum [::ffidl::symbol $::gdbm::lib gdbm_firstkey]
124::ffidl::callout ::gdbm::gdbm_nextkey {GDBM_FILE gdbm_datum} gdbm_datum [::ffidl::symbol $::gdbm::lib gdbm_nextkey]
125::ffidl::callout ::gdbm::gdbm_reorganize {GDBM_FILE} int [::ffidl::symbol $::gdbm::lib gdbm_reorganize]
126::ffidl::callout ::gdbm::gdbm_sync {GDBM_FILE} void [::ffidl::symbol $::gdbm::lib gdbm_sync]
127::ffidl::callout ::gdbm::gdbm_exists {GDBM_FILE gdbm_datum} int [::ffidl::symbol $::gdbm::lib gdbm_exists]
128::ffidl::callout ::gdbm::gdbm_setopt {GDBM_FILE int pointer-byte int} int [::ffidl::symbol $::gdbm::lib gdbm_setopt]
129::ffidl::callout ::gdbm::gdbm_strerror {int} pointer-utf8 [::ffidl::symbol $::gdbm::lib gdbm_strerror]
130
131#
132# helpers, create or extract the gdbm_datum structure
133# note, these are currently built for string, ie utf8,
134# data, so its important that each datum created has
135# the nul terminator included.
136#
137# this could be rewritten to allow binary data.
138#
139proc make-datum {string} {
140    if {[string length $string] == 0} {
141	binary format [::ffidl::info format gdbm_datum] 0 0
142    } else {
143	binary format [::ffidl::info format gdbm_datum] [::ffidl::get-string $string] [expr {1+[string length $string]}]
144    }
145}
146proc extract-datum {datum} {
147    binary scan $datum [::ffidl::info format gdbm_datum] string length
148    if {$string == 0} {
149	set result {}
150    } else {
151	set result [::ffidl::pointer-into-string $string]
152	::ffidl::free $string
153    }
154    set result
155}
156
157#
158# commands
159#
160proc ::gdbm::cmd-open {file {mode r}} {
161    variable nhandle
162    variable handles
163    variable writemodes
164    variable modes
165    variable constants
166    set h [gdbm_open $file 0 $constants($modes($mode)) 0644 0]
167    if {$h == 0} { error "could not open: $file" }
168    set name gdbm[incr nhandle]
169    set handles($name) $h
170    set writemodes($name) GDBM_REPLACE
171    set name
172}
173proc ::gdbm::cmd-close {name} {
174    variable handles
175    variable writemodes
176    set h $handles($name)
177    unset handles($name)
178    unset writemodes($name)
179    gdbm_close $h
180}
181proc ::gdbm::cmd-insert {name key content} {
182    variable handles
183    variable constants
184    switch [gdbm_store $handles($name) [make-datum $key] [make-datum $content] $constants(GDBM_INSERT)] {
185	0 { return }
186	1 { error "cannot insert \"$key\" into database, key already exists" }
187	-1 { error "cannot insert \"$key\" into database, not opened for writing or invalid data" }
188    }
189}
190proc ::gdbm::cmd-store {name key content} {
191    variable handles
192    variable writemodes
193    variable constants
194    switch [gdbm_store $handles($name) [make-datum $key] [make-datum $content] $constants($writemodes($name))] {
195	0 { return }
196	1 { error "cannot insert \"$key\" into database, key already exists" }
197	-1 { error "cannot insert \"$key\" into database, not opened for writing or invalid data" }
198    }
199}
200proc ::gdbm::cmd-fetch {name key} {
201    variable handles
202    extract-datum [gdbm_fetch $handles($name) [make-datum $key]]
203}
204proc ::gdbm::cmd-delete {name key} {
205    variable handles
206    gdbm_delete $handles($name) [make-datum $key]
207}
208proc ::gdbm::cmd-exists {name key} {
209    variable handles
210    gdbm_exists $handles($name) [make-datum $key]
211}
212proc ::gdbm::cmd-list {name} {
213    variable handles
214    set format [::ffidl::info format gdbm_datum]
215    set list {}
216    set key [gdbm_firstkey $handles($name)]
217    binary scan $key $format string length
218    while {$string != 0} {
219	lappend list [::ffidl::pointer-into-string $string]
220	set key [gdbm_nextkey $handles($name) $key]
221	::ffidl::free $string
222	binary scan $key $format string length
223    }
224    set list
225}
226proc ::gdbm::cmd-reorganize {name} {
227    variable handles
228    gdbm_reorganize $handles($name)
229}
230proc ::gdbm::cmd-firstkey {name} {
231    variable handles
232    extract-datum [gdbm_firstkey $handles($name)]
233}
234proc ::gdbm::cmd-nextkey {name lastkey} {
235    variable handles
236    extract-datum [gdbm_nextkey $handles($name) [make-datum $lastkey]]
237}
238proc ::gdbm::cmd-error {which} {
239    variable symbols
240    switch $which {
241	number { peek-int $symbols(gdbm_errno) }
242	text { gdbm_strerror [peek-int gdbm_errno] }
243	default { error "usage: gdbm error number|text" }
244    }
245}
246proc ::gdbm::cmd-writemode {name writemode} {
247    variable handles
248    variable writemodes
249    switch $which {
250	replace { set writemodes($name) GDBM_REPLACE }
251	insert { set writemodes($name) GDBM_INSERT }
252	default { error "usage: gdbm writemode name replace|insert" }
253    }
254}
255
256proc gdbm args {
257    if {[llength $args] == 0} {
258	error "usage: gdbm open|close|insert|store|fetch|delete|exists|list|reorganize|firstkey|nextkey|error|writemode"
259    }
260    eval ::gdbm::cmd-[lindex $args 0] [lrange $args 1 end]
261}
262