/[cl-dbf]/cl-dbf/src.lisp
ViewVC logotype

Contents of /cl-dbf/src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.7 - (show annotations)
Wed Mar 20 17:37:22 2013 UTC (13 months ago) by rklochkov
Branch: MAIN
Changes since 1.6: +170 -30 lines
Added support for FoxPro Memo
Thanks to Rafael Jesús Alcántara Pérez, <ralcantara@dedaloingenieros.com>
1 ;; (c) Roman Klochkov, kalimehtar@mail.ru
2 ;; Rafael Jesús Alcántara Pérez, <ralcantara@dedaloingenieros.com>
3 ;;
4 ;; Status: Alpha
5 ;; for now you can do something like
6 ;; (with-open-file (stream filename)
7 ;; (let ((driver (dbopen stream)))
8 ;; (read-record driver)
9 ;; (read-record driver)
10 ;; ....))
11
12 (in-package #:cl-dbf)
13
14 ;;;
15 ;;; Visual FoxPro table field flags (position 18).
16 ;;;
17
18 (defparameter +visual-foxpro-column-flag-system+ #x1
19 "System column (not visible to user).")
20 (defparameter +visual-foxpro-column-flag-can-be-null+ #x2
21 "Column can store null values.")
22 (defparameter +visual-foxpro-column-flag-binary+ #x4
23 "Binary column (for CHAR and MEMO only).")
24 (defparameter +visual-foxpro-column-flag-binary-and-can-be-null+ #x6
25 "When a field is binary and can be NULL (INTEGER, CURRENCY and
26 CHARACTER/MEMO fields).")
27 (defparameter +visual-foxpro-column-flag-autoincrement+ #xC
28 "Column is autoincrementing.")
29
30 ;;;
31 ;;; Binary types utilities. See `flexi-streams' package.
32 ;;;
33
34 (define-binary-type unsigned-integer-le (bytes bits-per-byte)
35 (:reader (in)
36 (loop with value = 0
37 for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte do
38 (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in))
39 finally (return value)))
40 (:writer (out value)
41 (loop for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte
42 do (write-byte (ldb (byte bits-per-byte low-bit) value) out))))
43
44 (define-binary-type l1 () (unsigned-integer-le :bytes 1 :bits-per-byte 8))
45 (define-binary-type l2 () (unsigned-integer-le :bytes 2 :bits-per-byte 8))
46 (define-binary-type l3 () (unsigned-integer-le :bytes 3 :bits-per-byte 8))
47 (define-binary-type l4 () (unsigned-integer-le :bytes 4 :bits-per-byte 8))
48
49 (define-binary-type discard (length)
50 (:reader (in)
51 (dotimes (i length)
52 (read-byte in))
53 nil)
54 (:writer (out dummy)
55 (declare (ignore dummy))
56 (dotimes (i length)
57 (write-byte 0 out))))
58
59 ;;;
60 ;;; xBase binary classes code.
61 ;;;
62
63 (defclass xbase-common ()
64 (stream external-format))
65
66 (define-tagged-binary-class dbf-header (xbase-common)
67 ((db-type u1))
68 (:dispatch (select-db-driver db-type)))
69
70 (define-binary-class dbase3-header (dbf-header)
71 ((year u1)
72 (month u1)
73 (day u1)
74 (records-count l4)
75 (header-size l2)
76 (record-size l2)
77 (reserved l2)
78 (transaction u1)
79 (code u1)
80 (multi-user (discard :length 12))
81 (indexed u1)
82 (code-page u1)
83 (reserved2 u2)))
84
85 (define-condition in-padding () ())
86
87 (define-binary-type db-field-name (length)
88 (:reader (in)
89 (let ((first-byte (read-byte in)))
90 (when (= first-byte #xd) (signal 'in-padding))
91 (let ((rest (read-value 'iso-8859-1-string in :length (1- length))))
92 (string-right-trim '(#\Nul)
93 (concatenate
94 'string (string (code-char first-byte)) rest)))))
95 (:writer (out id)
96 (write-value 'iso-8859-1-string out id :length (length id))
97 (dotimes (i (- length (length id)))
98 (write-byte 0 out))))
99
100 (define-binary-class xbase-field ()
101 ((name (db-field-name :length 11))
102 (field-type u1)
103 (reserved u4)
104 (size u1)
105 (precision u1)
106 (reserved2 u2)
107 (workspace u1)
108 (multi-user u2)
109 (set-fields u1)
110 (reserved3 (discard :length 7))
111 (index u1)))
112
113 (define-binary-class visual-foxpro-field ()
114 ((name (db-field-name :length 11))
115 (field-type u1)
116 (reserved u4)
117 (size u1)
118 (precision u1)
119 (flags u1)
120 (autoincrement-next-value u4)
121 (autoincrement-step-value u1)
122 (reserved2 (discard :length 8))))
123
124 (defun read-field (field-class in)
125 (handler-case (read-value field-class in)
126 (in-padding () nil)))
127
128 (define-binary-type xbase-fields (length)
129 (:reader
130 (in)
131 (loop with to-read = (- length 32)
132 while (plusp to-read)
133 for field = (read-field 'xbase-field in)
134 while field
135 do (decf to-read 32)
136 collect field
137 finally (assert (null field))))
138 (:writer
139 (out frames)
140 (loop with to-write = length
141 for frame in frames
142 do (write-value 'dbase3-field out frame)
143 (decf to-write (+ 6 (size frame)))
144 finally (loop repeat to-write do (write-byte 0 out)))))
145
146 (define-binary-type visual-foxpro-fields (length)
147 (:reader
148 (in)
149 (loop with to-read = (- length 32)
150 while (plusp to-read)
151 for field = (read-field 'visual-foxpro-field in)
152 while field
153 do (decf to-read 32)
154 collect field
155 finally (assert (null field))))
156 (:writer
157 (out frames)
158 (loop with to-write = length
159 for frame in frames
160 do (write-value 'visual-foxpro-field out frame)
161 (decf to-write (+ 6 (size frame)))
162 finally (loop repeat to-write do (write-byte 0 out)))))
163
164 (define-binary-class dbase3 (dbase3-header)
165 ((fields (xbase-fields :length header-size))))
166
167 (define-binary-class foxbase (dbase3-header)
168 ((fields (xbase-fields :length header-size))))
169
170 (define-binary-class visual-foxpro (dbase3-header)
171 ((fields (visual-foxpro-fields :length header-size))))
172
173 ;;;
174 ;;; Memo fields related classes.
175 ;;;
176
177 (defclass xbase-memo-common (xbase-common)
178 ((code-page :reader code-page)))
179
180 (define-binary-class dbt-header (xbase-memo-common)
181 ((next-available-block u4)
182 (reserved1 (discard :length 12))
183 (version u1)
184 (reserved2 (discard :length 494))))
185
186 (define-binary-class fpt-header (xbase-memo-common)
187 ((next-available-block u4)
188 (reserved1 u2)
189 (record-size u2)
190 (reserved2 (discard :length 504))))
191
192 (defmethod header-size ((object xbase-memo-common))
193 512)
194
195 (defmethod record-size ((object dbt-header))
196 512)
197
198 ;;;
199 ;;; Utilities.
200 ;;;
201
202 (defun select-db-driver (db-type)
203 (case db-type
204 (2 'foxbase)
205 (3 'dbase3)
206 ((48 49 50) 'visual-foxpro)
207 (t 'dbase3)))
208
209 (defun dbopen (stream)
210 (assert (and (input-stream-p stream) (output-stream-p stream)))
211 (file-position stream 0)
212 (let ((db (read-value 'dbf-header stream)))
213 (setf (slot-value db 'stream) stream)
214 db))
215
216 (defun dbopen-memo (stream type code-page)
217 (assert (and (input-stream-p stream) (output-stream-p stream)))
218 (file-position stream 0)
219 (let ((memo (read-value type stream)))
220 (setf (slot-value memo 'stream) stream)
221 (setf (slot-value memo 'code-page) code-page)
222 memo))
223
224 (defun goto-bof (driver)
225 (file-position (slot-value driver 'stream) (header-size driver)))
226
227 (defgeneric goto-record (driver n)
228 (:documentation "Moves the stream to the record `n'.")
229 (:method ((driver dbase3-header) n)
230 (file-position (slot-value driver 'stream)
231 (+ (header-size driver) (* n (record-size driver)))))
232 (:method ((driver fpt-header) n)
233 "In FPT memo files, the header is accesible via block numbers. So
234 it is up to the database engine to avoid using blocks that
235 overlaps the header (the first 512 bytes)."
236 (file-position (slot-value driver 'stream)
237 (* n (record-size driver)))))
238
239 (defun external-format (driver)
240 (or (slot-value driver 'external-format)
241 (case (code-page driver)
242 (2 '(:code-page :id 850))
243 (3 '(:code-page :id 1252))
244 (#x64 '(:code-page :id 852))
245 (#x65 '(:code-page :id 865))
246 (#x66 '(:code-page :id 866))
247 (#xC8 '(:code-page :id 1250))
248 (#xC9 '(:code-page :id 1251))
249 (t '(:code-page :id 437)))))
250
251 (defgeneric translate-field-datum (driver field datum)
252 (:method ((driver dbase3-header) field datum)
253 (flexi-streams:octets-to-string datum :external-format (external-format driver)))
254 (:method ((driver visual-foxpro) field datum)
255 (with-slots (stream) driver
256 (case (code-char (field-type field))
257 ((#\I #\M) datum)
258 (t
259 (flexi-streams:octets-to-string datum :external-format (external-format driver)))))))
260
261 (defgeneric translate-memo-datum (driver field datum)
262 (:method ((driver fpt-header) field datum)
263 (declare (ignore field))
264 (with-slots (stream) driver
265 (flexi-streams:octets-to-string datum :external-format (external-format driver)))))
266
267 (defgeneric read-field-datum (driver field &key translate)
268 (:documentation "Reads raw data from current `driver' `stream'
269 position and then, it uses `translate' for returning the real field
270 datum.")
271 (:method ((driver dbase3-header) field &key translate)
272 (with-slots (stream) driver
273 (let ((s (make-array (size field)
274 :element-type '(unsigned-byte 8))))
275 (read-sequence s stream)
276 (funcall translate driver field s))))
277 (:method ((driver visual-foxpro) field &key translate)
278 (with-slots (stream) driver
279 (case (code-char (field-type field))
280 ((#\I #\M) (funcall translate driver field (read-value 'l4 stream)))
281 (t (let ((s (make-array (size field) :element-type '(unsigned-byte 8))))
282 (read-sequence s stream)
283 (funcall translate driver field s)))))))
284
285 (defgeneric read-memo-datum (driver field &key translate)
286 (:documentation "Reads raw data from current `driver' `stream'
287 position and then, it uses `translate' for returning the real memo
288 datum.")
289 (:method ((driver fpt-header) field &key (translate #'translate-memo-datum))
290 (with-slots (stream) driver
291 (read-value 'l4 stream)
292 (let* ((size (read-value 'u4 stream))
293 (datum (make-array size :element-type '(unsigned-byte 8))))
294 (read-sequence datum stream)
295 (funcall translate driver field datum)))))
296
297 (defmethod read-record ((driver dbase3-header) &key (translate #'translate-field-datum))
298 "Return record value as list and move to the next record.
299 When eof, return nil. Deleted records skipped."
300 (with-slots (stream) driver
301 (case (read-byte stream nil :eof)
302 (32 (loop
303 :for field :in (fields driver)
304 :collect (read-field-datum driver field :translate translate)))
305 (t ; deleted record, skip and read again
306 (file-position stream
307 (+ (file-position stream)
308 (1- (record-size driver))))
309 (read-record driver)))))
310
311 (defmacro with-db (db filespec &body body)
312 (let ((stream (gensym)))
313 `(with-open-file (,stream ,filespec :direction :io
314 :element-type 'unsigned-byte
315 :if-exists :overwrite)
316 (let ((,db (dbopen ,stream)))
317 ,@body))))
318
319 (defmacro with-db-memo (db filespec type code-page &body body)
320 (let ((stream (gensym)))
321 (when (eql 'auto type)
322 (let ((filespec-type (pathname-type filespec)))
323 (setf type (cond
324 ((equalp filespec-type "dbt") 'dbt-header)
325 ((equalp filespec-type "fpt") 'fpt-header)
326 (t (error "unknown memo type '~a'" filespec-type))))))
327 `(with-open-file (,stream ,filespec :direction :io
328 :element-type 'unsigned-byte
329 :if-exists :overwrite)
330 (let ((,db (dbopen-memo ,stream ,type ,code-page)))
331 ,@body))))
332
333

  ViewVC Help
Powered by ViewVC 1.1.5