From rklochkov at common-lisp.net  Wed Mar 20 17:37:22 2013
From: rklochkov at common-lisp.net (CVS User rklochkov)
Date: Wed, 20 Mar 2013 10:37:22 -0700
Subject: [cl-dbf-cvs] CVS cl-dbf
Message-ID: <E1UIMx0-00065d-6a@common-lisp.net>

Update of /project/cl-dbf/cvsroot/cl-dbf
In directory tiger.common-lisp.net:/tmp/cvs-serv23033

Modified Files:
	cl-dbf.asd package.lisp src.lisp 
Added Files:
	conses.lisp 
Log Message:
Added support for FoxPro Memo
Thanks to Rafael Jes??s Alc??ntara P??rez, <ralcantara at dedaloingenieros.com>



--- /project/cl-dbf/cvsroot/cl-dbf/cl-dbf.asd	2012/12/31 22:14:00	1.4
+++ /project/cl-dbf/cvsroot/cl-dbf/cl-dbf.asd	2013/03/20 17:37:22	1.5
@@ -5,9 +5,10 @@
 (defsystem #:cl-dbf
   :description "DBF files reader/writer"
   :author "Roman Klochkov <kalimehtar at mail.ru>"
-  :version "0.1.2"
+  :version "0.2.0"
   :license "BSD"
   :depends-on (#:com.gigamonkeys.binary-data #:flexi-streams)
   :components
   ((:file #:package)
-   (:file #:src :depends-on (#:package))))
+   (:file #:src :depends-on (#:package))
+   (:file #:conses :depends-on (#:src))))
--- /project/cl-dbf/cvsroot/cl-dbf/package.lisp	2012/05/08 09:00:11	1.2
+++ /project/cl-dbf/cvsroot/cl-dbf/package.lisp	2013/03/20 17:37:22	1.3
@@ -1,13 +1,18 @@
 (defpackage #:cl-dbf
   (:use #:cl #:binary-data #:com.gigamonkeys.binary-data.common-datatypes)
   (:export 
-   #:records-count
-   #:read-record
-   #:fields
-   #:with-db
-   #:name
-   #:dbopen
    #:code-page
+   #:dbopen
+   #:field-type
+   #:fields
    #:goto-bof
-   #:goto-record))
+   #:goto-record
+   #:name
+   #:read-memo-datum
+   #:read-record
+   #:records-count
+   #:translate-field-datum
+   #:translate-memo-datum
+   #:with-db
+   #:with-db-memo))
 
--- /project/cl-dbf/cvsroot/cl-dbf/src.lisp	2012/12/31 22:18:25	1.6
+++ /project/cl-dbf/cvsroot/cl-dbf/src.lisp	2013/03/20 17:37:22	1.7
@@ -1,4 +1,5 @@
 ;; (c) Roman Klochkov, kalimehtar at mail.ru
+;;     Rafael Jes??s Alc??ntara P??rez, <ralcantara at dedaloingenieros.com>
 ;; 
 ;; Status: Alpha
 ;; for now you can do something like
@@ -10,6 +11,26 @@
 
 (in-package #:cl-dbf)
 
+;;;
+;;; Visual FoxPro table field flags (position 18).
+;;;
+
+(defparameter +visual-foxpro-column-flag-system+ #x1 
+  "System column (not visible to user).")
+(defparameter +visual-foxpro-column-flag-can-be-null+ #x2 
+  "Column can store null values.")
+(defparameter +visual-foxpro-column-flag-binary+ #x4 
+  "Binary column (for CHAR and MEMO only).")
+(defparameter +visual-foxpro-column-flag-binary-and-can-be-null+ #x6 
+  "When a field is binary and can be NULL (INTEGER, CURRENCY and 
+CHARACTER/MEMO fields).")
+(defparameter +visual-foxpro-column-flag-autoincrement+ #xC 
+  "Column is autoincrementing.")
+
+;;;
+;;; Binary types utilities. See `flexi-streams' package.
+;;;
+
 (define-binary-type unsigned-integer-le (bytes bits-per-byte)
   (:reader (in)
     (loop with value = 0
@@ -25,7 +46,6 @@
 (define-binary-type l3 () (unsigned-integer-le :bytes 3 :bits-per-byte 8))
 (define-binary-type l4 () (unsigned-integer-le :bytes 4 :bits-per-byte 8))
 
-
 (define-binary-type discard (length)
   (:reader (in)
            (dotimes (i length)
@@ -36,6 +56,10 @@
            (dotimes (i length)
              (write-byte 0 out))))
 
+;;;
+;;; xBase binary classes code.
+;;;
+
 (defclass xbase-common ()
   (stream external-format))
 
@@ -86,17 +110,27 @@
    (reserved3 (discard :length 7))
    (index u1)))
 
-(defun read-field (in)
-  (handler-case (read-value 'xbase-field in)
-    (in-padding () nil)))
+(define-binary-class visual-foxpro-field ()
+  ((name (db-field-name :length 11))
+   (field-type u1)
+   (reserved u4)
+   (size u1)
+   (precision u1)
+   (flags u1)
+   (autoincrement-next-value u4)
+   (autoincrement-step-value u1)
+   (reserved2 (discard :length 8))))
 
+(defun read-field (field-class in)
+  (handler-case (read-value field-class in)
+    (in-padding () nil)))
 
 (define-binary-type xbase-fields (length)
   (:reader 
    (in)
    (loop with to-read = (- length 32)
       while (plusp to-read)
-      for field = (read-field in)
+      for field = (read-field 'xbase-field in)
       while field
       do (decf to-read 32)
       collect field
@@ -109,16 +143,67 @@
         (decf to-write (+ 6 (size frame)))
       finally (loop repeat to-write do (write-byte 0 out)))))
 
+(define-binary-type visual-foxpro-fields (length)
+  (:reader 
+   (in)
+   (loop with to-read = (- length 32)
+      while (plusp to-read)
+      for field = (read-field 'visual-foxpro-field in)
+      while field
+      do (decf to-read 32)
+      collect field
+      finally (assert (null field))))
+  (:writer 
+   (out frames)
+   (loop with to-write = length
+      for frame in frames
+      do (write-value 'visual-foxpro-field out frame)
+        (decf to-write (+ 6 (size frame)))
+      finally (loop repeat to-write do (write-byte 0 out)))))
+
 (define-binary-class dbase3 (dbase3-header)
   ((fields (xbase-fields :length header-size))))
 
 (define-binary-class foxbase (dbase3-header)
   ((fields (xbase-fields :length header-size))))
 
+(define-binary-class visual-foxpro (dbase3-header)
+  ((fields (visual-foxpro-fields :length header-size))))
+
+;;;
+;;; Memo fields related classes.
+;;;
+
+(defclass xbase-memo-common (xbase-common)
+  ((code-page :reader code-page)))
+
+(define-binary-class dbt-header (xbase-memo-common)
+  ((next-available-block u4)
+   (reserved1 (discard :length 12))
+   (version u1)
+   (reserved2 (discard :length 494))))
+
+(define-binary-class fpt-header (xbase-memo-common)
+  ((next-available-block u4)
+   (reserved1 u2)
+   (record-size u2)
+   (reserved2 (discard :length 504))))
+
+(defmethod header-size ((object xbase-memo-common))
+  512)
+
+(defmethod record-size ((object dbt-header))
+  512)
+
+;;;
+;;; Utilities.
+;;;
+
 (defun select-db-driver (db-type)
   (case db-type
     (2 'foxbase)
     (3 'dbase3)
+    ((48 49 50) 'visual-foxpro)
     (t 'dbase3)))
    
 (defun dbopen (stream)
@@ -128,12 +213,28 @@
     (setf (slot-value db 'stream) stream)
     db))
 
+(defun dbopen-memo (stream type code-page)
+  (assert (and (input-stream-p stream) (output-stream-p stream)))
+  (file-position stream 0)
+  (let ((memo (read-value type stream)))
+    (setf (slot-value memo 'stream) stream)
+    (setf (slot-value memo 'code-page) code-page)
+    memo))
+
 (defun goto-bof (driver)
   (file-position (slot-value driver 'stream) (header-size driver)))
 
-(defun goto-record (driver n)
-  (file-position (slot-value driver 'stream) 
-                 (+ (header-size driver) (* n (record-size driver)))))
+(defgeneric goto-record (driver n)
+  (:documentation "Moves the stream to the record `n'.")
+  (:method ((driver dbase3-header) n)
+    (file-position (slot-value driver 'stream)
+                   (+ (header-size driver) (* n (record-size driver)))))
+  (:method ((driver fpt-header) n)
+    "In FPT memo files, the header is accesible via block numbers. So
+    it is up to the database engine to avoid using blocks that
+    overlaps the header (the first 512 bytes)."
+    (file-position (slot-value driver 'stream)
+                   (* n (record-size driver)))))
 
 (defun external-format (driver)
   (or (slot-value driver 'external-format)
@@ -147,21 +248,60 @@
         (#xC9 '(:code-page :id 1251))
         (t '(:code-page :id 437)))))
 
-(defmethod read-record ((driver dbase3-header))
+(defgeneric translate-field-datum (driver field datum)
+  (:method ((driver dbase3-header) field datum)
+    (flexi-streams:octets-to-string datum :external-format (external-format driver)))
+  (:method ((driver visual-foxpro) field datum)
+    (with-slots (stream) driver
+      (case (code-char (field-type field))
+        ((#\I #\M) datum)
+        (t
+         (flexi-streams:octets-to-string datum :external-format (external-format driver)))))))
+
+(defgeneric translate-memo-datum (driver field datum)
+  (:method ((driver fpt-header) field datum)
+    (declare (ignore field))
+    (with-slots (stream) driver
+      (flexi-streams:octets-to-string datum :external-format (external-format driver)))))
+
+(defgeneric read-field-datum (driver field &key translate)
+  (:documentation "Reads raw data from current `driver' `stream'
+  position and then, it uses `translate' for returning the real field
+  datum.")
+  (:method ((driver dbase3-header) field &key translate)
+    (with-slots (stream) driver
+      (let ((s (make-array (size field)
+                           :element-type '(unsigned-byte 8))))
+        (read-sequence s stream)
+        (funcall translate driver field s))))
+  (:method ((driver visual-foxpro) field &key translate)
+    (with-slots (stream) driver
+      (case (code-char (field-type field))
+        ((#\I #\M) (funcall translate driver field (read-value 'l4 stream)))
+        (t (let ((s (make-array (size field) :element-type '(unsigned-byte 8))))
+             (read-sequence s stream)
+             (funcall translate driver field s)))))))
+
+(defgeneric read-memo-datum (driver field &key translate)
+  (:documentation "Reads raw data from current `driver' `stream'
+  position and then, it uses `translate' for returning the real memo
+  datum.")
+  (:method ((driver fpt-header) field &key (translate #'translate-memo-datum))
+    (with-slots (stream) driver
+      (read-value 'l4 stream)
+      (let* ((size (read-value 'u4 stream))
+             (datum (make-array size :element-type '(unsigned-byte 8))))
+        (read-sequence datum stream)
+        (funcall translate driver field datum)))))
+
+(defmethod read-record ((driver dbase3-header) &key (translate #'translate-field-datum))
   "Return record value as list and move to the next record.
 When eof, return nil. Deleted records skipped."
   (with-slots (stream) driver
     (case (read-byte stream nil :eof)
       (32 (loop 
              :for field :in (fields driver)
-             :collect 
-             (let ((s (make-array (size field) 
-                                  :element-type '(unsigned-byte 8))))
-               (read-sequence s stream)
-               (flexi-streams:octets-to-string 
-                s 
-                :external-format (external-format driver)))))
-      (:eof nil)
+             :collect (read-field-datum driver field :translate translate)))
       (t ; deleted record, skip and read again
        (file-position stream
                       (+ (file-position stream)
@@ -176,18 +316,18 @@
        (let ((,db (dbopen ,stream)))
          , at body))))
 
-(defun dbf-to-conses-of-strings (filename &key external-format)
-  "FILNAME is a name of dbf file to open.
-Returns a list (field-names . record-values), 
-where values are strings.
-EXTERNAL-FORMAT is passed to flexi-streams:octets-to-string"
-  (with-db (db filename)
-    (when external-format
-      (setf (slot-value db 'external-format) external-format)
-      (cons (mapcar #'name (fields driver))
-            (loop 
-               :for rec = (read-record driver)
-               :while rec
-               :collect rec)))))
+(defmacro with-db-memo (db filespec type code-page &body body)
+  (let ((stream (gensym)))
+    (when (eql 'auto type)
+      (let ((filespec-type (pathname-type filespec)))
+        (setf type (cond
+                     ((equalp filespec-type "dbt") 'dbt-header)
+                     ((equalp filespec-type "fpt") 'fpt-header)
+                     (t (error "unknown memo type '~a'" filespec-type))))))
+    `(with-open-file (,stream ,filespec :direction :io 
+                              :element-type 'unsigned-byte
+                              :if-exists :overwrite)
+       (let ((,db (dbopen-memo ,stream ,type ,code-page)))
+         , at body))))
 
 

--- /project/cl-dbf/cvsroot/cl-dbf/conses.lisp	2013/03/20 17:37:22	NONE
+++ /project/cl-dbf/cvsroot/cl-dbf/conses.lisp	2013/03/20 17:37:22	1.1
;; (c) Roman Klochkov, kalimehtar at mail.ru
;; 


(in-package #:cl-dbf)


(defun dbf-to-conses-of-strings (filename &key external-format)
  "FILENAME is a name of dbf file to open.
Returns a list (field-names . record-values), 
where values are strings.
EXTERNAL-FORMAT is passed to flexi-streams:octets-to-string"
  (with-db db filename
    (when external-format
      (setf (slot-value db 'external-format) external-format)
      (cons (mapcar #'name (fields db))
            (loop 
               :for rec = (read-record db)
               :while rec
               :collect rec)))))