Changeset version,0.1,4 for version/0.1/xbase.lisp

Timestamp:

10/03/2007 05:21:21 PM (19 years ago)

Author:

David Owen <dsowen@…>

branch-nick:

xbase

revision id:

dsowen@fugue88.ws-20071003172121-56qbaz5sxe3k71ys

Message:

Now exports SQL do insert data.
Makefile creates executable.

File:

• version/0.1/xbase.lisp (modified) (5 diffs)

version/0.1/xbase.lisp

@@ +1 @@
+(require '#:asdf)
+(require '#:cl-ppcre)
+
+(use-package '#:cl-ppcre)
+
+
+
 ;;; Fairly generic file-reading stuff.
 
@@ -130 +137 @@
      ,@(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 '("user") :test 'equal)
+        (concatenate 'string "\"" name "\"")
+        name)))
+
+(defun sql-escape-data (value)
+  (if (string= value "")
+      "null"
+      (format nil "'~A'" (cl-ppcre:regex-replace-all "'" value "''"))))
+
 (defun sql-column (desc)
   (with-slots (name type size precision) desc
     (format nil "~A ~A"
-            name
+            (sql-escape-fieldname name)
             (cond
               ((string= type "C")
@@ -156 +181 @@
           (mapcar 'sql-column descs)))
 
-(defstruct dbf-desc
-  name
-  filename
-  sql-create)
-
-(defvar *dbfs* (make-hash-table :test 'eq))
+(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)
@@ -170 +206 @@
                             :filename ,filename
                             :sql-create ,(sql-create name descs)))
-       ,(struct-from-field-descs name descs))))
+       ,(struct-from-field-descs name descs)
+       ,(make-sql-function name name descs))))
 
 
@@ -193 +230 @@
 (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")
+
+
+
+(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;~%~%~%~%"
+              (slot-value (gethash 'import-struct *dbfs*) 'sql-create))
+      (dolist (rec recs)
+        (format t "~A;~%~%" (sql-insert rec))))))
+
+(defun main ()
+  (when (/= (length *posix-argv*) 2)
+    (format *error-output* "Usage: xbase dbf-file~%")
+    (quit))
+  (do-dbf (second *posix-argv*))
+  (quit))