# $Id: dbfreader.tcl,v 1.3 2012/01/02 16:17:40 joheid Exp $
 # dbase III file reader package
 # returns the data as dict, keys are the record numbers
 # based on the original code of Vitus Wagner
 # rewritten as snit component
 # (C) Vitus Wagner, Joachim Heidemeier 
 # published under the Tcl License
 # 
 # public methods
 # readData read the datafile into the dict
 # 
 #
 package require snit
 package provide dbasereader 0.5
 snit::type dbasefile {
 #
 # daten as list of lists
   variable fData
 # array holding information like nrow ncol
    variable info
    variable fh "none" ;# filehandle, wird in OpenDbf gesetzt
 #
 # normally used as component
    option -partof
 #
    option -filename {}
 # encoding
    option -encoding -default iso8859-1 -validatemethod encodingAvailable
 #   
    constructor {args} {
        set info(read) 0
        $self configurelist $args
    }
 #
    method encodingAvailable {option value} {
        if {[lsearch -exact [encoding names] $value] == -1} { 
            error "requested encoding $value not available"
        }
    }
 #
 # local methods
 # file == filehandle
 #
 method ReadHeader {} {
 fconfigure $fh -translation binary
 set rec [read $fh 32]
 binary scan $rec "cccciss" info(version) year month day info(nRow) info(offset) info(reclen)
 catch {set info(datestamp) [clock scan "$month/$day/[expr 1900 + $year]"]}
 set info(nCol) [expr {($info(offset)-1)/32-1}]
 set recoffset 1
 for {set i 1} {$i<=$info(nCol)} {incr i} {
   set rec [read $fh 32]
   binary scan $rec "A11Ax4cc" info(name,$i) info(type,$i) info(len,$i) \
          info(dec,$i) 
 # 
 # convert info(len) into unsigned int
 #
    set info(len,$i) [expr $info(len,$i) & 0xff]
   set info(ofs,$i) $recoffset
   incr recoffset $info(len,$i)
 }
 read $fh 1
 }
 #
 # Opens DBF file with given name.
 # Fills all neccesary information
 # sets file descriptor
 # and reads file header
 #
 method  OpenDbf {} {
    set info(read) 0
    if {[catch {open $options(-filename)} res]} {
       return -code error "$res"
    }
   set fh $res
   $self ReadHeader
   return
    }

 #
 # Position dbf file to given record
 # 
 method Dbfseek {recno} {
        if {![array exists info]||![info exists info(version)]} {
            return -code error "No structure information exists for $info(fh)"
        }
        if {$recno>$info(nRow)||$recno<0} {
            return -code error "No such record: $recno"
        }
        seek $fh [expr {$info(offset)+$info(reclen)*(int($recno)-1)}]
    }

 #
 # Get and decode next record
 #
 method GetNextRec {} {
 if {![array exists info]||![info exists info(version)]} {
  return -code error "No structure information exists for $info(fh)"
 }
 set rec [read $fh $info(reclen)]
 set first 1
 set last 0
 set reclist {}
 for {set i 1} {$i<=$info(nCol)} {incr i} {
     set len $info(len,$i)
     incr last $len
     set tmp [string trim [string range $rec $first $last]]
     incr first $len
     switch "$info(type,$i)" {
         "D" { 
             if {[regexp {([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])} \
                  $tmp jnk y m d]} {
                 set tmp "$m/$d/$y"
             }
         }
         "N" { 
             if {![string length $tmp]} {
                 set tmp 0
             }
         }
         "L" { 
             if {[string length $tmp]} {
                 set tmp [regexp {^[YyTt1]} $tmp]
             }
         }
         "C" { 

             set tmp [encoding convertfrom $options(-encoding) $tmp]
         }  
     }
     lappend reclist $tmp 
 }
     return $reclist
 }

   #
   # checkdbf - checks if structure matches given list of fields and types
   # Raises error and returns message if something doesn't match
   #
   method checkdbf {fieldlist  typelist } {
       set i 1 
       foreach f $fieldlist t $typelist {
           if {![info exists info(name,$i)]} {
               return -code error "Not enough fields. $f expected"
           } 
           if {"$info(name,$i)"!="$f"} {
               return -code error "Field # $i doesn't match: $info(name,$i) while $f expected"
           }
           if {"$info(type,$i)"!="[lindex $t 0]"} {
               return -code error "Field $f type mismatch $info(type,$i) found [lindex $t 0] expected."
      }
      if {$info(len,$i)!=[lindex $t 1]} {
         return -code error "Field $f size mismatch $info(len,$i) found [lindex $t 1] expected."
      }
      if {"$info(type,$i)"=="N"&&[lindex $t 2]!=$info(dec,$i)} {
         return -code error "Field $f decimal places mismatch $info(dec,$i) found [lindex $t 2] expected."
      }
           incr i
       } 
       if {$i<=$info(nCol)} {
           return -code error "Extra field $info(name,$i)"
       }
       return ""
   }

   #
   # closedbf - closes file and frees data structure
   #
   method CloseDbf {} {

    if {(![info exists fh]) || ($fh ne $fh)}  {
        return -code error "$info(fh) is not a dBase file"
    }
    if {[catch {close $fh} msg]} {
        unset fh
        return -code error -errorcode $errorCode $msh
    }
 }
   method AddRow {n datalist}  {
       dict append fData  $n $datalist
   }
   #
   #
   # readData
   # reads all files
   # and all field values to it.

   method readData {} {
    if {!$info(read)} {
    set fData [dict create] 
    if {$fh eq "none"} {$self OpenDbf}    
    $self Dbfseek 1 
    set n 1
    while {$n<=$info(nRow)} {
        $self AddRow  $n [$self GetNextRec]
        incr n
    }
    $self CloseDbf
    set info(read) 1
    return 0    
    } else {
        return {file already read}
    }
    
 }
 # schreibt Spalten und Zeileninfos sowie Datum raus
 method dbfInfo {} {
    if {!$info(read)} {
        return {no dbf-file read}
    } else {
    set colInfo [list]
    for {set i 1} {$i <= $info(nCol)} {incr i} {
        lappend colInfo [list "col $i" $info(name,$i) $info(type,$i) $info(len,$i) \
          $info(dec,$i)] 
    }
    return [list $info(nRow) $info(nCol) $colInfo $info(datestamp) ]
    }
 }
 # return one or all records
 method data {{recnr all}} {
    if {"$recnr" eq "all"} {
        return $fData
    } elseif {[string is integer $recnr] && $recnr <= $info(nRow)} {
        return [dict filter $fData key $recnr]
    } else {error "Record $recnr not available"}
 }
 }
 # testscript
 if {0} {
 catch {d1 destroy}
 dbasefile d1 -filename [tk_getOpenFile]
 d1 readData
 set x [d1 dbfInfo]
 set y [d1 data]
 }