File: db3.lisp

package info (click to toggle)
cl-db3 20150302-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, buster, sid, stretch
  • size: 60 kB
  • sloc: lisp: 187; makefile: 13
file content (228 lines) | stat: -rw-r--r-- 8,446 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
;;;; http://xach.com/lisp/db3.lisp
;;
;; db3.lisp
#|

Database file structure

The structure of a dBASE III database file is composed of a header
and data records.  The layout is given below.


dBASE III DATABASE FILE HEADER:

+---------+-------------------+---------------------------------+
|  BYTE   |     CONTENTS      |          MEANING                |
+---------+-------------------+---------------------------------+
|  0      |  1 byte           | dBASE III version number        |
|         |                   |  (03H without a .DBT file)      |
|         |                   |  (83H with a .DBT file)         |
+---------+-------------------+---------------------------------+
|  1-3    |  3 bytes          | date of last update             |
|         |                   |  (YY MM DD) in binary format    |
+---------+-------------------+---------------------------------+
|  4-7    |  32 bit number    | number of records in data file  |
+---------+-------------------+---------------------------------+
|  8-9    |  16 bit number    | length of header structure      |
+---------+-------------------+---------------------------------+
|  10-11  |  16 bit number    | length of the record            |
+---------+-------------------+---------------------------------+
|  12-31  |  20 bytes         | reserved bytes (version 1.00)   |
+---------+-------------------+---------------------------------+
|  32-n   |  32 bytes each    | field descriptor array          |
|         |                   |  (see below)                    | --+
+---------+-------------------+---------------------------------+   |
|  n+1    |  1 byte           | 0DH as the field terminator     |   |
+---------+-------------------+---------------------------------+   |
                                                                    |
                                                                    |
A FIELD DESCRIPTOR:      <------------------------------------------+

+---------+-------------------+---------------------------------+
|  BYTE   |     CONTENTS      |          MEANING                |
+---------+-------------------+---------------------------------+
|  0-10   |  11 bytes         | field name in ASCII zero-filled |
+---------+-------------------+---------------------------------+
|  11     |  1 byte           | field type in ASCII             |
|         |                   |  (C N L D or M)                 |
+---------+-------------------+---------------------------------+
|  12-15  |  32 bit number    | field data address              |
|         |                   |  (address is set in memory)     |
+---------+-------------------+---------------------------------+
|  16     |  1 byte           | field length in binary          |
+---------+-------------------+---------------------------------+
|  17     |  1 byte           | field decimal count in binary   |
+---------+-------------------+---------------------------------+
|  18-31  |  14 bytes         | reserved bytes (version 1.00)   |
+---------+-------------------+---------------------------------+


The data records are layed out as follows:

     1. Data records are preceeded by one byte that is a space (20H) if the
        record is not deleted and an asterisk (2AH) if it is deleted.

     2. Data fields are packed into records with  no  field separators or
        record terminators.

     3. Data types are stored in ASCII format as follows:

     DATA TYPE      DATA RECORD STORAGE
     ---------      --------------------------------------------
     Character      (ASCII characters)
     Numeric        - . 0 1 2 3 4 5 6 7 8 9
     Logical        ? Y y N n T t F f  (? when not initialized)
     Memo           (10 digits representing a .DBT block number)
     Date           (8 digits in YYYYMMDD format, such as
                    19840704 for July 4, 1984)

|#
(in-package :db3)

(defparameter *external-format* :ascii
  "External format of the DBF file Character data")


;;; reading binary stuff
(defun read-uint32 (stream)
  (loop repeat 4
        for offset from 0 by 8
        for value = (read-byte stream)
          then (logior (ash (read-byte stream) offset) value)
        finally (return value)))

(defun read-uint16 (stream)
  (loop repeat 2
        for offset from 0 by 8
        for value = (read-byte stream)
          then (logior (ash (read-byte stream) offset) value)
        finally (return value)))



;;; objects

(defclass db3 ()
  ((version-number :accessor version-number)
   (last-update :accessor last-update)
   (record-count :accessor record-count)
   (header-length :accessor header-length)
   (record-length :accessor record-length)
   (fields :accessor fields)))


(defclass db3-field ()
  ((name :accessor field-name)
   (type :accessor field-type)
   (data-address :accessor data-address)
   (field-length :accessor field-length)
   (field-count :accessor field-count)))


(defun asciiz->string (array)
  (let* ((string-length (or (position 0 array)
                            (length array)))
         (string (make-string string-length)))
    (loop for i below string-length
          do (setf (schar string i) (code-char (aref array i))))
    string))

(defun ascii->string (array)
  (cond
    ((eq :ascii *external-format*) (map 'string #'code-char array))

    (t #+sbcl
       (sb-ext:octets-to-string array :external-format *external-format*)

       #+ccl
       (ccl:decode-string-from-octets array :external-format *external-format*))))


(defun load-field-descriptor (stream)
  (let ((field (make-instance 'db3-field))
        (name (make-array 11 :element-type '(unsigned-byte 8))))
    (read-sequence name stream)
    (setf (field-name field) (asciiz->string name)
          (field-type field) (code-char (read-byte stream))
          (data-address field) (read-uint32 stream)
          (field-length field) (read-byte stream)
          (field-count field) (read-byte stream))
    (loop repeat 14 do (read-byte stream))
    field))


(defmethod field-count ((db3 db3))
  (1- (/ (1- (header-length db3)) 32)))


(defmethod load-header ((db3 db3) stream)
  (let ((version (read-byte stream)))
    (unless (= version #x03)
      (error "Can't handle this file"))
    (let ((year (read-byte stream))
          (month (read-byte stream))
          (day (read-byte stream)))
      (setf (version-number db3) version
            (last-update db3) (list year month day)
            (record-count db3) (read-uint32 stream)
            (header-length db3) (read-uint16 stream)
            (record-length db3) (read-uint16 stream))
      (file-position stream 32)
      (setf (fields db3) (loop repeat (field-count db3)
                               collect (load-field-descriptor stream)))
      (assert (= (read-byte stream) #x0D))
      db3)))


(defmethod convert-field (type data)
  (ascii->string data))

(defmethod convert-field ((type (eql #\C)) data)
  (ascii->string data))


(defmethod load-field (type length stream)
  (let ((field (make-array length :element-type '(unsigned-byte 8))))
    (read-sequence field stream)
    (convert-field type field)))

(defmethod load-record ((db3 db3) stream)
  (read-byte stream)
  (loop with record = (make-array (field-count db3))
        for i below (field-count db3)
        for field in (fields db3)
        do (setf (svref record i)
                 (load-field (field-type field) (field-length field) stream))
        finally (return record)))


(defun write-record (record stream)
  (loop for field across record
        do
        (write-char #\" stream)
        (write-string field stream)
        (write-string "\"," stream))
  (terpri stream))


(defun dump-db3 (input output)
  (with-open-file (stream input :direction :input
                          :element-type '(unsigned-byte 8))
    (with-open-file (ostream output :direction :output
                             :element-type 'character)
      (let ((db3 (make-instance 'db3)))
        (load-header db3 stream)
        (loop repeat (record-count db3)
              do (write-record (load-record db3 stream) ostream))
        db3))))

(defun sample-db3 (input ostream &key (sample-size 10))
  (with-open-file (stream input :direction :input
                          :element-type '(unsigned-byte 8))
    (let ((db3 (make-instance 'db3)))
      (load-header db3 stream)
      (loop
	 :repeat sample-size
	 :do (format ostream "~s~%" (load-record db3 stream)))
      db3)))