Changeset main,6 for main


Ignore:
Timestamp:
10/11/2007 10:09:29 PM (19 years ago)
Author:
David Owen <dsowen@…>
branch-nick:
xbase
revision id:
dsowen@fugue88.ws-20071011220929-sjjjdjykw7t25k5k
Message:

Use the new binary-class package.
Convert to keyword type for new package.
Fix: Properly encode funky strings.
Fix: Declare the generic function sql-insert to avoid compilation problems.
Removed old testing code.
Fix: Export only records that haven't been deleted.

Location:
main
Files:
2 edited

Legend:

Unmodified
Added
Removed

  • main/Makefile

    r4 r6  
    11all: xbase
     2
     3clean:
     4        rm -f *.fasl *~ xbase
    25
    36%: %.lisp

  • main/xbase.lisp

    r5 r6  
    11(require '#:asdf)
    22(require '#:cl-ppcre)
     3(require '#:dso-binary-class)
    34
    45(use-package '#:cl-ppcre)
    5 
    6 
    7 
    8 ;;; Fairly generic file-reading stuff.
    9 
    10 (defstruct member-def
    11   name
    12   type
    13   format)
    14 
    15 (defun parser-member-def (def)
    16   (destructuring-bind (name type format) def
    17     (make-member-def :name name :type type :format format)))
    18 
    19 (defun lisp-type-from-file-type (type)
    20   (ecase type
    21     (unsigned '(integer 0))
    22     (date t)
    23     (string 'string)))
    24 
    25 (defun default-from-file-type (type)
    26   (ecase type
    27     (unsigned 0)
    28     (date 0)
    29     (string "")))
    30 
    31 (defgeneric read-binary (type stream &optional format)
    32   (:method ((type (eql 'unsigned)) stream &optional (format 1))
    33     (let ((r 0))
    34       (dotimes (i format r)
    35         (setf (ldb (byte 8 (* i 8)) r) (read-byte stream)))))
    36   (:method ((type (eql 'string)) stream &optional format)
    37     (let ((v (make-sequence '(vector (unsigned-byte 8)) format
    38                             :initial-element 0)))
    39       (read-sequence v stream)
    40       (string-trim '(#\Nul #\Space) (map 'string #'code-char v))))
    41   (:method ((type (eql 'date)) stream &optional format)
    42     (assert (stringp format))
    43     (cond
    44       ((string= format "YYMMDD")
    45        (let* ((year (read-binary 'unsigned stream))
    46               (month (read-binary 'unsigned stream))
    47               (day (read-binary 'unsigned stream)))
    48          (encode-universal-time 0 0 0 day month year)))
    49       ((string= format "YYYYMMDD")
    50        (let* ((year (read-binary 'unsigned stream 2))
    51               (month (read-binary 'unsigned stream))
    52               (day (read-binary 'unsigned stream)))
    53          (encode-universal-time 0 0 0 day month year))))))
    54 
    55 (defmacro define-file-struct (name &body defs)
    56   (let ((defs (mapcar #'parser-member-def defs)))
    57     `(progn
    58        (defstruct ,name
    59          ,@(mapcar (lambda (def)
    60                      (with-slots (name type) def
    61                        `(,name ,(default-from-file-type type)
    62                                :type ,(lisp-type-from-file-type type))))
    63                    (remove-if #'null defs :key #'member-def-type)))
    64        (defmethod read-binary ((type (eql ',name)) stream &optional format)
    65          (declare (ignore format))
    66          (let ((rec (make-instance ',name)))
    67            ,@(mapcar (lambda (def)
    68                        (with-slots (name type format) def
    69                          (if name
    70                              `(setf (slot-value rec ',name)
    71                                     (read-binary ',type stream ,format))
    72                              `(read-binary 'unsigned stream ,format))))
    73                      defs)
    74            rec)))))
     6(use-package '#:binary-class)
    757
    768
    … …  
    7911
    8012(define-file-struct dbf-header
    81   (version unsigned 1)
    82   (last-update date "YYMMDD")
    83   (record-count unsigned 4)
    84   (header-length unsigned 2)
    85   (record-length unsigned 2)
     13  (version :unsigned 1)
     14  (last-update :date "YYMMDD")
     15  (record-count :unsigned 4)
     16  (header-length :unsigned 2)
     17  (record-length :unsigned 2)
    8618  (nil nil 2)
    87   (incomplete-transaction unsigned 1)
    88   (encrypted unsigned 1)
     19  (incomplete-transaction :unsigned 1)
     20  (encrypted :unsigned 1)
    8921  (nil nil 12)
    90   (mdx-flag unsigned 1)
    91   (language unsigned 1)
     22  (mdx-flag :unsigned 1)
     23  (language :unsigned 1)
    9224  (nil nil 2))
    9325
    9426(define-file-struct field-desc
    95   (name string 11)
    96   (type string 1)
     27  (name :string 11)
     28  (type :string 1)
    9729  (nil nil 4)
    98   (size unsigned 1)
    99   (precision unsigned 1)
     30  (size :unsigned 1)
     31  (precision :unsigned 1)
    10032  (nil nil 5)
    101   (set-fields-flag unsigned 1)
     33  (set-fields-flag :unsigned 1)
    10234  (nil nil 7)
    103   (is-indexed unsigned 1))
     35  (is-indexed :unsigned 1))
    10436
    10537(defun peek-byte (in)
    … …  
    12557  (with-slots (name type size) desc
    12658    (let ((type (cond
    127                   ((string= type "C") 'string)
    128                   ((string= type "N") 'string)
    129                   ((string= type "D") 'string)
    130                   ((string= type "M") 'string)
    131                   ((string= type "L") 'string)
     59                  ((string= type "C") :string)
     60                  ((string= type "N") :string)
     61                  ((string= type "D") :string)
     62                  ((string= type "M") :string)
     63                  ((string= type "L") :string)
    13264                  (t (abort)))))
    13365      `(,(intern name) ,type ,size))))
    … …  
    13567(defun struct-from-field-descs (name descs)
    13668  `(define-file-struct ,name
    137      (%deleted unsigned 1)
     69     (%deleted :unsigned 1)
    13870     ,@(mapcar #'slot-from-field descs)))
    13971
    … …  
    15183        name)))
    15284
     85(defun recode (str)
     86  (let (r
     87        e)
     88    (dotimes (i (length str))
     89      (let* ((ch (aref str i))
     90             (code (char-code ch)))
     91        (cond
     92          ((or (<= (char-code #\Space) code (char-code #\[))
     93               (<= (char-code #\]) code (char-code #\~)))
     94           (push (string ch) r))
     95          ((<= 0 code 255)
     96           (push (format nil "\\x~2,'0X" code) r)
     97           (setf e t))
     98          (t
     99           (error "Bad character!")))))
     100    (values
     101     (apply #'concatenate 'string (nreverse r))
     102     e)))
     103
    153104(defun sql-escape-data (value)
    154105  (if (string= value "")
    155106      "null"
    156       (let ((value
    157              (concatenate 'string "'" (regex-replace-all "'" value "''") "'")))
    158         (when (find #\\ value :test 'char=)
    159           (setf value (concatenate 'string
    160                                    "E"
    161                                    (regex-replace-all "\\\\"
    162                                                       value
    163                                                       "\\\\\\\\"))))
    164         value)))
     107      (multiple-value-bind (s recoded) (recode value)
     108        (concatenate 'string
     109                     (if recoded "E'" "'")
     110                     (regex-replace-all "'" s "''")
     111                     "'"))))
    165112
    166113(defun sql-column (desc)
    … …  
    192139          (mapcar 'sql-column descs)))
    193140
     141(defgeneric sql-insert (obj))
     142
    194143(defun make-sql-function (type name descs)
    195144  `(defmethod sql-insert ((obj ,type))
    … …  
    237186          (read-records in type))))))
    238187
    239 (define-dbf-struct unit-type "/home/dsowen/scott/local/bent-data/bentutyp.dbf")
    240 (define-dbf-struct vendor "/home/dsowen/scott/local/bent-data/bentvend.dbf")
    241 (define-dbf-struct phone "/home/dsowen/scott/local/bent-data/bentphon.dbf")
    242 (define-dbf-struct tenent-change "/home/dsowen/scott/local/bent-data/benttchg.dbf")
    243 
    244188
    245189
    … …  
    269213              (slot-value (gethash 'import-struct *dbfs*) 'sql-create))
    270214      (dolist (rec recs)
    271         (format t "~A;~%~%" (sql-insert rec))))))
     215        (unless (/= (slot-value rec '%deleted) 32)
     216          (format t "~A;~%~%" (sql-insert rec)))))))
    272217
    273218(defun main ()
Note: See TracChangeset for help on using the changeset viewer.