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 1998/08/06 18:20:55 gporter 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