TSV - an [incr tcl] class
TSV object -formatInfo something -recordType something -formatArray something -line something -keyFields {} -seeDeleted 0
inherits
object configure
config
object pull_header
object header
object field_index
fieldName
object open
fileName headerFile ""
object isopen
object rewind
object location_of_last_record
object headerless_open
fileType dataFileName
object create
fileType dataFileName
object headerless_create
fileType dataFileName
object tell
object seek
where offset "start"
object size
object query
arrayName fields expression callout
object nquery
arrayName expression callout
object fetch
varName
object fetch_to_array
arrayName
object store_from_array
arrayName
object delete_record_at_location
deletePosition
object append_from_array
arrayName
object line
object fetch_fields_to_array
arrayName args
object array_to_list
arrayName
object reindex
object close
#@package: tsv-database-2 TSV TSVsearcher # # Copyright (C) 1992-1996 NeoSoft. # # Permission to use, copy, modify, and distribute this software and its # documentation for any purpose and without fee is hereby granted, provided # that the above copyright notice appear in all copies. NeoSoft makes no # representations about the suitability of this software for any purpose. # It is provided "as is" without express or implied warranty. # # Class library for handling Tcl list-style tabular files with headers. # # $Id: neodb.html,v 1.1.1.1 1999/03/31 20:34:36 damon Exp $ # # # TSV class - create object for manipulating files of Tcl record-oriented, # list-separated values. # constructor {config} { } destructor { close } method configure {config} { } # read in and save the header containing the field names method pull_header {} { if {[gets $fp formatInfo] < 0} {error "no header line"} set idx 0 foreach field $formatInfo { set formatArray($field) $idx incr idx } if {[gets $fp blankLine] < 0} {error "no header second line"} if {$blankLine != ""} { error "second header line isn't blank, file probably doesn't have a header" } } # return the header as a list method header {} { return $formatInfo } # return the list index of a field based on the field name method field_index {fieldName} { return $formatArray($fieldName) } # open a Tcl list-oriented database with header line method open {fileName {headerFile ""}} { if {$fp != ""} close set databaseFileName $fileName set fp [::open $fileName "RDONLY"] set recordType [lindex [split [file tail $fileName] "."] 0] pull_header set dataStart [tell] set locationOfLastRecord $dataStart return } # return 1 if database is currently open, 0 otherwise method isopen {} { return [expr {$fp != ""}] } method rewind {} { seek $dataStart } method location_of_last_record {} { return $locationOfLastRecord } # open a Tcl list-oriented database with header line from a separate file method headerless_open {fileType dataFileName} { set databaseFileName $dataFileName open headers/$fileType.tsv close set fp [::open $dataFileName "RDONLY"] set dataStart 0 return } # create a Tcl list-oriented database method create {fileType dataFileName} { open headers/$fileType.tsv close set fp [::open $dataFileName "WRONLY APPEND CREAT TRUNC"] set databaseFileName $dataFileName flock -write $fp puts $fp "$formatInfo" puts $fp "" set dataStart [tell] return } # create a Tcl list-oriented database method headerless_create {fileType dataFileName} { open headers/$fileType.tsv close set fp [::open $dataFileName "WRONLY APPEND CREAT TRUNC"] set databaseFileName $dataFileName set dataStart 0 return } # return the current seek offset into the database method tell {} { return [::tell $fp] } # seek to a given offset in the database method seek {where {offset "start"}} { ::seek $fp $where $offset return } # return the size of the file in bytes method size {} { return [fstat $fp size] } # # query method - takes array name and fields to fetch into the # array. # # For all records, reads and assigns fields into array, then # evalues expression. If expression returns nonzero, # query executes the named callout routine, with arguments # being the name of the object being queried, the offset to # the start of the current record in the database where the # matching record was found, and the name of the array that # the fields are in. # method query {arrayName fields expression callout} { rewind while {[eval fetch_fields_to_array $arrayName $fields]} { if {[catch {set exprResult [expr $expression]} result] == 1} { error "error in expression: $expression: $result" } if $exprResult {eval $callout $this $locationOfLastRecord $arrayName} } rewind } method nquery {arrayName expression callout} { rewind upvar $arrayname array while {[eval fetch_to_array array]} { if {[catch {set exprResult [expr $expression]} result] == 1} { error "error in expression: $expression: $result" } if $exprResult {eval $callout $this $locationOfLastRecord array} } rewind } # fetch a record from the database and return it as a list # into the specified variable. Return 1 on success or 0 on # failure. method fetch {varName} { upvar $varName line set locationOfLastRecord [tell] if {[gets $fp line] < 0} {return 0} return 1 } # Fetch a record from the database and return it inside # an array, where each field is a value in the array with # the array key being set to the field name defined in the header. method fetch_to_array {arrayName} { catch {uplevel unset $arrayName} upvar $arrayName array while 1 { set locationOfLastRecord [tell] if {[gets $fp line] < 0} {return 0} eval lassign_array [list $line] array $formatInfo if {[info exists array(_status)] && $array(_status) == "-"} { if {$seeDeleted} {return 1} continue } return 1 } } # Take a record inside an array where the array keys are the # names of fields and the values are the values to be # written, and create a new record with the fields in the # right order. method store_from_array {arrayName} { upvar $arrayName array set array(_status) "+" puts $fp "[array_to_list array]" return 1 } method delete_record_at_location {deletePosition} { seek $deletePosition if {[read $fp 1] != "+"} { error "Position not at start of record or db not delete-capable." } ::close $fp set fp [::open $databaseFileName "RDWR"] flock -write $fp 0 0 end seek $deletePosition puts $fp "-" nonewline sync $fp ::close $fp set fp [::open $databaseFileName "RDONLY"] seek $deletePosition } method append_from_array {arrayName} { upvar $arrayName array set readPosition [tell] ::close $fp set fp [::open $databaseFileName "CREAT WRONLY APPEND"] flock -write $fp 0 0 end seek 0 end set writePosition [tell] set array(_status) "+" puts $fp "[array_to_list array]" sync $fp ::close $fp set fp [::open $databaseFileName "RDONLY"] seek $readPosition return $writePosition } # return the list-style text of the last record read method line {} { return $line } # Fetch a record from the database and return selected # fields in an array, where each selected field is a # value in the array with the corresponding array # key being set to the field name defined in the header. method fetch_fields_to_array {arrayName args} { catch {uplevel unset $arrayName} upvar $arrayName array while 1 { set locationOfLastRecord [tell] if {[gets $fp line] < 0} {return 0} eval lassign_fields [list $line] formatArray array "_status $args" if {[info exists array(_status)] && $array(_status) == "-"} { if {$seeDeleted} {return 1} continue } return 1 } } method array_to_list {arrayName} { upvar $arrayName array foreach field $formatInfo { lappend result $array($field) } return $result } method reindex {} { if {$keyFields == ""} return foreach keyField $keyFields { set indexes($keyField) [TSVsearcher #auto] $indexes($keyField) create } $tsvid query x $indexFieldName 1 "$this reindex-write" foreach keyField $keyFields { $keyField reindex } } # close the database method close {} { if {$fp == ""} return ::close $fp set fp "" } protected dataStart protected fp "" protected locationOfLastRecord protected databaseFileName public formatInfo public recordType public formatArray public line public keyFields "" public seeDeleted 0
TSVindex - an [incr tcl] class
TSVindex object -tsvid something
inherits TSVsearcher
object configure
config
object fetch
id varName
object fetch_to_array
id arrayName
object fetch_fields_to_array
id arrayName args
object reindex
callback ""
# # class to use index files generated by genindex # to lookup items in a database object open by the TSV class. # # Usage: # # TSV customer # TSV open customer.tsv # # TSVindex customer-index customer # TSVindex open customer.ID-index # # customer-index fetch ABWAM x # # customer-index configure -searchType fuzzy # customer-index configure -searchType exact # inherit TSVsearcher # special constructor - requires an instance of the # TSV object as an argument, and the name of the # field this index is for. constructor {TSVinstance config} { set tsvid $TSVinstance } method configure {config} { } # look up a record using the key field and fetch # as a list into the named variable. method fetch {id varName} { upvar $varName result set where [locate $id] if {$where == -1} {return 0} $tsvid seek $where return [$tsvid fetch result] } # look up a record using the key field # and fetch into an array of key-value pairs. method fetch_to_array {id arrayName} { upvar $arrayName myArray set where [locate $id] if {$where == -1} {return 0} $tsvid seek $where return [$tsvid fetch_to_array myArray] } # look up a record using the key field # and fetch specific elements into an array of key-value pairs. method fetch_fields_to_array {id arrayName args} { upvar $arrayName myArray set where [locate $id] if {$where == -1} {return 0} $tsvid seek $where return [eval $tsvid fetch_fields_to_array myArray $args] } method reindex {{callback ""}} { close open $indexFilename c $tsvid query x $indexFieldName 1 "$this reindex-write" } public tsvid
TSVsearcher - an [incr tcl] class
TSVsearcher object -searchType exact -indexFilename {} -deferredOpen 0 -relockEvery 0
inherits
object configure
config
object key
action varName
object find_and_key
action id varName
object locate
id
object search
pattern varName callout searchtype "-exact"
object open_now
mode
object close_now
object open
name mode "rl"
object create
name
object write
key value
object close
# # Class library to create and manipulate index files # using dbopen's btree structures. # # Mostly only inherited by TSVindex, but has other # interesting standalone possibilities. # # constructor {config} { } destructor { close } method configure {config} { } # # key first varname # key next varname # key previous varname # key last varname # # Traverse the btree forwards and backwards. # method key {action varName} { upvar $varName var if $deferredOpen { error "key method invalid with deferred open, use find_and_key instead" } set result [db seq $indexfp $action var] return $result } # # key first varname # key next varname # key previous varname # key last varname # # Traverse the btree forwards and backwards. # method find_and_key {action id varName} { upvar $varName var open_now "rl" db seq $indexfp cursor $id dummy set result [db seq $indexfp $action var] close_now return $result } # look up a record using the key field. method locate {id} { open_now "rl" if {$searchType == "exact"} { if ![db get $indexfp $id numindex] { close_now return -1 } } else { if ![db seq $indexfp cursor $id matchName] { close_now return -1 } if ![db get $indexfp $matchName numindex] { close_now return -1 } } close_now return $numindex } # # search the index file for something matching pattern, # call function name stored in callout everytime one is # found, with object, offset and matching string as arguments. # method search {pattern varName callout {searchtype "-exact"}} { open_now "rl" db searchall $indexfp $varName $searchtype $pattern $callout close_now } method open_now {mode} { if !$deferredOpen { if !$relockEvery return incr relockRemaining -1 if {$relockRemaining > 0} return set relockRemaining $relockEvery close } set indexfp [db open $indexFilename btree $mode] } method close_now {} { if !$deferredOpen return close } # open an index file method open {name {mode "rl"}} { close set indexFilename $name if !$deferredOpen { set indexfp [db open $name btree $mode] set relockRemaining $relockEvery } return } method create {name} { open $name "ctL" } method write {key value} { open_now "wL" db put $indexfp $key $value db sync $indexfp close_now } # close an index file method close {} { if {$indexfp == ""} return db close $indexfp set indexfp "" } protected indexfp "" protected searchString protected searchContext protected relockRemaining 0 public searchType "exact" public indexFilename "" public deferredOpen 0 public relockEvery 0