]> wagner.pp.ru Git - sites/home_page.git/blob - software/tcl/dbfreader.tcl
grandpa picture
[sites/home_page.git] / 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