source: version/1.0/binary-class.lisp

(defpackage #:binary-class
  (:use #:cl #:cl-ppcre)
  (:export #:lisp-type-for #:default-for #:read-binary #:define-file-struct))

(in-package #:binary-class)



(defstruct member-def
  name
  type
  format)

(defun parse-member-def (def)
  (destructuring-bind (name type format) def
    (make-member-def :name name :type type :format format)))

(defgeneric lisp-type-for (binary-type)
  (:method ((type (eql :unsigned)))
    '(integer 0))
  (:method ((type (eql :string)))
    'string)
  (:method ((type (eql :date)))
    't))

(defgeneric default-for (binary-type)
  (:method ((type (eql :unsigned)))
    0)
  (:method ((type (eql :string)))
    "")
  (:method ((type (eql :date)))
    (encode-universal-time 0 0 0 01 01 1970)))

(defgeneric read-binary (type stream &optional format)
  (:method ((type (eql :unsigned)) stream &optional (format 1))
    (let ((r 0))
      (dotimes (i format r)
        (setf (ldb (byte 8 (* i 8)) r) (read-byte stream)))))
  (:method ((type (eql :string)) stream &optional format)
    (let ((v (make-sequence '(vector (unsigned-byte 8)) format
                            :initial-element 0)))
      (read-sequence v stream)
      (string-trim '(#\Nul #\Space) (map 'string #'code-char v))))
  (:method ((type (eql :date)) stream &optional format)
    (assert (stringp format))
    (cond
      ((string= format "YYMMDD")
       (let* ((year (read-binary :unsigned stream))
              (month (read-binary :unsigned stream))
              (day (read-binary :unsigned stream)))
         (encode-universal-time 0 0 0 day month year)))
      ((string= format "YYYYMMDD")
       (let* ((year (read-binary :unsigned stream 2))
              (month (read-binary :unsigned stream))
              (day (read-binary :unsigned stream)))
         (encode-universal-time 0 0 0 day month year)))
      (t
       (error "Date-format must be either \"YYMMDD\" or \"YYYYMMDD\".")))))

(defmacro define-file-struct (name &body defs)
  (let ((defs (mapcar #'parse-member-def defs)))
    `(progn
       (defstruct ,name
         ,@(mapcar (lambda (def)
                     (with-slots (name type) def
                       `(,name ,(default-for type)
                               :type ,(lisp-type-for type))))
                   (remove-if #'null defs :key #'member-def-type)))
       (defmethod read-binary ((type (eql ',name)) stream &optional format)
         (declare (ignore format))
         (let ((rec (make-instance ',name)))
           ,@(mapcar (lambda (def)
                       (with-slots (name type format) def
                         (if name
                             `(setf (slot-value rec ',name)
                                    (read-binary ',type stream ,format))
                             `(read-binary :unsigned stream ,format))))
                     defs)
           rec)))))