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

Contents of /cl-dbf/src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (hide annotations)
Sun May 8 13:48:23 2011 UTC (2 years, 11 months ago) by rklochkov
Branch: MAIN
Changes since 1.1: +32 -17 lines
Fixed asd dependencies.
Added with-db macro. Remove stream from function args except dbopen.
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     (stream))
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     (defun external-format (driver)
135     (case (code-page driver)
136     (2 '(:code-page :id 850))
137     (3 '(:code-page :id 1252))
138     (#x64 '(:code-page :id 852))
139     (#x65 '(:code-page :id 865))
140     (#x66 '(:code-page :id 866))
141     (#xC8 '(:code-page :id 1250))
142     (#xC9 '(:code-page :id 1251))
143     (t '(:code-page :id 437))))
144    
145 rklochkov 1.2 (defmethod read-record ((driver dbase3-header))
146     (with-slots (stream) driver
147     (case (read-byte stream)
148     (32 (loop
149     :for field :in (fields driver)
150     :collect
151     (let ((s (make-array (size field)
152     :element-type '(unsigned-byte 8))))
153     (read-sequence s stream)
154     (flexi-streams:octets-to-string
155     s
156     :external-format (external-format driver)))))
157     (t nil))))
158    
159     (defmacro with-db (db filespec &body body)
160     (let ((stream (gensym)))
161     `(with-open-file (,stream ,filespec :direction :io
162     :element-type 'unsigned-byte
163     :if-exists :overwrite)
164     (let ((,db (dbopen ,stream)))
165     ,@body))))
166 rklochkov 1.1
167    
168    

  ViewVC Help
Powered by ViewVC 1.1.5