Index: main/xbase.lisp
===================================================================
--- main/xbase.lisp	(revision main,5)
+++ main/xbase.lisp	(revision main,6)
@@ -1,76 +1,8 @@
 (require '#:asdf)
 (require '#:cl-ppcre)
+(require '#:dso-binary-class)
 
 (use-package '#:cl-ppcre)
-
-
-
-;;; 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 #\Space) (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)))))
+(use-package '#:binary-class)
 
 
@@ -79,27 +11,27 @@
 
 (define-file-struct dbf-header
-  (version unsigned 1)
-  (last-update date "YYMMDD")
-  (record-count unsigned 4)
-  (header-length unsigned 2)
-  (record-length unsigned 2)
+  (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)
+  (incomplete-transaction :unsigned 1)
+  (encrypted :unsigned 1)
   (nil nil 12)
-  (mdx-flag unsigned 1)
-  (language unsigned 1)
+  (mdx-flag :unsigned 1)
+  (language :unsigned 1)
   (nil nil 2))
 
 (define-file-struct field-desc
-  (name string 11)
-  (type string 1)
+  (name :string 11)
+  (type :string 1)
   (nil nil 4)
-  (size unsigned 1)
-  (precision unsigned 1)
+  (size :unsigned 1)
+  (precision :unsigned 1)
   (nil nil 5)
-  (set-fields-flag unsigned 1)
+  (set-fields-flag :unsigned 1)
   (nil nil 7)
-  (is-indexed unsigned 1))
+  (is-indexed :unsigned 1))
 
 (defun peek-byte (in)
@@ -125,9 +57,9 @@
   (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)
-                  ((string= type "L") 'string)
+                  ((string= type "C") :string)
+                  ((string= type "N") :string)
+                  ((string= type "D") :string)
+                  ((string= type "M") :string)
+                  ((string= type "L") :string)
                   (t (abort)))))
       `(,(intern name) ,type ,size))))
@@ -135,5 +67,5 @@
 (defun struct-from-field-descs (name descs)
   `(define-file-struct ,name
-     (%deleted unsigned 1)
+     (%deleted :unsigned 1)
      ,@(mapcar #'slot-from-field descs)))
 
@@ -151,16 +83,31 @@
         name)))
 
+(defun recode (str)
+  (let (r
+        e)
+    (dotimes (i (length str))
+      (let* ((ch (aref str i))
+             (code (char-code ch)))
+        (cond
+          ((or (<= (char-code #\Space) code (char-code #\[))
+               (<= (char-code #\]) code (char-code #\~)))
+           (push (string ch) r))
+          ((<= 0 code 255)
+           (push (format nil "\\x~2,'0X" code) r)
+           (setf e t))
+          (t
+           (error "Bad character!")))))
+    (values
+     (apply #'concatenate 'string (nreverse r))
+     e)))
+
 (defun sql-escape-data (value)
   (if (string= value "")
       "null"
-      (let ((value
-             (concatenate 'string "'" (regex-replace-all "'" value "''") "'")))
-        (when (find #\\ value :test 'char=)
-          (setf value (concatenate 'string
-                                   "E"
-                                   (regex-replace-all "\\\\"
-                                                      value
-                                                      "\\\\\\\\"))))
-        value)))
+      (multiple-value-bind (s recoded) (recode value)
+        (concatenate 'string
+                     (if recoded "E'" "'")
+                     (regex-replace-all "'" s "''")
+                     "'"))))
 
 (defun sql-column (desc)
@@ -192,4 +139,6 @@
           (mapcar 'sql-column descs)))
 
+(defgeneric sql-insert (obj))
+
 (defun make-sql-function (type name descs)
   `(defmethod sql-insert ((obj ,type))
@@ -237,9 +186,4 @@
           (read-records in type))))))
 
-(define-dbf-struct unit-type "/home/dsowen/scott/local/bent-data/bentutyp.dbf")
-(define-dbf-struct vendor "/home/dsowen/scott/local/bent-data/bentvend.dbf")
-(define-dbf-struct phone "/home/dsowen/scott/local/bent-data/bentphon.dbf")
-(define-dbf-struct tenent-change "/home/dsowen/scott/local/bent-data/benttchg.dbf")
-
 
 
@@ -269,5 +213,6 @@
               (slot-value (gethash 'import-struct *dbfs*) 'sql-create))
       (dolist (rec recs)
-        (format t "~A;~%~%" (sql-insert rec))))))
+        (unless (/= (slot-value rec '%deleted) 32)
+          (format t "~A;~%~%" (sql-insert rec)))))))
 
 (defun main ()