[cl-dbf-cvs] CVS cl-dbf
CVS User rklochkov
rklochkov at common-lisp.net
Sat Mar 29 07:38:45 UTC 2014
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))))
-
-
More information about the cl-dbf-cvs
mailing list