Make xdump tables attributes of the parser object, move test data to separate subdire...

[eow] / xdump.lisp

diff --git a/xdump.lisp b/xdump.lisp
index 624eb6929173f16bed0365b28ca5803af7649fb9..8e099d815621b9643817e845e6339411b55583b0 100644 (file)
--- a/xdump.lisp
+++ b/xdump.lisp
@@ -14,21 +14,13 @@
    (index :accessor table-index :initarg :index)
    (last-update :accessor table-last-update :initform 0)
    (entry-class :accessor table-entry-class :initarg :entry-class)
    (index :accessor table-index :initarg :index)
    (last-update :accessor table-last-update :initform 0)
    (entry-class :accessor table-entry-class :initarg :entry-class)

-   (entries :accessor table-entries :initform (make-array 8
-                                                         :fill-pointer 8
-                                                         :adjustable t
-                                                         :initial-element nil))
+   (entries :accessor table-entries
+           :initform (make-array 8
+                                 :fill-pointer 0
+                                 :adjustable t
+                                 :initial-element nil))

    (has-uid-p :accessor has-uid-p :initarg :has-uid-p)))
 
    (has-uid-p :accessor has-uid-p :initarg :has-uid-p)))
 

-;(defclass empire-table ()
-;  (()))
-
-(defvar *meta-by-index* (make-array 128 :adjustable t :initial-element nil))
-(defvar *table-by-index* (make-array 128 :adjustable t :initial-element nil))
-(defvar *index-by-name* (make-hash-table :size 128 :test 'equal))
-(defvar *meta-index* (make-array 5) "meta slot symbol by meta table column index")
-(defvar *meta-meta* (make-array 5))
-

 (defun get-table (table-name)
   (let* ((table-index (gethash table-name *index-by-name*))
         (table (aref *table-by-index* table-index)))
 (defun get-table (table-name)
   (let* ((table-index (gethash table-name *index-by-name*))
         (table (aref *table-by-index* table-index)))


@@ -39,11 +31,24 @@
 
 (defclass xdump-parser ()
   ((line-parser :accessor line-parser :initform nil)
 
 (defclass xdump-parser ()
   ((line-parser :accessor line-parser :initform nil)

-   (entry-buffer :accessor entry-buffer :initform (make-array 1 :fill-pointer 0 :adjustable t))
+   (entry-buffer :accessor entry-buffer
+                :initform (make-array 1 :fill-pointer 0 :adjustable t))

    (entry-index :accessor entry-index :initform 0)
    (finalizer :accessor finalizer :initform nil)
    (name :accessor table-name :initform nil)
    (entry-index :accessor entry-index :initform 0)
    (finalizer :accessor finalizer :initform nil)
    (name :accessor table-name :initform nil)

-   (timestamp :accessor timestamp :initform nil)))
+   (timestamp :accessor timestamp :initform nil)
+   (meta-by-index :accessor meta-by-index
+                 :initform (make-array 128
+                                       :adjustable t
+                                       :initial-element nil))
+   (table-by-index :accessor table-by-index
+                  :initform (make-array 128
+                                        :adjustable t
+                                        :initial-element nil))
+   (index-by-name :accessor index-by-name
+                 :initform (make-hash-table :size 128 :test 'equal))
+   (meta-index :accessor meta-index :initform (make-array 5))
+   (meta-meta :accessor meta-meta :initform (make-array 5))))

 
 (defgeneric finish-table (xdump-parser number-of-records))
 (defgeneric parse-entry (xdump-parser line))
 
 (defgeneric finish-table (xdump-parser number-of-records))
 (defgeneric parse-entry (xdump-parser line))


@@ -51,41 +56,67 @@
 (defgeneric parse-table (xdump-parser name timestamp))
 (defgeneric header-parser (xdump-parser line))
 (defgeneric parse-line (xdump-parser line))
 (defgeneric parse-table (xdump-parser name timestamp))
 (defgeneric header-parser (xdump-parser line))
 (defgeneric parse-line (xdump-parser line))

+(defgeneric reset-table-parser (xdump-parser))
+
+(defmethod reset-table-parser ((parser xdump-parser))
+  (with-slots (line-parser entry-buffer entry-index finalizer name timestamp)
+      parser
+    (setf line-parser #'header-parser
+         entry-buffer (make-array 1 :fill-pointer 0 :adjustable t)
+         entry-index 0
+         finalizer nil
+         name nil
+         timestamp nil)))

 
 (defun meta-meta-finalizer (parser)
 
 (defun meta-meta-finalizer (parser)

-  (with-slots (entry-buffer) parser
-                                       ; build meta-index from integer index to slot symbol
+  (with-slots (entry-buffer meta-index meta-meta) parser
+                                       ; build meta-index from integer index to
+                                       ; slot symbol

     (loop
        for i = 0 then (+ i 1)
        for e across entry-buffer
        do (let* ((slot-name (string-upcase (car e)))
                 (slot (find-symbol slot-name :xdump)))
     (loop
        for i = 0 then (+ i 1)
        for e across entry-buffer
        do (let* ((slot-name (string-upcase (car e)))
                 (slot (find-symbol slot-name :xdump)))

-           (setf (aref *meta-index* i) slot)))
+           (setf (aref meta-index i) slot)))

                                        ; build meta-meta table
     (loop for entry across entry-buffer
        for i = 0 then (+ i 1)
                                        ; build meta-meta table
     (loop for entry across entry-buffer
        for i = 0 then (+ i 1)

-       do (let ((meta-meta (make-instance 'table-column-meta)))
-           (loop for slot across *meta-index*
+       do (let ((meta-meta-column (make-instance 'table-column-meta)))
+           (loop for slot across meta-index

               for field in entry
               for field in entry

-              do (setf (slot-value meta-meta slot) field))
-           (setf (aref *meta-meta* i) meta-meta)))))
+              do (setf (slot-value meta-meta-column slot) field))
+           (setf (aref meta-meta i) meta-meta-column)))))
+
+(defun table-entry-defclass-form (name class-name package slot-list)
+  `(defclass ,(find-symbol class-name package) ()
+     ,(mapcar #'(lambda (raw-slot-name)
+                 (let* ((slot-name (string-upcase raw-slot-name))
+                        (accessor-name (string-upcase (format nil "~a-~a"
+                                                              name
+                                                              slot-name))))
+                   (list (intern slot-name package)
+                         :accessor (intern accessor-name package))))
+             slot-list)))

 
 (defun meta-finalizer (parser)
   (let ((meta-table (make-array 1 :fill-pointer 0 :adjustable t)))
 
 (defun meta-finalizer (parser)
   (let ((meta-table (make-array 1 :fill-pointer 0 :adjustable t)))

-    (with-slots (entry-buffer name) parser
+    (with-slots (entry-buffer name meta-index meta-by-index index-by-name
+                             table-by-index)
+       parser

       (loop for entry across entry-buffer
         do (let ((meta (make-instance 'table-column-meta)))
       (loop for entry across entry-buffer
         do (let ((meta (make-instance 'table-column-meta)))

-             (loop for slot across *meta-index*
+             (loop for slot across meta-index

                 for field in entry
                 do (setf (slot-value meta slot) field))
              (vector-push-extend meta meta-table)))
       (format t "~a~%~a~%~a~%" name meta-table entry-buffer)
       (let ((table-index (if (string= "table" name)
                 for field in entry
                 do (setf (slot-value meta slot) field))
              (vector-push-extend meta meta-table)))
       (format t "~a~%~a~%~a~%" name meta-table entry-buffer)
       (let ((table-index (if (string= "table" name)

-                            ; voodoo: the first column of the table of tables is the uid
+                            ; voodoo: the first column of the table of tables
+                            ; is the uid

                             (elt (aref entry-buffer 0) 4)
                             (elt (aref entry-buffer 0) 4)

-                            (gethash name *index-by-name*)))
+                            (gethash name index-by-name)))

            (has-uid-p nil))
            (has-uid-p nil))

-       (setf (aref *meta-by-index* table-index) meta-table)
+       (setf (aref meta-by-index table-index) meta-table)

 
        ;; determine if this table has a uid column
        (if (and (string= "uid" (elt (aref entry-buffer 0) 0))
 
        ;; determine if this table has a uid column
        (if (and (string= "uid" (elt (aref entry-buffer 0) 0))


@@ -98,25 +129,23 @@
               (table-instance (make-instance 'xdump-table
                                              :name name
                                              :index table-index
               (table-instance (make-instance 'xdump-table
                                              :name name
                                              :index table-index

-                                             :entry-class (intern class-name package)
+                                             :entry-class (intern class-name
+                                                                  package)

                                              :has-uid-p has-uid-p))
               (slot-list (loop for entry across entry-buffer
                             collect (car entry))))
                                              :has-uid-p has-uid-p))
               (slot-list (loop for entry across entry-buffer
                             collect (car entry))))

-         (setf (aref *table-by-index* table-index) table-instance)
+         (setf (aref table-by-index table-index) table-instance)

          (format t "slot-list: ~a~%" slot-list)
          (format t "slot-list: ~a~%" slot-list)

-         (eval `(defclass ,(find-symbol class-name package) ()
-                  ,(mapcar #'(lambda (raw-slot-name)
-                               (let* ((slot-name (string-upcase raw-slot-name))
-                                      (accessor-name (string-upcase (format nil "~a-~a" name slot-name))))
-                                 (list (intern slot-name package) :accessor (intern accessor-name package))))
-                           slot-list))))))))
+         (eval (table-entry-defclass-form name class-name package
+                                          slot-list)))))))

 
 (defun entry-from-vector (class meta-table entry-vector)
   (let ((new-entry (make-instance class)))
     (loop
        for item in entry-vector
        for column across meta-table do
 
 (defun entry-from-vector (class meta-table entry-vector)
   (let ((new-entry (make-instance class)))
     (loop
        for item in entry-vector
        for column across meta-table do

-        (let ((slot (find-symbol (string-upcase (meta-name column)) (find-package "XDUMP-DATA"))))
+        (let ((slot (find-symbol (string-upcase (meta-name column))
+                                 (find-package "XDUMP-DATA"))))

           (setf (slot-value new-entry slot) item)))
     new-entry))
 
           (setf (slot-value new-entry slot) item)))
     new-entry))
 


@@ -124,21 +153,26 @@
                                        ; extend array if necessary
   (let ((entries (table-entries table)))
     (unless (> (fill-pointer entries) index)
                                        ; extend array if necessary
   (let ((entries (table-entries table)))
     (unless (> (fill-pointer entries) index)

-      (adjust-array entries (* 2 index) :fill-pointer index :initial-element nil))
+      (adjust-array entries (max 1 (* 2 index))
+                   :fill-pointer index
+                   :initial-element nil))

     (setf (aref entries index) entry)))
 
 (defun table-finalizer (parser)
     (setf (aref entries index) entry)))
 
 (defun table-finalizer (parser)

-  (with-slots (entry-buffer name timestamp) parser
+  (with-slots (entry-buffer name timestamp index-by-name meta-by-index
+                           table-by-index) parser

     (if (string= name "table") ; special magic: prefill index-by-name
        (loop for entry across entry-buffer do
     (if (string= name "table") ; special magic: prefill index-by-name
        (loop for entry across entry-buffer do

-            (setf (gethash (second entry) *index-by-name*) (first entry))))
+            (setf (gethash (second entry) index-by-name) (first entry))))

     (format t "table-finalizer: ~a~%" name)
     (format t "table-finalizer: ~a~%" name)

-    (let* ((table-index (gethash name *index-by-name*))
-          (meta-table (aref *meta-by-index* table-index))
-          (table (aref *table-by-index* table-index))
+    (let* ((table-index (gethash name index-by-name))
+          (meta-table (aref meta-by-index table-index))
+          (table (aref table-by-index table-index))

           (has-uid-p (has-uid-p table)))
       (loop for entry across entry-buffer do
           (has-uid-p (has-uid-p table)))
       (loop for entry across entry-buffer do

-          (let ((entry-instance (entry-from-vector (table-entry-class table) meta-table entry)))
+          (let ((entry-instance (entry-from-vector (table-entry-class table)
+                                                   meta-table
+                                                   entry)))

             (if has-uid-p
                 (let ((index (first entry)))
                   (table-entry-insert-at table entry-instance index))
             (if has-uid-p
                 (let ((index (first entry)))
                   (table-entry-insert-at table entry-instance index))


@@ -149,6 +183,7 @@
   (if (not (equal number-of-records (length (entry-buffer parser))))
       (error "Table row count mismatch"))
   (funcall (finalizer parser) parser)
   (if (not (equal number-of-records (length (entry-buffer parser))))
       (error "Table row count mismatch"))
   (funcall (finalizer parser) parser)

+  (reset-table-parser parser)

   t) ;; finished
 
 (defmethod parse-entry ((parser xdump-parser) line)
   t) ;; finished
 
 (defmethod parse-entry ((parser xdump-parser) line)


@@ -170,6 +205,12 @@
          timestamp input-timestamp)))
 
 (defmethod parse-table ((parser xdump-parser) input-name input-timestamp)
          timestamp input-timestamp)))
 
 (defmethod parse-table ((parser xdump-parser) input-name input-timestamp)

+  "Parse a normal table.
+
+   Args:
+     parser: The current parser
+     input-name: Name of the current table
+     input-timestamp: Timestamp of the current table"

   (with-slots (line-parser finalizer name timestamp) parser
     (setf line-parser #'parse-entry
          finalizer #'table-finalizer
   (with-slots (line-parser finalizer name timestamp) parser
     (setf line-parser #'parse-entry
          finalizer #'table-finalizer


@@ -193,31 +234,33 @@
            (parse-table parser name timestamp)))))
   nil)
 
            (parse-table parser name timestamp)))))
   nil)
 

-(defmethod parse-line ((parser xdump-parser) line)
-  (with-slots (line-parser) parser
-    (funcall line-parser parser line)))
-

 (defun make-parser ()
   (let ((parser (make-instance 'xdump-parser)))
     (setf (line-parser parser) #'header-parser)
     parser))
 
 (defun make-parser ()
   (let ((parser (make-instance 'xdump-parser)))
     (setf (line-parser parser) #'header-parser)
     parser))
 

-(defun parse (stream)
-  (let ((parser (make-parser)))
-    (setf *current-parser* parser)
-    (loop for line = (read-line stream nil)
-       while line do (parse-line parser line))))
+(defmethod parse-line ((parser xdump-parser) line)
+  (with-slots (line-parser) parser
+    (funcall line-parser parser line)))
+
+(defmethod parse-stream ((parser xdump-parser) stream)
+  (loop for line = (read-line stream nil)
+     while line do (parse-line parser line)))

 
 

-(defun test-parse (filename)
+(defmethod parse-file ((parser xdump-parser) filename)

   (with-open-file (s filename)
   (with-open-file (s filename)

-    (parse s)))
+    (parse-stream parser s)))

 
 (defun t1 ()
 
 (defun t1 ()

-  (test-parse "xdump-meta-meta.txt"))
-
+  (let ((parser (make-parser)))
+    (setf *current-parser* parser)
+    (parse-file parser "testdata/xdump-meta-meta.txt")))
+  

 (defun t2 ()
 (defun t2 ()

-  (test-parse "xdump-meta-meta.txt")
-  (test-parse "xdump-meta-table.txt")
-  (test-parse "xdump-table.txt")
-  (test-parse "xdump-meta-34.txt")
-  (test-parse "xdump-34.txt"))
+  (let ((parser (make-parser)))
+    (setf *current-parser* parser)
+    (parse-file parser "testdata/xdump-meta-meta.txt")
+    (parse-file parser "testdata/xdump-meta-table.txt")
+    (parse-file parser "testdata/xdump-table.txt")
+    (parse-file parser "testdata/xdump-meta-34.txt")
+    (parse-file parser "testdata/xdump-34.txt")))