From rklochkov at common-lisp.net  Sat Mar 29 07:38:45 2014
From: rklochkov at common-lisp.net (CVS User rklochkov)
Date: Sat, 29 Mar 2014 00:38:45 -0700 (PDT)
Subject: [cl-dbf-cvs] CVS cl-dbf
Message-ID: <20140329073845.3B3EC356481@mail.common-lisp.net>

Update of /project/cl-dbf/cvsroot/cl-dbf
In directory alpha-cl-net:/tmp/cvs-serv10059

Modified Files:
	package.lisp src.lisp 
Log Message:
Rafael Jes??s Alc??ntara P??rez <ralcantara at dedaloingenieros.com> patch for memo fields


--- /project/cl-dbf/cvsroot/cl-dbf/package.lisp	2013/03/20 17:37:22	1.3
+++ /project/cl-dbf/cvsroot/cl-dbf/package.lisp	2014/03/29 07:38:44	1.4
@@ -2,17 +2,19 @@
   (:use #:cl #:binary-data #:com.gigamonkeys.binary-data.common-datatypes)
   (:export 
    #:code-page
+   #:dbase3-memo
+   #:dbase4-memo
    #:dbopen
    #:field-type
    #:fields
    #:goto-bof
    #:goto-record
    #:name
-   #:read-memo-datum
+   #:read-field-datum
    #:read-record
    #:records-count
    #:translate-field-datum
-   #:translate-memo-datum
+   #:visual-foxpro-memo
    #:with-db
    #:with-db-memo))
 
--- /project/cl-dbf/cvsroot/cl-dbf/src.lisp	2013/03/20 17:37:22	1.7
+++ /project/cl-dbf/cvsroot/cl-dbf/src.lisp	2014/03/29 07:38:45	1.8
@@ -15,6 +15,8 @@
 ;;; Visual FoxPro table field flags (position 18).
 ;;;
 
+(defparameter +dbt-memo-end-marker+ #x1A
+  "Marker for end of text in memo fields.")
 (defparameter +visual-foxpro-column-flag-system+ #x1 
   "System column (not visible to user).")
 (defparameter +visual-foxpro-column-flag-can-be-null+ #x2 
@@ -88,10 +90,12 @@
   (:reader (in)
     (let ((first-byte (read-byte in)))
       (when (= first-byte #xd) (signal 'in-padding))
-      (let ((rest (read-value 'iso-8859-1-string in :length (1- length))))
-        (string-right-trim '(#\Nul) 
-                           (concatenate
-                            'string (string (code-char first-byte)) rest)))))
+      (let* ((rest (read-value 'iso-8859-1-string in :length (1- length)))
+             (raw-dbf-field-name (concatenate 'string (string (code-char first-byte)) rest))
+             (nul-char-position (position #\nul raw-dbf-field-name)))
+        (if nul-char-position
+            (subseq raw-dbf-field-name 0 nul-char-position)
+            raw-dbf-field-name))))
   (:writer (out id)
     (write-value 'iso-8859-1-string out id :length (length id))
     (dotimes (i (- length (length id)))
@@ -164,6 +168,9 @@
 (define-binary-class dbase3 (dbase3-header)
   ((fields (xbase-fields :length header-size))))
 
+(define-binary-class dbase4 (dbase3-header)
+  ((fields (xbase-fields :length header-size))))
+
 (define-binary-class foxbase (dbase3-header)
   ((fields (xbase-fields :length header-size))))
 
@@ -178,12 +185,16 @@
   ((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))))
+  ((next-available-block u4)))
+
+(define-binary-class dbase3-memo (dbt-header)
+  ((reserved1 (discard :length 508))))
+
+(define-binary-class dbase4-memo (dbt-header)
+  ((record-size l4)
+   (reserved2 (discard :length 504))))
 
-(define-binary-class fpt-header (xbase-memo-common)
+(define-binary-class visual-foxpro-memo (xbase-memo-common)
   ((next-available-block u4)
    (reserved1 u2)
    (record-size u2)
@@ -192,7 +203,7 @@
 (defmethod header-size ((object xbase-memo-common))
   512)
 
-(defmethod record-size ((object dbt-header))
+(defmethod record-size ((object xbase-memo-common))
   512)
 
 ;;;
@@ -201,9 +212,10 @@
 
 (defun select-db-driver (db-type)
   (case db-type
-    (2 'foxbase)
-    (3 'dbase3)
-    ((48 49 50) 'visual-foxpro)
+    (#x2 'foxbase)
+    ((#x3 #x83) 'dbase3)
+    ((#x4 #x7B #x8B #x8E) 'dbase4)
+    ((#x30 #x31 #x32 #xF5) 'visual-foxpro)
     (t 'dbase3)))
    
 (defun dbopen (stream)
@@ -229,15 +241,15 @@
   (: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
+  (:method ((driver xbase-memo-common) n)
+    "In 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)."
+    overlaps the header."
     (file-position (slot-value driver 'stream)
                    (* n (record-size driver)))))
 
 (defun external-format (driver)
-  (or (slot-value driver 'external-format)
+  (or (and (slot-boundp driver 'external-format) (slot-value driver 'external-format))
       (case (code-page driver)
         (2    '(:code-page :id 850))
         (3    '(:code-page :id 1252))
@@ -248,51 +260,87 @@
         (#xC9 '(:code-page :id 1251))
         (t '(:code-page :id 437)))))
 
+;;; FIXME Join first and third methods.
 (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)
+         (flexi-streams:octets-to-string datum :external-format (external-format driver))))))
+  (:method ((driver xbase-memo-common) field datum)
     (declare (ignore field))
-    (with-slots (stream) driver
-      (flexi-streams:octets-to-string datum :external-format (external-format 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)
+  (:method ((driver dbase3-header) field &key (translate #'translate-field-datum))
     (with-slots (stream) driver
       (case (code-char (field-type field))
-        ((#\I #\M) (funcall translate driver field (read-value 'l4 stream)))
+        (#\I (funcall translate driver field (read-value 'l4 stream)))
+        (#\M (let ((s (make-array (size field) :element-type '(unsigned-byte 8))))
+               (read-sequence s stream)
+               (handler-case
+                   (let ((memo-block-index
+                          (parse-integer (flexi-streams:octets-to-string s :external-format (external-format driver)))))
+                     (when (plusp memo-block-index)
+                       (funcall translate driver field memo-block-index)))
+                 (parse-error () nil))))
         (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))
+             (funcall translate driver field s))))))
+  (:method ((driver dbase3-memo) field &key (translate #'translate-field-datum))
+    (with-slots (stream) driver
+      (let ((memo-value-pieces
+             (loop
+                :with memo-block-size := (record-size driver)
+                :with buffer := (make-array memo-block-size :element-type (stream-element-type stream))
+                :for read-length := (read-sequence buffer stream)
+                :for terminator-position := (position +dbt-memo-end-marker+ buffer :end read-length)
+                :if (zerop read-length)
+                  :return memo-value-pieces
+                :else
+                  :if terminator-position
+                    :collect (subseq buffer 0 terminator-position) :into memo-value-pieces
+                    :and :return memo-value-pieces
+                  :else
+                    :collect (subseq buffer 0 read-length) :into memo-value-pieces)))
+        (funcall translate driver field (apply #'concatenate (cons 'vector memo-value-pieces))))))
+  (:method ((driver dbase4-memo) field &key (translate #'translate-field-datum))
+    (with-slots (stream) driver
+      (let ((memo-value-pieces
+             (loop
+                :with memo-block-size := (record-size driver)
+                :with buffer := (make-array memo-block-size :element-type (stream-element-type stream))
+                :for read-length := (read-sequence buffer stream)
+                :for terminator-position := (position +dbt-memo-end-marker+ buffer :end read-length)
+                :if (zerop read-length)
+                  :return memo-value-pieces
+                :else
+                  :if terminator-position
+                    :collect (subseq buffer 8 terminator-position) :into memo-value-pieces
+                    :and :return memo-value-pieces
+                  :else
+                    :collect (subseq buffer 8 read-length) :into memo-value-pieces)))
+        (funcall translate driver field (apply #'concatenate (cons 'vector memo-value-pieces))))))
+  (:method ((driver visual-foxpro-memo) field &key (translate #'translate-field-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)))))
+        (funcall translate driver field datum))))
+  (:method ((driver visual-foxpro) field &key (translate #'translate-field-datum))
+    (with-slots (stream) driver
+      (case (code-char (field-type field))
+        ((#\I #\M) (let ((memo-block-index (read-value 'l4 stream)))
+                     (when (plusp memo-block-index)
+                       (funcall translate driver field memo-block-index))))
+        (t (let ((s (make-array (size field) :element-type '(unsigned-byte 8))))
+             (read-sequence s stream)
+             (funcall translate driver field s)))))))
 
 (defmethod read-record ((driver dbase3-header) &key (translate #'translate-field-datum))
   "Return record value as list and move to the next record.
@@ -302,11 +350,12 @@
       (32 (loop 
              :for field :in (fields driver)
              :collect (read-field-datum driver field :translate translate)))
+      (:eof nil)
       (t ; deleted record, skip and read again
        (file-position stream
                       (+ (file-position stream)
                          (1- (record-size driver))))
-       (read-record driver)))))
+       (read-record driver :translate translate)))))
 
 (defmacro with-db (db filespec &body body)
   (let ((stream (gensym)))
@@ -318,16 +367,8 @@
 
 (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 
+    `(with-open-file (,stream ,filespec :direction :io
                               :element-type 'unsigned-byte
                               :if-exists :overwrite)
        (let ((,db (dbopen-memo ,stream ,type ,code-page)))
          , at body))))
-
-