source: main/xbase.lisp

(require '#:asdf)
(require '#:cl-ppcre)
(require '#:dso-binary-class)

(use-package '#:cl-ppcre)
(use-package '#:binary-class)



;;; 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)
                  ((string= type "L") :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)))

(defstruct dbf-desc
  name
  filename
  sql-create)

(defvar *dbfs* (make-hash-table :test 'eq))

(defun sql-escape-fieldname (name)
  (let ((name (string-downcase name)))
    (if (member name '("group" "user") :test 'equal)
        (concatenate 'string "\"" name "\"")
        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"
      (multiple-value-bind (s recoded) (recode value)
        (concatenate 'string
                     (if recoded "E'" "'")
                     (regex-replace-all "'" s "''")
                     "'"))))

(defun sql-column (desc)
  (with-slots (name type size precision) desc
    (format nil "~A ~A"
            (sql-escape-fieldname name)
            (cond
              ((string= type "C")
               (format nil "VARCHAR(~A)" size))
              ((string= type "N")
               (if (= precision 0)
                   (cond
                     ((< size 10) "INTEGER")
                     ((< size 19) "BIGINT")
                     (t "NUMERIC(~A)" size))
                   (format nil "NUMERIC(~A,~A)" (1- size) precision)))
              ((string= type "D")
               "DATE")
              ((string= type "M")
               (warn "MEMOs aren't implemented yet.")
               "NUMERIC(10)")
              ((string= type "L")
               "BOOLEAN")
              (t (error "Bad type ~S." type))))))

(defvar *temporary-tables* nil)

(defun sql-create (name descs)
  (format nil "CREATE ~:[~;TEMP ~]TABLE ~A~%   (~{~A~@{,~%    ~A~}~})~:[~;~%ON COMMIT DROP~]"
          *temporary-tables*
          name
          (mapcar 'sql-column descs)
          (eql *temporary-tables* 1)))

(defgeneric sql-insert (obj))

(defun make-sql-function (type name descs)
  `(defmethod sql-insert ((obj ,type))
     (format
      nil
      ,(format nil "INSERT INTO ~A(~{~A~@{,~A~}~}) VALUES(~{~A~@{,~A~}~})"
               name
               (mapcar (lambda (desc)
                         (sql-escape-fieldname (field-desc-name desc)))
                       descs)
               (mapcar (lambda (d)
                         (declare (ignore d))
                         "~A")
                       descs))
      ,@(mapcar (lambda (desc)
                  `(sql-escape-data
                    (slot-value obj ',(intern (field-desc-name desc)))))
                descs))))

(defmacro define-dbf-struct (name filename)
  (let ((descs (nth-value 1 (read-dbf-structure filename))))
    `(progn
       (setf (gethash ',name *dbfs*)
             (make-dbf-desc :name ',name
                            :filename ,filename
                            :sql-create ,(sql-create name descs)))
       ,(struct-from-field-descs name descs)
       ,(make-sql-function name 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 ((dbf-desc (gethash type *dbfs*)))
    (with-slots (filename) dbf-desc
      (let ((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))))))



(defun import-dbf (filename table-name)
  "Reads the DBF file, analyzing meta-data to create Lisp structures,
populating those structures, and constructing descriptive SQL."
  (let ((field-descs (nth-value 1 (read-dbf-structure filename))))
    (setf (gethash 'import-struct *dbfs*)
          (make-dbf-desc :name 'import-struct
                         :filename filename
                         :sql-create (sql-create table-name field-descs)))
    (eval (struct-from-field-descs 'import-struct field-descs))
    (eval (make-sql-function 'import-struct table-name field-descs))
    (read-dbf 'import-struct)))

(defun split-name (filename)
  (unless (pathnamep filename)
    (setf filename (pathname filename)))
  (let ((name (pathname-name filename)))
    (values (subseq name 0 4)
            (subseq name 4))))

(defun do-dbf (filename)
  (multiple-value-bind (db-name table-name) (split-name filename)
    (let ((recs (import-dbf filename table-name)))
      (format t "~A;~4%"
              (slot-value (gethash 'import-struct *dbfs*) 'sql-create))
      (dolist (rec recs)
        (unless (/= (slot-value rec '%deleted) 32)
          (format t "~2&~A;~%" (sql-insert rec)))))))

(defun main ()
  (unless (member (length *posix-argv*) '(2 3))
    (format *error-output* "Usage: xbase [-t | -tt] dbf-file~%")
    (quit))
  (let* ((*temporary-tables* (position (second *posix-argv*) '("-t" "-tt") :test 'string=))
         (file (if *temporary-tables*
                   (third *posix-argv*)
                   (second *posix-argv*))))
    (do-dbf file))
  (quit))