software/tcl/dbfreader.tcl

   1 #
   2 # Dbfreade package - reads dbf file
   3 #
   4
   5 #
   6 # Dbf files seldom use KOI8
   7 #
   8 package require recode
   9 #
  10 # Read header of file and return list of fields. Also fill global array
  11 # with name same as file handle
  12 #
  13 proc dbf_readheader {file} {
  14 upvar #0 $file info
  15 fconfigure $file -translation binary
  16 set rec [read $file 32]
  17 binary scan $rec "cccciss" info(version) year month day info(reccount) info(offset) info(reclen)
  18 set info(datestamp) [clock scan "$month/$day/$year"]
  19 set info(fieldcount) [expr {($info(offset)-1)/32-1}]
  20 set recoffset 1
  21 for {set i 1} {$i<=$info(fieldcount)} {incr i} {
  22    set rec [read $file 32]
  23    binary scan $rec "a11ax4cc" info(name,$i) info(type,$i) info(len,$i) \
  24           info(dec,$i)
  25    set info(ofs,$i) $recoffset
  26    incr recoffset $info(len,$i)
  27 }
  28 read $file 1
  29 }
  30 #
  31 # Opens DBF file with given name.
  32 # Fills all neccesary information
  33 # and returns file descriptor
  34 #
  35 proc opendbf filename {
  36 global errorCode
  37     if [catch {open $filename} res] {
  38        return -code error -errorcode $errorCode $res
  39    }
  40    dbf_readheader $res
  41    return $res
  42 }
  43 #
  44 # Position dbf file to given record
  45 #
  46 proc dbf_seek {file recno} {
  47 upvar #0 $file info
  48 if {![array exists info]||![info exists info(version)]} {
  49   return -code error "No structure information exists for $file"
  50 }
  51 if {$recno>$info(reccount)||$recno<0} {
  52   return -code error "No such record: $recno"
  53 }
  54 seek $file [expr {$info(offset)+$info(reclen)*(int($recno)-1)}]
  55 }
  56
  57 #
  58 # Get next record
  59 #
  60 proc dbf_getrec {file} {
  61 upvar #0 $file info
  62 if {![array exists info]||![info exists info(version)]} {
  63   return -code error "No structure information exists for $file"
  64 }
  65 set rec [read $file $info(reclen)]
  66 set first 1
  67 set last 0
  68 set list {}
  69 for {set i 1} {$i<=$info(fieldcount)} {incr i} {
  70   set len $info(len,$i)
  71   incr last $len
  72   set tmp [string trim [string range $rec $first $last]]
  73   incr first $len
  74   switch "$info(type,$i)" {
  75   "D" {
  76         if [regexp {([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])} \
  77                   $tmp jnk y m d] {
  78            set tmp "$m/$d/$y"
  79         }
  80       }
  81   "N" {
  82         if ![string length $tmp] {
  83           set tmp 0
  84         }
  85       }
  86   "L" { if [string length $tmp] {
  87           set tmp [regexp {^[YyTt1]} $tmp]
  88         }
  89       }
  90   "C" {
  91       set tmp [recode -input cp866 $tmp]
  92   }
  93   }
  94   lappend list $tmp
  95 }
  96 return $list
  97 }
  98
  99 #
 100 # checkdbf - checks if structure matches given list of fields and types
 101 # Raises error and returns message if something doesn't match
 102 #
 103 proc checkdbf {file fieldlist  typelist } {
 104    upvar #0 $file info
 105    set i 1
 106    foreach f $fieldlist t $typelist {
 107       if {![info exists info(name,$i)]} {
 108           return -code error "Not enough fields. $f expected"
 109       }
 110       if {"$info(name,$i)"!="$f"} {
 111          return -code error "Field # $i doesn't match: $info(name,$i) while $f expected"
 112       }
 113       if {"$info(type,$i)"!="[lindex $t 0]"} {
 114          return -code error "Field $f type mismatch $info(type,$i) found [lindex $t 0] expected."
 115       }
 116       if {$info(len,$i)!=[lindex $t 1]} {
 117          return -code error "Field $f size mismatch $info(len,$i) found [lindex $t 1] expected."
 118       }
 119       if {"$info(type,$i)"=="N"&&[lindex $t 2]!=$info(dec,$i)} {
 120          return -code error "Field $f decimal places mismatch $info(dec,$i) found [lindex $t 2] expected."
 121       }
 122       incr i
 123    }
 124    if {$i<=$info(fieldcount)} {
 125       return -code error "Extra field $info(name,$i)"
 126    }
 127    return ""
 128 }
 129
 130 #
 131 # reccount - returns count of records
 132 #
 133 proc reccount file {
 134     upvar #0 $file info
 135     if ![info exist info(reccount)] {
 136         return -code error "$f is not a dBase file"
 137     }
 138     return $info(reccount)
 139 }
 140
 141 #
 142 # fieldlist - return list of fields
 143 #
 144 proc fieldlist file {
 145    upvar #0 $file info
 146    set list {}
 147    for {set i 1} {$i<=$info(fieldcount)} {incr i} {
 148        lappend list $info(name,$i)
 149    }
 150    return $list
 151 }
 152
 153 #
 154 # closedbf - closes file and frees data structure
 155 #
 156 proc closedbf {file} {
 157 global errorCode
 158 if ![uplevel #0 info exists $file] {
 159    return -code error "$file is not a dBase file"
 160 }
 161 if [catch {close $file} msg] {
 162    return -code error -errorcode $errorCode $msh
 163 }
 164 uplevel #0 unset $file
 165 }
 166 #
 167 # scandbf file script
 168 # executes script for each record in the file, appending record number
 169 # and all field values to it.
 170 proc scandbf {file script} {
 171     dbf_seek $file 1
 172     upvar #0 $file info
 173     set n 1
 174     while {$n<=$info(reccount)} {
 175        uplevel $script $n [dbf_getrec $file]
 176        incr n
 177     }
 178 }
 179
 180 package provide Dbfreader "1.0"
 181
 182