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