Make xdump tables attributes of the parser object, move test data to separate subdire...
authorGerd Flaig <gefla@rose.pond.sub.org>
Wed, 9 Feb 2011 22:19:11 +0000 (23:19 +0100)
committerGerd Flaig <gefla@rose.pond.sub.org>
Wed, 9 Feb 2011 22:19:11 +0000 (23:19 +0100)
13 files changed:
testdata/xdump-33.txt [new file with mode: 0644]
testdata/xdump-34.txt [new file with mode: 0644]
testdata/xdump-meta-33.txt [new file with mode: 0644]
testdata/xdump-meta-34.txt [new file with mode: 0644]
testdata/xdump-meta-meta.txt [new file with mode: 0644]
testdata/xdump-meta-table.txt [new file with mode: 0644]
testdata/xdump-table.txt [new file with mode: 0644]
xdump-34.txt [deleted file]
xdump-meta-34.txt [deleted file]
xdump-meta-meta.txt [deleted file]
xdump-meta-table.txt [deleted file]
xdump-table.txt [deleted file]
xdump.lisp

diff --git a/testdata/xdump-33.txt b/testdata/xdump-33.txt
new file mode 100644 (file)
index 0000000..d053099
--- /dev/null
@@ -0,0 +1,6 @@
+XDUMP meta-flags 1273526107
+1 "deity"
+2 "extra"
+4 "const"
+8 "bits"
+/4
diff --git a/testdata/xdump-34.txt b/testdata/xdump-34.txt
new file mode 100644 (file)
index 0000000..daea494
--- /dev/null
@@ -0,0 +1,16 @@
+XDUMP meta-type 1242293228
+1 "d"
+2 "g"
+3 "s"
+4 "d"
+5 "d"
+6 "d"
+7 "d"
+8 "d"
+9 "d"
+10 "d"
+11 "d"
+12 "d"
+13 "g"
+14 "c"
+/14
diff --git a/testdata/xdump-meta-33.txt b/testdata/xdump-meta-33.txt
new file mode 100644 (file)
index 0000000..39ef052
--- /dev/null
@@ -0,0 +1,4 @@
+XDUMP meta meta-flags 1273526102
+"value" 8 4 0 -1
+"name" 3 4 0 -1
+/2
diff --git a/testdata/xdump-meta-34.txt b/testdata/xdump-meta-34.txt
new file mode 100644 (file)
index 0000000..b7abe4c
--- /dev/null
@@ -0,0 +1,4 @@
+XDUMP meta meta-type 1242293224
+"value" 8 4 0 -1
+"name" 3 4 0 -1
+/2
diff --git a/testdata/xdump-meta-meta.txt b/testdata/xdump-meta-meta.txt
new file mode 100644 (file)
index 0000000..f672fb7
--- /dev/null
@@ -0,0 +1,7 @@
+XDUMP meta meta 1242293190
+"name" 3 4 0 -1
+"type" 4 4 0 34
+"flags" 5 12 0 33
+"len" 7 4 0 -1
+"table" 8 4 0 -1
+/5
diff --git a/testdata/xdump-meta-table.txt b/testdata/xdump-meta-table.txt
new file mode 100644 (file)
index 0000000..bd65dd7
--- /dev/null
@@ -0,0 +1,4 @@
+XDUMP meta table 1246361724
+"uid" 8 0 0 27
+"name" 3 4 0 -1
+/2
diff --git a/testdata/xdump-table.txt b/testdata/xdump-table.txt
new file mode 100644 (file)
index 0000000..5ec5a32
--- /dev/null
@@ -0,0 +1,51 @@
+XDUMP table 1246361738
+0 "sect"
+1 "ship"
+2 "plane"
+3 "land"
+4 "nuke"
+5 "news"
+6 "treaty"
+7 "trade"
+9 "nat"
+10 "loan"
+13 "commodity"
+14 "lost"
+15 "realm"
+16 "game"
+17 "item"
+18 "product"
+19 "sect-chr"
+20 "ship-chr"
+21 "plane-chr"
+22 "land-chr"
+23 "nuke-chr"
+24 "news-chr"
+25 "infrastructure"
+26 "updates"
+27 "table"
+28 "version"
+29 "meta"
+30 "agreement-status"
+31 "land-chr-flags"
+32 "level"
+33 "meta-flags"
+34 "meta-type"
+35 "missions"
+36 "nation-flags"
+37 "nation-rejects"
+38 "nation-relationships"
+39 "nation-status"
+40 "nuke-chr-flags"
+41 "packing"
+42 "page-headings"
+43 "plague-stages"
+44 "plane-chr-flags"
+45 "plane-flags"
+46 "resources"
+47 "retreat-flags"
+48 "sector-navigation"
+49 "ship-chr-flags"
+50 "treaty-flags"
+51 "country"
+/49
diff --git a/xdump-34.txt b/xdump-34.txt
deleted file mode 100644 (file)
index daea494..0000000
+++ /dev/null
@@ -1,16 +0,0 @@
-XDUMP meta-type 1242293228
-1 "d"
-2 "g"
-3 "s"
-4 "d"
-5 "d"
-6 "d"
-7 "d"
-8 "d"
-9 "d"
-10 "d"
-11 "d"
-12 "d"
-13 "g"
-14 "c"
-/14
diff --git a/xdump-meta-34.txt b/xdump-meta-34.txt
deleted file mode 100644 (file)
index b7abe4c..0000000
+++ /dev/null
@@ -1,4 +0,0 @@
-XDUMP meta meta-type 1242293224
-"value" 8 4 0 -1
-"name" 3 4 0 -1
-/2
diff --git a/xdump-meta-meta.txt b/xdump-meta-meta.txt
deleted file mode 100644 (file)
index f672fb7..0000000
+++ /dev/null
@@ -1,7 +0,0 @@
-XDUMP meta meta 1242293190
-"name" 3 4 0 -1
-"type" 4 4 0 34
-"flags" 5 12 0 33
-"len" 7 4 0 -1
-"table" 8 4 0 -1
-/5
diff --git a/xdump-meta-table.txt b/xdump-meta-table.txt
deleted file mode 100644 (file)
index bd65dd7..0000000
+++ /dev/null
@@ -1,4 +0,0 @@
-XDUMP meta table 1246361724
-"uid" 8 0 0 27
-"name" 3 4 0 -1
-/2
diff --git a/xdump-table.txt b/xdump-table.txt
deleted file mode 100644 (file)
index 5ec5a32..0000000
+++ /dev/null
@@ -1,51 +0,0 @@
-XDUMP table 1246361738
-0 "sect"
-1 "ship"
-2 "plane"
-3 "land"
-4 "nuke"
-5 "news"
-6 "treaty"
-7 "trade"
-9 "nat"
-10 "loan"
-13 "commodity"
-14 "lost"
-15 "realm"
-16 "game"
-17 "item"
-18 "product"
-19 "sect-chr"
-20 "ship-chr"
-21 "plane-chr"
-22 "land-chr"
-23 "nuke-chr"
-24 "news-chr"
-25 "infrastructure"
-26 "updates"
-27 "table"
-28 "version"
-29 "meta"
-30 "agreement-status"
-31 "land-chr-flags"
-32 "level"
-33 "meta-flags"
-34 "meta-type"
-35 "missions"
-36 "nation-flags"
-37 "nation-rejects"
-38 "nation-relationships"
-39 "nation-status"
-40 "nuke-chr-flags"
-41 "packing"
-42 "page-headings"
-43 "plague-stages"
-44 "plane-chr-flags"
-45 "plane-flags"
-46 "resources"
-47 "retreat-flags"
-48 "sector-navigation"
-49 "ship-chr-flags"
-50 "treaty-flags"
-51 "country"
-/49
index 624eb6929173f16bed0365b28ca5803af7649fb9..8e099d815621b9643817e845e6339411b55583b0 100644 (file)
    (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)))
 
-;(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)))
 
 (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)
-   (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 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)
-  (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)))
-           (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)
-       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
-              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)))
-    (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 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)
-                            ; 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)
-                            (gethash name *index-by-name*)))
+                            (gethash name index-by-name)))
            (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))
               (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))))
-         (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)
-         (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
-        (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))
 
                                        ; 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)
-  (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
-            (setf (gethash (second entry) *index-by-name*) (first entry))))
+            (setf (gethash (second entry) index-by-name) (first entry))))
     (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
-          (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 (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)
          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
            (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 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)
-    (parse s)))
+    (parse-stream parser s)))
 
 (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 ()
-  (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")))