Index: version/0.1/xbase.lisp
===================================================================
--- version/0.1/xbase.lisp	(revision version,0.1,1)
+++ version/0.1/xbase.lisp	(revision version,0.1,1)
@@ -0,0 +1,159 @@
+;;; Fairly generic file-reading stuff.
+
+(defstruct member-def
+  name
+  type
+  format)
+
+(defun parser-member-def (def)
+  (destructuring-bind (name type format) def
+    (make-member-def :name name :type type :format format)))
+
+(defun lisp-type-from-file-type (type)
+  (ecase type
+    (unsigned '(integer 0))
+    (date t)
+    (string 'string)))
+
+(defun default-from-file-type (type)
+  (ecase type
+    (unsigned 0)
+    (date 0)
+    (string "")))
+
+(defgeneric read-binary (type stream &optional format)
+  (:method ((type (eql 'unsigned)) stream &optional (format 1))
+    (let ((r 0))
+      (dotimes (i format r)
+        (setf (ldb (byte 8 (* i 8)) r) (read-byte stream)))))
+  (:method ((type (eql 'string)) stream &optional format)
+    (let ((v (make-sequence '(vector (unsigned-byte 8)) format
+                            :initial-element 0)))
+      (read-sequence v stream)
+      (string-trim '(#\Nul) (map 'string #'code-char v))))
+  (:method ((type (eql 'date)) stream &optional format)
+    (assert (stringp format))
+    (cond
+      ((string= format "YYMMDD")
+       (let* ((year (read-binary 'unsigned stream))
+              (month (read-binary 'unsigned stream))
+              (day (read-binary 'unsigned stream)))
+         (encode-universal-time 0 0 0 day month year)))
+      ((string= format "YYYYMMDD")
+       (let* ((year (read-binary 'unsigned stream 2))
+              (month (read-binary 'unsigned stream))
+              (day (read-binary 'unsigned stream)))
+         (encode-universal-time 0 0 0 day month year))))))
+
+(defmacro define-file-struct (name &body defs)
+  (let ((defs (mapcar #'parser-member-def defs)))
+    `(progn
+       (defstruct ,name
+         ,@(mapcar (lambda (def)
+                     (with-slots (name type) def
+                       `(,name ,(default-from-file-type type)
+                               :type ,(lisp-type-from-file-type type))))
+                   (remove-if #'null defs :key #'member-def-type)))
+       (defmethod read-binary ((type (eql ',name)) stream &optional format)
+         (declare (ignore format))
+         (let ((rec (make-instance ',name)))
+           ,@(mapcar (lambda (def)
+                       (with-slots (name type format) def
+                         (if name
+                             `(setf (slot-value rec ',name)
+                                    (read-binary ',type stream ,format))
+                             `(read-binary 'unsigned stream ,format))))
+                     defs)
+           rec)))))
+
+
+
+;;; xBase stuff.
+
+(define-file-struct dbf-header
+  (version unsigned 1)
+  (last-update date "YYMMDD")
+  (record-count unsigned 4)
+  (header-length unsigned 2)
+  (record-length unsigned 2)
+  (nil nil 2)
+  (incomplete-transaction unsigned 1)
+  (encrypted unsigned 1)
+  (nil nil 12)
+  (mdx-flag unsigned 1)
+  (language unsigned 1)
+  (nil nil 2))
+
+(define-file-struct field-desc
+  (name string 11)
+  (type string 1)
+  (nil nil 4)
+  (size unsigned 1)
+  (precision unsigned 1)
+  (nil nil 5)
+  (set-fields-flag unsigned 1)
+  (nil nil 7)
+  (is-indexed unsigned 1))
+
+(defun peek-byte (in)
+  (let ((b (read-byte in)))
+    (file-position in (1- (file-position in)))
+    b))
+
+(defun read-field-descs (in &optional descs)
+  (let ((b (peek-byte in)))
+    (if (= b 13)
+        (nreverse descs)
+        (read-field-descs in (cons (read-binary 'field-desc in) descs)))))
+
+(defun read-dbf-structure (file)
+  (with-open-file (in file :element-type '(unsigned-byte 8))
+    (let* ((dbf-header (read-binary 'dbf-header in))
+           (field-descs (read-field-descs in)))
+      (values dbf-header field-descs))))
+
+
+
+(defun slot-from-field (desc)
+  (with-slots (name type size) desc
+    (let ((type (cond
+                  ((string= type "C") 'string)
+                  ((string= type "N") 'string)
+                  ((string= type "D") 'string)
+                  ((string= type "M") 'string)
+                  (t (abort)))))
+      `(,(intern name) ,type ,size))))
+
+(defun struct-from-field-descs (name descs)
+  `(define-file-struct ,name
+     (%deleted unsigned 1)
+     ,@(mapcar #'slot-from-field descs)))
+
+(defvar *dbfs* (make-hash-table :test 'eq))
+
+(defmacro define-dbf-struct (name filename)
+  (let ((descs (nth-value 1 (read-dbf-structure filename))))
+    `(progn
+       (setf (gethash ',name *dbfs*) ,filename)
+       ,(struct-from-field-descs name descs))))
+
+
+
+;;; Now file stuff.
+
+
+
+(defun read-records (in type &optional records)
+  (if (or (not (listen in)) (= (peek-byte in) 26))
+      (nreverse records)
+      (read-records in type (cons (read-binary type in) records))))
+
+(defun read-dbf (type)
+  (let* ((filename (gethash type *dbfs*))
+         (header (read-dbf-structure filename)))
+    (with-open-file (in filename :element-type '(unsigned-byte 8))
+      (file-position in (slot-value header 'header-length))
+      (read-records in type))))
+
+(define-dbf-struct unit-type "/home/dsowen/scott/main/db/brisutyp.dbf")
+(define-dbf-struct vendor "/home/dsowen/scott/main/db/brisvend.dbf")