Added asd files and separate test file.

Pascal J. Bourguignon [2018-10-16 09:17]
Added asd files and separate test file.
Filename
common-lisp/file/table-file/com.informatimago.common-lisp.file.table-file.test.asd
common-lisp/file/table-file/table-file-test.lisp
common-lisp/file/table-file/table-file.lisp
diff --git a/common-lisp/file/table-file/com.informatimago.common-lisp.file.table-file.test.asd b/common-lisp/file/table-file/com.informatimago.common-lisp.file.table-file.test.asd
new file mode 100644
index 0000000..94f0355
--- /dev/null
+++ b/common-lisp/file/table-file/com.informatimago.common-lisp.file.table-file.test.asd
@@ -0,0 +1,69 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;***************************************************************************
+;;;;FILE:                com.informatimago.common-lisp.file.table-file.test.asd
+;;;;LANGUAGE:            Common-Lisp
+;;;;SYSTEM:              None
+;;;;USER-INTERFACE:      None
+;;;;DESCRIPTION:
+;;;;
+;;;;    This file defines the com.informatimago.common-lisp.file.table-file.test system.
+;;;;    Tests the com.informatimago.common-lisp.file.table-file system.
+;;;;
+;;;;USAGE:
+;;;;
+;;;;AUTHORS:
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2018-10-16 <PJB> Created.
+;;;;BUGS:
+;;;;
+;;;;LEGAL:
+;;;;
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2018 - 2018
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>
+;;;;
+;;;;***************************************************************************
+
+(asdf:defsystem "com.informatimago.common-lisp.file.table-file.test"
+  ;; system attributes:
+  :description    "Tests the com.informatimago.common-lisp.file.table-file system."
+  :author         "Pascal J. Bourguignon <pjb@informatimago.com>"
+  :maintainer     "Pascal J. Bourguignon <pjb@informatimago.com>"
+  :licence        "AGPL3"
+  ;; component attributes:
+  :version        "1.0.0"
+  :properties     ((#:author-email . "pjb@informatimago.com")
+                   (#:date . "Autumn 2018")
+                   ((#:albert #:output-dir)
+                    . "/tmp/documentation/com.informatimago.common-lisp.file.table-file.test/")
+                   ((#:albert #:formats) "docbook")
+                   ((#:albert #:docbook #:template) . "book")
+                   ((#:albert #:docbook #:bgcolor) . "white")
+                   ((#:albert #:docbook #:textcolor) . "black"))
+  #+asdf-unicode :encoding #+asdf-unicode :utf-8
+  :depends-on     ("com.informatimago.common-lisp.cesarum"
+                   "com.informatimago.common-lisp.file.table-file")
+
+  :components     ((:file "table-file-test" :depends-on ()))
+  #+asdf3 :perform #+asdf3 (asdf:test-op
+                            (operation system)
+                            (declare (ignore operation system))
+                            (dolist (p '("COM.INFORMATIMAGO.COMMON-LISP.FILE.TABLE-FILE"))
+                              (let ((*package* (find-package p)))
+                                (uiop:symbol-call p "TEST/ALL")))))
+
+;;;; THE END ;;;;
diff --git a/common-lisp/file/table-file/table-file-test.lisp b/common-lisp/file/table-file/table-file-test.lisp
new file mode 100644
index 0000000..76dda23
--- /dev/null
+++ b/common-lisp/file/table-file/table-file-test.lisp
@@ -0,0 +1,143 @@
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               table-file-test.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    Tests the table-file file access method.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2018-10-16 <PJB> Extracted from table-file.lisp
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2018 - 2018
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.FILE.TABLE-FILE")
+
+(defun test/table-file ()
+  (let ((path  "/tmp/test-txt.table")
+        (path2 "/tmp/test-bin.table")
+        (rows   7)
+        (cols   5)
+        (rsize 64))
+
+    (create-table-file path rows cols rsize)
+
+    (let ((table (open-table-file path :direction :io))
+          (record (make-array rsize :element-type 'octet)))
+      (loop :for i :from 1 :below rows
+            :do (loop :for j :from 1 :below cols
+                      :for value :=  (* i j)
+                      :do (replace record (map 'vector (function char-code) (format nil "~D~%" value)))
+                          (setf (table-file-ref table i j) record)))
+      (close-table-file table))
+
+    (let ((table (open-table-file path :direction :io))
+          (record (make-array rsize :element-type 'octet)))
+      (loop :for i :from 1 :below rows
+            :do  (replace record (map 'vector (function char-code) (format nil "~D~%" i)))
+                 (setf (table-file-ref table i 0) record))
+      (loop :for j :from 1 :below cols
+            :do  (replace record (map 'vector (function char-code) (format nil "~D~%" j)))
+                 (setf (table-file-ref table 0 j) record))
+      (loop :for i :from 1 :below rows
+            :do (loop :for j :from 1 :below cols
+                      :for value :=  (* i j)
+                      :do (assert (eql value (read-from-string
+                                              (map 'string (function code-char)
+                                                   (table-file-ref table i j record)))))))
+      (close-table-file table))
+
+    (flet ((dump-table (path deserializer)
+             (let* ((table (open-table-file path :direction :input :deserializer deserializer))
+                    (record (make-array (table-file-record-size table) :element-type 'octet)))
+               (loop :for i :from 1 :below (table-file-rows table)
+                     :do (loop :for j :from 1 :below (table-file-cols table)
+                               :do (format t "~4D " (table-file-ref table i j record)))
+                         (terpri))
+               (close-table-file table))))
+
+      (format t "~%Stored as text:~%")
+      (dump-table path (lambda (record)
+                         (read-from-string (map 'string (function code-char) record))))
+
+
+      (let ((rsize 4))
+        (flet ((serializer (integer)
+                 (loop
+                   :with record := (make-array rsize :element-type 'octet)
+                   :for i :below (length record)
+                   :do (setf (aref record i) (ldb (byte 8 (* 8 i)) integer))
+                   :finally (return record)))
+               (deserializer  (record)
+                 (loop
+                   :with integer := 0
+                   :for i :below (length record)
+                   :do (setf integer (dpb (aref record i) (byte 8 (* 8 i)) integer))
+                   :finally (return integer))))
+          (create-table-file path2 rows cols rsize)
+          (let ((table (open-table-file path2
+                                        :direction :io
+                                        :serializer (function serializer)
+                                        :deserializer (function deserializer)))
+                (record (make-array rsize :element-type 'octet)))
+            (loop :for i :from 1 :below rows
+                  :do (setf (table-file-ref table i 0) i))
+            (loop :for j :from 1 :below cols
+                  :do  (setf (table-file-ref table 0 j) j))
+            (loop :for i :from 1 :below rows
+                  :do (loop :for j :from 1 :below cols
+                            :do (setf (table-file-ref table i j record) (* i j))))
+            (loop :for i :from 1 :below rows
+                  :do (loop :for j :from 1 :below cols
+                            :do (assert (= (table-file-ref table i j record) (* i j)))))
+            (close-table-file table)
+            (format t "~%Stored as binary:~%")
+            (dump-table path2 (function deserializer))))))))
+
+#|
+cl-user> (test/table-file)
+Stored as text:
+   1    2    3    4
+   2    4    6    8
+   3    6    9   12
+   4    8   12   16
+   5   10   15   20
+   6   12   18   24
+
+Stored as binary:
+   1    2    3    4
+   2    4    6    8
+   3    6    9   12
+   4    8   12   16
+   5   10   15   20
+   6   12   18   24
+t
+cl-user>
+|#
+
+(defun test/all ()
+  (test/table-file)
+  :success)
+
+;;;; THE END ;;;;
diff --git a/common-lisp/file/table-file/table-file.lisp b/common-lisp/file/table-file/table-file.lisp
index d5ef2f7..a1cfc29 100644
--- a/common-lisp/file/table-file/table-file.lisp
+++ b/common-lisp/file/table-file/table-file.lisp
@@ -1,4 +1,41 @@
-(defpackage "COM.INFORMATIMAGO.COMMON-LISP.TABLE-FILE"
+;;;; -*- mode:lisp;coding:utf-8 -*-
+;;;;**************************************************************************
+;;;;FILE:               table-file.lisp
+;;;;LANGUAGE:           Common-Lisp
+;;;;SYSTEM:             Common-Lisp
+;;;;USER-INTERFACE:     NONE
+;;;;DESCRIPTION
+;;;;
+;;;;    This package implements a binary file access method,
+;;;;    with fixed-size records, indexed by row and column.
+;;;;    The record size, and the numbers of rows and columns are fixed
+;;;;    and determined at file creation time.
+;;;;
+;;;;AUTHORS
+;;;;    <PJB> Pascal J. Bourguignon <pjb@informatimago.com>
+;;;;MODIFICATIONS
+;;;;    2018-10-15 <PJB> Created.
+;;;;BUGS
+;;;;LEGAL
+;;;;    AGPL3
+;;;;
+;;;;    Copyright Pascal J. Bourguignon 2018 - 2018
+;;;;
+;;;;    This program is free software: you can redistribute it and/or modify
+;;;;    it under the terms of the GNU Affero General Public License as published by
+;;;;    the Free Software Foundation, either version 3 of the License, or
+;;;;    (at your option) any later version.
+;;;;
+;;;;    This program is distributed in the hope that it will be useful,
+;;;;    but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;;;    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+;;;;    GNU Affero General Public License for more details.
+;;;;
+;;;;    You should have received a copy of the GNU Affero General Public License
+;;;;    along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;;;**************************************************************************
+
+(defpackage "COM.INFORMATIMAGO.COMMON-LISP.FILE.TABLE-FILE"
   (:use "COMMON-LISP")
   (:export "CREATE-TABLE-FILE"
            "OPEN-TABLE-FILE"
@@ -10,21 +47,42 @@
            "TABLE-FILE-ROWS"
            "TABLE-FILE-COLS"
            "TABLE-FILE-RECORD-SIZE"))
-(in-package "COM.INFORMATIMAGO.COMMON-LISP.TABLE-FILE")
+(in-package "COM.INFORMATIMAGO.COMMON-LISP.FILE.TABLE-FILE")
+
+(define-condition table-file-error (stream-error)
+  ((table-file       :initarg :table-file       :reader table-file-error-table-file)
+   (format-string    :initarg :format-string    :reader table-file-error-format-string)
+   (format-arguments :initarg :format-arguments :reader table-file-error-format-arguments)
+   (stream-error     :initarg :stream-error     :reader table-file-error-stream-error)))
+
+(define-condition table-file-header-too-big-error (table-file-error)
+  ())
+

 (deftype octet () '(unsigned-byte 8))

 (defconstant +header-size+ 1024)
+(defconstant +filler+ (char-code #\newline) "Default byte to fill buffers with.")

 (defun write-header (file rows cols record-size)
-  (let ((header (make-array +header-size+
-                           :element-type 'octet
-                           :initial-element (char-code #\newline))))
-    (replace header (map 'vector 'char-code (prin1-to-string (list :file :table
-                                                                   :version 1
-                                                                   :rows rows
-                                                                   :cols cols
-                                                                   :record-size record-size))))
+  (let* ((header (make-array +header-size+
+                             :element-type 'octet
+                             :initial-element +filler+))
+         (data    (map 'vector 'char-code
+                       (with-output-to-string (out)
+                         (prin1 (list :file :table
+                                      :version 1
+                                      :rows rows
+                                      :cols cols
+                                      :record-size record-size)
+                                out)
+                         (terpri out)))))
+    (when (< (length header) (length data))
+      (error 'table-file-header-too-big-error
+             :table-file file
+             :format-string "Data header for the ~S at pathname ~S is too big (more than ~D bytes)."
+             :format-arguments 'table-file (pathname file) +header-size+))
+    (replace header data)
     (file-position file 0)
     (write-sequence header file)))

@@ -36,7 +94,7 @@
     (write-header file rows cols record-size)
     (let ((row (make-array (* cols record-size)
                            :element-type 'octet
-                           :initial-element (char-code #\newline))))
+                           :initial-element +filler+)))
       (file-position file +header-size+)
       (loop :repeat rows
             :do (write-sequence row file)))))
@@ -46,7 +104,9 @@
   version
   rows
   cols
-  record-size)
+  record-size
+  serializer
+  deserializer)

 (defun read-header (stream)
   (file-position stream 0)
@@ -66,40 +126,32 @@
                          :cols cols
                          :record-size record-size)))))

-#|
-|--------------------+--------------------|
-| :direction         | :input             |
-|                    | :output            |
-|                    | :io                |
-|--------------------+--------------------|
-| :if-does-not-exist | :create            |
-|                    | :error             |
-|                    | nil                |
-|--------------------+--------------------|
-| :if-exists         | :error             |
-|                    | :new-version       |
-|                    | :rename            |
-|                    | :rename-and-delete |
-|                    | :overwrite         |
-|                    | :append            |
-|                    | :supersede         |
-|                    | nil.               |
-|--------------------+--------------------|
-|#
-
-(defun open-table-file (pathname &key (direction :input))
+(defun open-table-file (pathname &key (direction :input) serializer deserializer)
   (assert (member direction '(:input :io)))
   (let* ((stream (open pathname :direction direction
                                 :if-does-not-exist :error
                                 :if-exists :append ; with :io
-                                :element-type 'octet)))
-     (read-header stream)))
+                                :element-type 'octet))
+         (file (read-header stream)))
+    (setf (table-file-serializer file) serializer
+          (table-file-deserializer file) deserializer)
+    file))

-(defun table-file-ref (file row col &optional record)
+(defun check-arguments (file row col record)
   (assert (< -1 row (table-file-rows file))
           (row) "row ~A out of bounds 0 .. ~A" row (1-  (table-file-rows file)))
   (assert (< -1 col (table-file-cols file))
           (col) "col ~A out of bounds 0 .. ~A" col (1-  (table-file-cols file)))
+  (when record
+    (assert (and (typep record 'vector)
+                 (subtypep 'octet (array-element-type record))
+                 (<= (table-file-record-size file) (array-dimension record 0)))
+            (record)
+            "Improper record type ~S for the ~S at pathname ~S"
+            (type-of record) 'table-file (pathname (table-file-stream file)))))
+
+(defun table-file-ref (file row col &optional record)
+  (check-arguments file row col record)
   (let ((pos (+ +header-size+
                 (* (table-file-record-size file)
                    (+ col (* row (table-file-cols file))))))
@@ -109,80 +161,27 @@
         (stream (table-file-stream file)))
     (file-position stream pos)
     (read-sequence record stream)
-    record))
+    (if (table-file-deserializer file)
+        (funcall (table-file-deserializer file) record)
+        record)))

-(defun (setf table-file-ref) (new-record file row col)
-  (assert (< -1 row (table-file-rows file))
-          (row) "row ~A out of bounds 0 .. ~A" row (1-  (table-file-rows file)))
-  (assert (< -1 col (table-file-cols file))
-          (col) "col ~A out of bounds 0 .. ~A" col (1-  (table-file-cols file)))
+(defun (setf table-file-ref) (new-value file row col &optional record)
+  (check-arguments file row col record)
   (let ((pos (+ +header-size+
                 (* (table-file-record-size file)
                    (+ col (* row (table-file-cols file))))))
-        (record (make-array (table-file-record-size file)
-                            :element-type 'octet
-                            :initial-element (char-code #\newline)))
+        (record (or record  (make-array (table-file-record-size file)
+                                        :element-type 'octet
+                                        :initial-element +filler+)))
         (stream (table-file-stream file)))
-    (replace record new-record)
+    (replace record (if (table-file-serializer file)
+                        (funcall (table-file-serializer file) new-value)
+                        new-value))
     (file-position stream pos)
     (write-sequence record stream)
-    record))
+    new-value))

 (defun close-table-file (file)
   (close (table-file-stream file)))


-(defun test/table-file ()
-  (let ((path  "/tmp/test.table")
-        (rows   7)
-        (cols   5)
-        (rsize 64))
-
-    (create-table-file path rows cols rsize)
-
-    (let ((table (open-table-file path :direction :io))
-          (record (make-array rsize :element-type 'octet)))
-      (loop :for i :from 1 :below rows
-            :do (loop :for j :from 1 :below cols
-                      :for value :=  (* i j)
-                      :do (replace record (map 'vector (function char-code) (format nil "~D~%" value)))
-                          (setf (table-file-ref table i j) record)))
-      (close-table-file table))
-
-    (let ((table (open-table-file path :direction :io))
-          (record (make-array rsize :element-type 'octet)))
-      (loop :for i :from 1 :below rows
-            :do  (replace record (map 'vector (function char-code) (format nil "~D~%" i)))
-                 (setf (table-file-ref table i 0) record))
-      (loop :for j :from 1 :below cols
-            :do  (replace record (map 'vector (function char-code) (format nil "~D~%" j)))
-                 (setf (table-file-ref table 0 j) record))
-      (loop :for i :from 1 :below rows
-            :do (loop :for j :from 1 :below cols
-                      :for value :=  (* i j)
-                      :do (assert (eql value (read-from-string
-                                              (map 'string (function code-char)
-                                                   (table-file-ref table i j record)))))))
-      (close-table-file table))
-
-    (let ((table (open-table-file path :direction :io))
-          (record (make-array rsize :element-type 'octet)))
-      (loop :for i :from 1 :below rows
-            :do (loop :for j :from 1 :below cols
-                      :do (format t "~4D " (read-from-string
-                                            (map 'string (function code-char)
-                                                 (table-file-ref table i j record)))))
-                (terpri))
-      (close-table-file table))))
-
-#|
-cl-user> (test/table-file)
-   1    2    3    4
-   2    4    6    8
-   3    6    9   12
-   4    8   12   16
-   5   10   15   20
-   6   12   18   24
-t
-cl-user>
-|#
ViewGit