software/tcl/dbf.tcl

   1 #
   2 # dbf package - read and write dbf file
   3 #
   4
   5 #
   6 # Read header of file and return list of fields. Also fill global array
   7 # with name same as file handle
   8 #
   9 proc dbf_readheader {file} {
  10     upvar #0 $file info
  11     seek $file 0
  12     set rec [read $file 32]
  13     binary scan $rec "cccciss" info(version) year month day info(reccount) info(offset) info(reclen)
  14     set info(datestamp) [clock scan "$month/$day/$year"]
  15     set info(fieldcount) [expr {($info(offset)-1)/32-1}]
  16     set recoffset 1
  17     for {set i 1} {$i<=$info(fieldcount)} {incr i} {
  18        set rec [read $file 32]
  19        binary scan $rec "a11ax4cc" info(name,$i) info(type,$i) info(len,$i) \
  20               info(dec,$i)
  21        set info(ofs,$i) $recoffset
  22        incr recoffset $info(len,$i)
  23     }
  24     read $file 1
  25 }
  26
  27 #
  28 # Opens DBF file with given name.
  29 # Fills all neccesary information
  30 # and returns file descriptor
  31 #
  32 proc opendbf filename {
  33     global errorCode
  34     if [catch {open $filename r+} res] {
  35        return -code error -errorcode $errorCode $res
  36     }
  37     fconfigure $res -encoding cp866 -translation binary
  38     dbf_readheader $res
  39     return $res
  40 }
  41
  42 #
  43 # Position dbf file to given record
  44 #
  45 proc dbf_seek {file recno} {
  46     upvar #0 $file info
  47     if {![array exists info]||![info exists info(version)]} {
  48         return -code error "No structure information exists for $file"
  49     }
  50     if {$recno>$info(reccount)||$recno<0} {
  51         return -code error "No such record: $recno"
  52     }
  53     seek $file [expr {$info(offset)+$info(reclen)*(int($recno)-1)}]
  54 }
  55
  56 #
  57 # Get next record
  58 #
  59 proc dbf_getrec {file} {
  60     upvar #0 $file info
  61     if {![array exists info]||![info exists info(version)]} {
  62         return -code error "No structure information exists for $file"
  63     }
  64     set rec [read $file $info(reclen)]
  65     set first 1
  66     set last 0
  67     set list {}
  68     for {set i 1} {$i<=$info(fieldcount)} {incr i} {
  69         set len $info(len,$i)
  70         incr last $len
  71         set tmp [string trim [string range $rec $first $last]]
  72         incr first $len
  73         switch "$info(type,$i)" {
  74             "D" {
  75                    if [regexp {([0-9][0-9][0-9][0-9])([0-9][0-9])([0-9][0-9])} \
  76                       $tmp jnk y m d] {
  77                           set tmp "$m/$d/$y"
  78                    }
  79                  }
  80             "N" {
  81                    if ![string length $tmp] {
  82                        set tmp 0
  83                    }
  84                  }
  85             "L" { if [string length $tmp] {
  86                       set tmp [regexp {^[YyTt1]} $tmp]
  87                   }
  88                  }
  89             "C" {
  90                   set tmp [encoding convertfrom cp866 $tmp]
  91                 }
  92         }
  93         lappend list $tmp
  94     }
  95     return $list
  96 }
  97
  98 #
  99 # checkdbf - checks if structure matches given list of fields and types
 100 # Raises error and returns message if something doesn't match
 101 #
 102 proc checkdbf {file fieldlist  typelist } {
 103    upvar #0 $file info
 104    set i 1
 105    foreach f $fieldlist t $typelist {
 106       if {![info exists info(name,$i)]} {
 107           return -code error "Not enough fields. $f expected"
 108       }
 109       if {"$info(name,$i)"!="$f"} {
 110          return -code error "Field # $i doesn't match: $info(name,$i) while $f expected"
 111       }
 112       if {"$info(type,$i)"!="[lindex $t 0]"} {
 113          return -code error "Field $f type mismatch $info(type,$i) found [lindex $t 0] expected."
 114       }
 115       if {$info(len,$i)!=[lindex $t 1]} {
 116          return -code error "Field $f size mismatch $info(len,$i) found [lindex $t 1] expected."
 117       }
 118       if {"$info(type,$i)"=="N"&&[lindex $t 2]!=$info(dec,$i)} {
 119          return -code error "Field $f decimal places mismatch $info(dec,$i) found [lindex $t 2] expected."
 120       }
 121       incr i
 122    }
 123    if {$i<=$info(fieldcount)} {
 124       return -code error "Extra field $info(name,$i)"
 125    }
 126    return ""
 127 }
 128
 129 #
 130 # reccount - returns count of records
 131 #
 132 proc reccount file {
 133     upvar #0 $file info
 134     if ![info exist info(reccount)] {
 135         return -code error "$f is not a dBase file"
 136     }
 137     return $info(reccount)
 138 }
 139
 140 #
 141 # fieldlist - return list of fields
 142 #
 143 proc fieldlist file {
 144    upvar #0 $file info
 145    set list {}
 146    for {set i 1} {$i<=$info(fieldcount)} {incr i} {
 147        lappend list $info(name,$i)
 148    }
 149    return $list
 150 }
 151
 152 #
 153 # closedbf - closes file and frees data structure
 154 #
 155 proc closedbf {file} {
 156     global errorCode
 157     upvar #0 $file info
 158     if ![info exists info] {
 159         return -code error "$file is not a dBase file"
 160     }
 161     seek $file 4
 162     puts -nonewline $file [binary format i $info(reccount)]
 163     if [catch {close $file} msg] {
 164         return -code error -errorcode $errorCode $msh
 165     }
 166     uplevel #0 unset $file
 167 }
 168
 169 #
 170 # scandbf file script
 171 # executes script for each record in the file, appending record number
 172 # and all field values to it.
 173 proc scandbf {file script} {
 174     dbf_seek $file 1
 175     upvar #0 $file info
 176     set n 1
 177     while {$n<=$info(reccount)} {
 178        uplevel $script $n [dbf_getrec $file]
 179        incr n
 180     }
 181 }
 182
 183 #
 184 # dbf_addrec file value value value ...
 185 #
 186 proc dbf_addrec {file args} {
 187     upvar #0 $file info
 188     if ![info exists info] {
 189         return -code error "$file is not a dBase file"
 190     }
 191     if {[llength $args] < $info(fieldcount)} {
 192         return -code error -errorcode "Too not enouth fields in fieldlist" "Too not enouth fields in fieldlist"
 193     }
 194     seek $file [expr {$info(offset)+$info(reclen)*$info(reccount)}]
 195     set rec "\x20"
 196     for {set i 1} {$i<=$info(fieldcount)} {incr i} {
 197         set field [lindex $args [expr $i - 1]]
 198         set len $info(len,$i)
 199         set type $info(type,$i)
 200         switch "$info(type,$i)" {
 201             "D" {
 202                   if {![catch {clock scan $field}]} {
 203                       append rec [clock format [clock scan $field] -format {%Y%m%d}]
 204                   } else {
 205                       return -code error -errorcode "Bad value $field in fieltype $type" "Bad value $field in fieldtype $type"
 206                   }
 207                  }
 208             "N" {
 209                   if {[regexp {(^[0-9\.]+$)|()} $field]} {
 210                       if {[string length $field] <= $len} {
 211                           append rec [format %#-${len}s $field]
 212                       } else {
 213                           append rec [format %#-.${len}s $field]
 214                       }
 215                   } else {
 216                       return -code error -errorcode "Bad value $field in fieltype $type" "Bad value $field in fieldtype $type"
 217                   }
 218                  }
 219             "L" {
 220                   if {[regexp {^[YyTt1]} $field]} {
 221                       append rec [format %#-1 [regexp {^[YyTt1]} $field]]
 222                   } else {
 223                       return -code error -errorcode "Bad value $field in fieltype $type" "Bad value $field in fieldtype $type"
 224                   }
 225                  }
 226             "C" {
 227                   if {[string length $field] <= $len} {
 228                       append rec [format %#-${len}s $field]
 229                   } else {
 230                       append rec [format %#-.${len}s $field]
 231                   }
 232                 }
 233         }
 234     }
 235     puts -nonewline $file "[encoding convertto cp866 $rec]\x1A"
 236     incr info(reccount)
 237 }
 238
 239 #
 240 # delete record from dbf file
 241 # dbf_delrec file recnumber recnumber ...
 242 #
 243 proc dbf_delrec {file args} {
 244     upvar #0 $file info
 245     if ![info exists info] {
 246         return -code error "$file is not a dBase file"
 247     }
 248     if ![llength $args] {
 249         return
 250     }
 251     foreach rec $args {
 252         if {![regexp {[0-9]} $rec]} {
 253             return -code error "Not valid number recodr $rec"
 254         }
 255         if {$rec > $info(reccount)} {
 256            return -code error "Cannot delete record $rec"
 257         }
 258         seek $file [expr {$info(offset)+$info(reclen)*($rec-1)}]
 259         puts -nonewline $file "*"
 260     }
 261 }
 262
 263 #
 264 # undelete record from dbf file
 265 # dbf_undelrec file recnumber recnumber ...
 266 #
 267 proc dbf_undelrec {file args} {
 268     upvar #0 $file info
 269     if ![info exists info] {
 270         return -code error "$file is not a dBase file"
 271     }
 272     if ![llength $args] {
 273         return
 274     }
 275     foreach rec $args {
 276         if {![regexp {[0-9]} $rec]} {
 277             return -code error "Not valid number recodr $rec"
 278         }
 279         if {$rec > $info(reccount)} {
 280            return -code error "Cannot undelete record $rec"
 281         }
 282         seek $file [expr {$info(offset)+$info(reclen)*($rec-1)}]
 283         puts -nonewline $file "\x20"
 284     }
 285 }
 286
 287 #
 288 # create dbf file
 289 # createdbf filename fieldname fieldtype ?width? ?decimal? fieldname fieldtype ...
 290 #
 291 proc createdbf {filename args} {
 292     if ![catch {glob $filename}] {
 293          return -code error "File $filename alredy exists in current directory"
 294     }
 295     if [catch {open $filename w+} res] {
 296          return -code error -errorcode $errorCode $res
 297     }
 298     fconfigure $res -encoding cp866 -translation binary
 299     set year  [string trimleft [clock format [clock seconds]  -format %y] 0]
 300     set month [string trimleft [clock format [clock seconds]  -format %m] 0]
 301     set day   [string trimleft [clock format [clock seconds]  -format %d] 0]
 302     append header \x03 [binary format cccx28 $year $month $day]
 303     set i 0
 304     set n 0
 305     set offset 1
 306     while {$i < [llength $args]} {
 307         set name [string toupper [lindex $args $i]]
 308         set type [string toupper [lindex $args [expr {$i+1}]]]
 309         if {$type == "D"} {
 310             append header [binary format a10xaicx15 $name $type $offset 8]
 311             set pos 2
 312             set offset [expr {$offset + 8}]
 313         } elseif {$type == "C"} {
 314             set width [lindex $args [expr {$i+2}]]
 315             append header [binary format a10xaicx15 $name $type $offset $width]
 316             set pos 3
 317             set offset [expr {$offset + $width}]
 318         } elseif {$type == "N"} {
 319             set width   [lindex $args [expr {$i+2}]]
 320             set decimal [lindex $args [expr {$i+3}]]
 321             append header [binary format a10xaiccx14 $name $type $offset $width $decimal]
 322             set pos 4
 323             set offset [expr {$offset + $width}]
 324         } elseif {$type == "L"} {
 325             append header [binary format a10xaicx15 $name $type $offset 1]
 326             set pos 2
 327             set offset [expr {$offset + 1}]
 328         } else {
 329             close $res
 330             file delete $filename
 331             return -code error -errorcode "Unknown field type $type" "Unknown field type $type"
 332         }
 333         incr i $pos
 334         incr n
 335     }
 336     puts -nonewline $res "$header\x0D"
 337     seek $res 8
 338     puts -nonewline $res [binary format ss [expr {33+$n*32}] $offset]
 339     dbf_readheader $res
 340     return $res
 341 }
 342
 343 package provide dbf "0.1"
 344
 345
 346