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

Contents of /cl-dbf/src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5