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