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

Contents of /cl-dbf/src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.6 - (hide annotations)
Mon Dec 31 22:18:25 2012 UTC (15 months, 2 weeks ago) by rklochkov
Branch: MAIN
Changes since 1.5: +4 -3 lines
.
1 rklochkov 1.1 ;; (c) Roman Klochkov, kalimehtar@mail.ru
2     ;;
3     ;; Status: Alpha
4     ;; for now you can do something like
5     ;; (with-open-file (stream filename)
6     ;; (let ((driver (dbopen stream)))
7 rklochkov 1.2 ;; (read-record driver)
8     ;; (read-record driver)
9 rklochkov 1.1 ;; ....))
10    
11     (in-package #:cl-dbf)
12    
13     (define-binary-type unsigned-integer-le (bytes bits-per-byte)
14     (:reader (in)
15     (loop with value = 0
16     for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte do
17     (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in))
18     finally (return value)))
19     (:writer (out value)
20     (loop for low-bit from 0 to (* bits-per-byte (1- bytes)) by bits-per-byte
21     do (write-byte (ldb (byte bits-per-byte low-bit) value) out))))
22    
23     (define-binary-type l1 () (unsigned-integer-le :bytes 1 :bits-per-byte 8))
24     (define-binary-type l2 () (unsigned-integer-le :bytes 2 :bits-per-byte 8))
25     (define-binary-type l3 () (unsigned-integer-le :bytes 3 :bits-per-byte 8))
26     (define-binary-type l4 () (unsigned-integer-le :bytes 4 :bits-per-byte 8))
27    
28    
29     (define-binary-type discard (length)
30     (:reader (in)
31     (dotimes (i length)
32     (read-byte in))
33     nil)
34     (:writer (out dummy)
35     (declare (ignore dummy))
36     (dotimes (i length)
37     (write-byte 0 out))))
38    
39 rklochkov 1.2 (defclass xbase-common ()
40 rklochkov 1.5 (stream external-format))
41 rklochkov 1.1
42 rklochkov 1.2 (define-tagged-binary-class dbf-header (xbase-common)
43 rklochkov 1.1 ((db-type u1))
44     (:dispatch (select-db-driver db-type)))
45    
46     (define-binary-class dbase3-header (dbf-header)
47     ((year u1)
48     (month u1)
49     (day u1)
50     (records-count l4)
51     (header-size l2)
52     (record-size l2)
53     (reserved l2)
54     (transaction u1)
55     (code u1)
56     (multi-user (discard :length 12))
57     (indexed u1)
58     (code-page u1)
59     (reserved2 u2)))
60    
61     (define-condition in-padding () ())
62    
63     (define-binary-type db-field-name (length)
64     (:reader (in)
65     (let ((first-byte (read-byte in)))
66     (when (= first-byte #xd) (signal 'in-padding))
67     (let ((rest (read-value 'iso-8859-1-string in :length (1- length))))
68     (string-right-trim '(#\Nul)
69     (concatenate
70     'string (string (code-char first-byte)) rest)))))
71     (:writer (out id)
72     (write-value 'iso-8859-1-string out id :length (length id))
73     (dotimes (i (- length (length id)))
74     (write-byte 0 out))))
75    
76     (define-binary-class xbase-field ()
77     ((name (db-field-name :length 11))
78     (field-type u1)
79     (reserved u4)
80     (size u1)
81     (precision u1)
82     (reserved2 u2)
83     (workspace u1)
84     (multi-user u2)
85     (set-fields u1)
86     (reserved3 (discard :length 7))
87     (index u1)))
88    
89     (defun read-field (in)
90     (handler-case (read-value 'xbase-field in)
91     (in-padding () nil)))
92    
93    
94     (define-binary-type xbase-fields (length)
95     (:reader
96     (in)
97     (loop with to-read = (- length 32)
98     while (plusp to-read)
99     for field = (read-field in)
100     while field
101     do (decf to-read 32)
102     collect field
103     finally (assert (null field))))
104     (:writer
105     (out frames)
106     (loop with to-write = length
107     for frame in frames
108     do (write-value 'dbase3-field out frame)
109     (decf to-write (+ 6 (size frame)))
110     finally (loop repeat to-write do (write-byte 0 out)))))
111    
112     (define-binary-class dbase3 (dbase3-header)
113     ((fields (xbase-fields :length header-size))))
114    
115     (define-binary-class foxbase (dbase3-header)
116     ((fields (xbase-fields :length header-size))))
117    
118     (defun select-db-driver (db-type)
119     (case db-type
120     (2 'foxbase)
121     (3 'dbase3)
122     (t 'dbase3)))
123    
124     (defun dbopen (stream)
125     (assert (and (input-stream-p stream) (output-stream-p stream)))
126 rklochkov 1.2 (file-position stream 0)
127     (let ((db (read-value 'dbf-header stream)))
128     (setf (slot-value db 'stream) stream)
129     db))
130 rklochkov 1.1
131 rklochkov 1.2 (defun goto-bof (driver)
132     (file-position (slot-value driver 'stream) (header-size driver)))
133 rklochkov 1.1
134 rklochkov 1.3 (defun goto-record (driver n)
135     (file-position (slot-value driver 'stream)
136     (+ (header-size driver) (* n (record-size driver)))))
137    
138 rklochkov 1.1 (defun external-format (driver)
139 rklochkov 1.5 (or (slot-value driver 'external-format)
140     (case (code-page driver)
141     (2 '(:code-page :id 850))
142     (3 '(:code-page :id 1252))
143     (#x64 '(:code-page :id 852))
144     (#x65 '(:code-page :id 865))
145     (#x66 '(:code-page :id 866))
146     (#xC8 '(:code-page :id 1250))
147     (#xC9 '(:code-page :id 1251))
148     (t '(:code-page :id 437)))))
149 rklochkov 1.1
150 rklochkov 1.2 (defmethod read-record ((driver dbase3-header))
151 rklochkov 1.5 "Return record value as list and move to the next record.
152     When eof, return nil. Deleted records skipped."
153 rklochkov 1.2 (with-slots (stream) driver
154 rklochkov 1.5 (case (read-byte stream nil :eof)
155 rklochkov 1.2 (32 (loop
156     :for field :in (fields driver)
157     :collect
158     (let ((s (make-array (size field)
159     :element-type '(unsigned-byte 8))))
160     (read-sequence s stream)
161     (flexi-streams:octets-to-string
162     s
163     :external-format (external-format driver)))))
164 rklochkov 1.5 (:eof nil)
165     (t ; deleted record, skip and read again
166     (file-position stream
167     (+ (file-position stream)
168     (1- (record-size driver))))
169     (read-record driver)))))
170 rklochkov 1.2
171     (defmacro with-db (db filespec &body body)
172     (let ((stream (gensym)))
173     `(with-open-file (,stream ,filespec :direction :io
174     :element-type 'unsigned-byte
175     :if-exists :overwrite)
176     (let ((,db (dbopen ,stream)))
177     ,@body))))
178 rklochkov 1.1
179 rklochkov 1.5 (defun dbf-to-conses-of-strings (filename &key external-format)
180 rklochkov 1.6 "FILNAME is a name of dbf file to open.
181 rklochkov 1.5 Returns a list (field-names . record-values),
182 rklochkov 1.6 where values are strings.
183     EXTERNAL-FORMAT is passed to flexi-streams:octets-to-string"
184 rklochkov 1.5 (with-db (db filename)
185     (when external-format
186     (setf (slot-value db 'external-format) external-format)
187 rklochkov 1.6 (cons (mapcar #'name (fields driver))
188 rklochkov 1.5 (loop
189     :for rec = (read-record driver)
190     :while rec
191     :collect rec)))))
192 rklochkov 1.1
193    

  ViewVC Help
Powered by ViewVC 1.1.5