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

Contents of /cl-dbf/src.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (hide annotations)
Sat May 7 18:28:43 2011 UTC (2 years, 11 months ago) by rklochkov
Branch: MAIN
Branch point for: slavsoft
Initial revision
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     ;; (read-record driver stream)
8     ;; (read-record driver stream)
9     ;; ....))
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    
40     (define-tagged-binary-class dbf-header ()
41     ((db-type u1))
42     (:dispatch (select-db-driver db-type)))
43    
44     (define-binary-class dbase3-header (dbf-header)
45     ((year u1)
46     (month u1)
47     (day u1)
48     (records-count l4)
49     (header-size l2)
50     (record-size l2)
51     (reserved l2)
52     (transaction u1)
53     (code u1)
54     (multi-user (discard :length 12))
55     (indexed u1)
56     (code-page u1)
57     (reserved2 u2)))
58    
59     (define-condition in-padding () ())
60    
61     (define-binary-type db-field-name (length)
62     (:reader (in)
63     (let ((first-byte (read-byte in)))
64     (when (= first-byte #xd) (signal 'in-padding))
65     (let ((rest (read-value 'iso-8859-1-string in :length (1- length))))
66     (string-right-trim '(#\Nul)
67     (concatenate
68     'string (string (code-char first-byte)) rest)))))
69     (:writer (out id)
70     (write-value 'iso-8859-1-string out id :length (length id))
71     (dotimes (i (- length (length id)))
72     (write-byte 0 out))))
73    
74     (define-binary-class xbase-field ()
75     ((name (db-field-name :length 11))
76     (field-type u1)
77     (reserved u4)
78     (size u1)
79     (precision u1)
80     (reserved2 u2)
81     (workspace u1)
82     (multi-user u2)
83     (set-fields u1)
84     (reserved3 (discard :length 7))
85     (index u1)))
86    
87     (defun read-field (in)
88     (handler-case (read-value 'xbase-field in)
89     (in-padding () nil)))
90    
91    
92     (define-binary-type xbase-fields (length)
93     (:reader
94     (in)
95     (loop with to-read = (- length 32)
96     while (plusp to-read)
97     for field = (read-field in)
98     while field
99     do (decf to-read 32)
100     collect field
101     finally (assert (null field))))
102     (:writer
103     (out frames)
104     (loop with to-write = length
105     for frame in frames
106     do (write-value 'dbase3-field out frame)
107     (decf to-write (+ 6 (size frame)))
108     finally (loop repeat to-write do (write-byte 0 out)))))
109    
110     (define-binary-class dbase3 (dbase3-header)
111     ((fields (xbase-fields :length header-size))))
112    
113     (define-binary-class foxbase (dbase3-header)
114     ((fields (xbase-fields :length header-size))))
115    
116     (defun select-db-driver (db-type)
117     (case db-type
118     (2 'foxbase)
119     (3 'dbase3)
120     (t 'dbase3)))
121    
122     (defun dbopen (stream)
123     (assert (and (input-stream-p stream) (output-stream-p stream)))
124     (read-value 'dbf-header stream))
125    
126     (defun goto-bof (driver stream)
127     (file-position stream (header-size driver)))
128    
129     (defun external-format (driver)
130     (case (code-page driver)
131     (2 '(:code-page :id 850))
132     (3 '(:code-page :id 1252))
133     (#x64 '(:code-page :id 852))
134     (#x65 '(:code-page :id 865))
135     (#x66 '(:code-page :id 866))
136     (#xC8 '(:code-page :id 1250))
137     (#xC9 '(:code-page :id 1251))
138     (t '(:code-page :id 437))))
139    
140     (defmethod read-record ((driver dbase3-header) stream)
141     (case (read-byte stream)
142     (32 (loop
143     :for field :in (fields driver)
144     :collect
145     (let ((s (make-array (size field) :element-type '(unsigned-byte 8))))
146     (read-sequence s stream)
147     (flexi-streams:octets-to-string
148     s
149     :external-format (external-format driver)))))
150     (t nil)))
151    
152    
153    

  ViewVC Help
Powered by ViewVC 1.1.5