# $Id: s.TclGdbmStorage.xotcl 1.7 01/03/23 21:55:32+01:00 neumann@somewhere.wu-wien.ac.at $
package provide xotcl::store::tclgdbm 0.84

package require xotcl::store::gdbm
package require xotcl::store

#
# a simple GNU Gdbm DB Store Access based on TclGdbm
#
Class Storage=TclGdbm -superclass Storage
Storage=TclGdbm instproc open f {
  ::set [self]::persistenceDB [gdbm_open -wrcreat $f]
}

Storage=TclGdbm instproc set args {
  ::set l [llength $args]
  if {$l == 1} {[::set [self]::persistenceDB] fetch [lindex $args 0]
  } elseif {$l == 2} {[::set [self]::persistenceDB] -replace store \
	   [lindex $args 0] [lindex $args 1]
  } else { next }
}

Storage=TclGdbm instproc exists k {
  [::set [self]::persistenceDB] exists $k
}

Storage=TclGdbm instproc names {} {
  [self] instvar persistenceDB
  ::set list ""
  if {[::set key [$persistenceDB firstkey]] != ""} {
    lappend list $key
    while {[::set key [$persistenceDB nextkey $key]] != ""} {
      lappend list $key
    }
  }
  return $list
}


Storage=TclGdbm instproc close args {
  [::set [self]::persistenceDB] close
}

Storage=TclGdbm instproc unset k {
  [::set [self]::persistenceDB] delete $k
}
