#@package: tsv-database-2 TSV TSVsearcher

package require Itcl

#
# Copyright (C) 1992-1997 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: tsv-class.tcl,v 1.1.1.1 1999/03/31 20:34:40 damon Exp $
#

set quote \"

#
# TSV class - create object for manipulating files of Tcl record-oriented,
# list-separated values.
#
itcl_class TSV {
    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
}

#
# Class library to create and manipulate index files
# using dbopen's btree structures.
#
# Mostly only inherited by TSVindex, but has other
# interesting standalone possibilities.
#
#
itcl_class TSVsearcher {

    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
}

#
# 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
#
itcl_class TSVindex {
    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
}

