## Table of Contents

TSV
TSVindex
TSVsearcher

[next] [TOC]

## Command

TSV - an [incr tcl] class

### Synopsis

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

### Description

    #@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

[next] [prev] [TOC]

## Command

TSVindex - an [incr tcl] class

### Synopsis

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 ""

### Description

    #
    # 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

[prev] [TOC]

## Command

TSVsearcher - an [incr tcl] class

### Synopsis

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

### Description

    #
    # 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