[cl-dbf-cvs] CVS cl-dbf
CVS User rklochkov
rklochkov at common-lisp.net
Wed Mar 20 17:37:22 UTC 2013
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)))))
More information about the cl-dbf-cvs
mailing list