Start integration of xdump with protocol
authorGerd Flaig <gefla@pond.sub.org>
Sat, 29 Aug 2009 23:28:45 +0000 (01:28 +0200)
committerGerd Flaig <gefla@pond.sub.org>
Sat, 29 Aug 2009 23:28:45 +0000 (01:28 +0200)
empire.lisp
eow.mbd
package.lisp
xdump-test.lisp [deleted file]
xdump.lisp [new file with mode: 0644]

index 2f3452e3af8113b120fd87fd0a6873c70231ae7e..c8993e8bb8cb53899befdecc38bc9ef120681ab2 100644 (file)
        (char= +special-command-char+ (aref line 0))))
 
 (defclass xdump-mode (play-mode)
-  ((table-buffer
-    :initform nil
-    :accessor table-buffer
-    :documentation "Intermediate storage for incomplete table dump.")))
+  ((parser :initform (xdump:make-parser))
+   (phase :initform :meta-meta)))
 
 (defmethod handle-data ((m xdump-mode) message)
-  (with-slots (connection table-buffer) m
-    (if (char= #\/ (aref message 0))
-       (progn
-         (format t "table: ~a~%" table-buffer)
-         (set-new-mode m 'play-mode)))
-                                       ;XXX check table size
-    (with-input-from-string (s (format nil "(~a)" message))
-      (setf table-buffer (cons (read s) table-buffer)))))
+  (with-slots (connection parser phase) m
+    (if (xdump:parse-line parser message)
+       ;;XXX consider something like a 'pop-mode function
+       (case phase
+         (:meta-meta 
+          (setf phase :meta-table)
+          (send-message connection "xdump meta table" :next-mode 'xdump-mode))
+         (:meta-table
+          (setf phase :table)
+          (send-message connection "xdump table *" :next-mode 'xdump-mode))
+         (:table
+          (set-new-mode (connection-mode connection) 'play-mode))))))
 
 (defmethod special-xup ((c connection))
   (send-message c "xdump meta meta" :next-mode 'xdump-mode))
diff --git a/eow.mbd b/eow.mbd
index 587b648fd2cfb533ca937ab8fd0bd7517d8e6079..2c8ded193ce205a3977cab727a0c8ef644b21e12 100644 (file)
--- a/eow.mbd
+++ b/eow.mbd
@@ -12,6 +12,7 @@
    ("util" (:needs "package"))
    ("locked-queue" (:needs "package"))
    ("log" (:needs "package"))
+   ("xdump" (:needs "package"))
    ("web" (:needs "locked-queue" "log"))
-   ("empire" (:needs "util" "log")))
+   ("empire" (:needs "util" "log" "xdump")))
   (:needs :usocket :hunchentoot :parenscript))
index 64ff316fc44bdc9a1ca9cbc059e7919bab334029..5459b5028272ec08188f22cf1e12657744a3ec1b 100644 (file)
@@ -24,4 +24,5 @@
   (defpackage :xdump-data
     (:use :cl))
   (defpackage :xdump
-    (:use :cl :xdump-data)))
+    (:use :cl :xdump-data)
+    (:export :make-parser :parse-line)))
diff --git a/xdump-test.lisp b/xdump-test.lisp
deleted file mode 100644 (file)
index 928748c..0000000
+++ /dev/null
@@ -1,204 +0,0 @@
-(in-package :xdump)
-
-(defparameter *mode* (make-instance 'empire::xdump-mode :connection nil))
-
-(defvar *current-parser* nil)
-
-(defclass table-column-meta ()
-  ((name :accessor meta-name)
-   (type :accessor meta-type)
-   (flags :accessor meta-flags)
-   (len :accessor meta-len)
-   (table :accessor meta-table)))
-
-(defclass xdump-table ()
-  ((name :accessor table-name :initarg :name)
-   (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))))
-
-;(defclass empire-table ()
-;  (()))
-
-(defvar *meta-by-index* (make-array 50 :adjustable t :initial-element nil))
-(defvar *table-by-index* (make-array 50 :adjustable t :initial-element nil))
-(defvar *index-by-name* (make-hash-table :size 50 :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-entry (table-name index)
-  (let* ((table-index (gethash table-name *index-by-name*))
-        (table (aref *table-by-index* table-index)))
-    (aref (table-entries 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-index :accessor entry-index :initform 0)
-   (finalizer :accessor finalizer :initform nil)
-   (name :accessor table-name :initform nil)
-   (timestamp :accessor timestamp :initform nil)))
-
-(defgeneric finish-table (xdump-parser number-of-records))
-(defgeneric parse-entry (xdump-parser line))
-(defgeneric parse-meta (xdump-parser name timestamp))
-(defgeneric parse-table (xdump-parser name timestamp))
-(defgeneric header-parser (xdump-parser line))
-(defgeneric parse-line (xdump-parser line))
-
-(defun meta-meta-finalizer (parser)
-  (with-slots (entry-buffer) 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)))
-                                       ; 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*
-              for field in entry
-              do (setf (slot-value meta-meta slot) field))
-           (setf (aref *meta-meta* i) meta-meta)))))
-
-(defun meta-finalizer (parser)
-  (let ((meta-table (make-array 1 :fill-pointer 0 :adjustable t)))
-    (with-slots (entry-buffer name) parser
-      (loop for entry across entry-buffer
-        do (let ((meta (make-instance 'table-column-meta)))
-             (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
-                            (elt (aref entry-buffer 0) 4)
-                            (gethash name *index-by-name*))))
-       (setf (aref *meta-by-index* table-index) meta-table)
-
-       ;; create xdump-table instance and entry class
-       (let* ((class-name (string-upcase (format nil "~a-table-entry" name)))
-              (package (find-package "XDUMP-DATA"))
-              (table-instance (make-instance 'xdump-table
-                                             :name name
-                                             :index table-index
-                                             :entry-class (intern class-name package)))
-              (slot-list (loop for entry across entry-buffer
-                            collect (car entry))))
-         (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))))))))
-
-(defun table-finalizer (parser)
-  (with-slots (entry-buffer name timestamp) 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))))
-    (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)))
-      (loop for entry across entry-buffer do
-          (let ((e (make-instance (table-entry-class table)))
-                (index (first entry))
-                (entries (table-entries table)))
-            ; extend array if necessary
-            (unless (> (fill-pointer entries) index)
-              (adjust-array entries (* 2 index) :fill-pointer t))
-            (setf (aref entries index) e)
-            (loop
-               for item in entry
-               for column across meta-table do
-                 (setf (slot-value e (find-symbol (string-upcase (meta-name column)) (find-package "XDUMP-DATA"))) item))))
-      (setf (table-last-update table) timestamp))))
-
-(defmethod finish-table ((parser xdump-parser) number-of-records)
-  (if (not (equal number-of-records (length (entry-buffer parser))))
-      (error "Table row count mismatch"))
-  (funcall (finalizer parser) parser))
-
-(defmethod parse-entry ((parser xdump-parser) line)
-  (if (char= #\/ (aref line 0))
-      (finish-table parser (parse-integer (subseq line 1)))
-      (let ((fields (mapcar #'read-from-string (cl-ppcre:split " " line))))
-       (with-slots (entry-buffer entry-index) parser
-         (vector-push-extend fields entry-buffer)
-         (incf entry-index)))))
-
-(defmethod parse-meta ((parser xdump-parser) input-name input-timestamp)
-  (with-slots (line-parser finalizer name timestamp) parser
-    (setf line-parser #'parse-entry
-         finalizer (if (string= "meta" input-name)
-                       #'meta-meta-finalizer
-                       #'meta-finalizer)
-         name input-name
-         timestamp input-timestamp)))
-
-(defmethod parse-table ((parser xdump-parser) input-name input-timestamp)
-  (with-slots (line-parser finalizer name timestamp) parser
-    (setf line-parser #'parse-entry
-         finalizer #'table-finalizer
-         name input-name
-         timestamp input-timestamp)))
-
-(defmethod header-parser ((parser xdump-parser) line)
-  (multiple-value-bind (fullmatch groups)
-      (cl-ppcre:scan-to-strings "^XDUMP meta (.*) ([0-9]+)$" line)
-    (if fullmatch
-       ;; meta table
-       (let ((name (aref groups 0))
-             (timestamp (parse-integer (aref groups 1))))
-         (parse-meta parser name timestamp))
-       ;; table
-       (multiple-value-bind (fullmatch groups)
-           (cl-ppcre:scan-to-strings "^XDUMP (.*) ([0-9]+)$" line)
-         (declare (ignorable fullmatch))
-         (let ((name (aref groups 0))
-               (timestamp (parse-integer (aref groups 1))))
-           (parse-table parser name timestamp))))))
-
-(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))))
-
-(defun test-parse (filename)
-  (with-open-file (s filename)
-    (parse s)))
-
-(defun xd-test (input)
-  (loop for m in input
-     do (empire::handle-data *mode* m)))
-
-(defun t1 ()
-  (test-parse "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"))
diff --git a/xdump.lisp b/xdump.lisp
new file mode 100644 (file)
index 0000000..c2f866e
--- /dev/null
@@ -0,0 +1,201 @@
+(in-package :xdump)
+
+(defvar *current-parser* nil)
+
+(defclass table-column-meta ()
+  ((name :accessor meta-name)
+   (type :accessor meta-type)
+   (flags :accessor meta-flags)
+   (len :accessor meta-len)
+   (table :accessor meta-table)))
+
+(defclass xdump-table ()
+  ((name :accessor table-name :initarg :name)
+   (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))))
+
+;(defclass empire-table ()
+;  (()))
+
+(defvar *meta-by-index* (make-array 50 :adjustable t :initial-element nil))
+(defvar *table-by-index* (make-array 50 :adjustable t :initial-element nil))
+(defvar *index-by-name* (make-hash-table :size 50 :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-entry (table-name index)
+  (let* ((table-index (gethash table-name *index-by-name*))
+        (table (aref *table-by-index* table-index)))
+    (aref (table-entries 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-index :accessor entry-index :initform 0)
+   (finalizer :accessor finalizer :initform nil)
+   (name :accessor table-name :initform nil)
+   (timestamp :accessor timestamp :initform nil)))
+
+(defgeneric finish-table (xdump-parser number-of-records))
+(defgeneric parse-entry (xdump-parser line))
+(defgeneric parse-meta (xdump-parser name timestamp))
+(defgeneric parse-table (xdump-parser name timestamp))
+(defgeneric header-parser (xdump-parser line))
+(defgeneric parse-line (xdump-parser line))
+
+(defun meta-meta-finalizer (parser)
+  (with-slots (entry-buffer) 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)))
+                                       ; 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*
+              for field in entry
+              do (setf (slot-value meta-meta slot) field))
+           (setf (aref *meta-meta* i) meta-meta)))))
+
+(defun meta-finalizer (parser)
+  (let ((meta-table (make-array 1 :fill-pointer 0 :adjustable t)))
+    (with-slots (entry-buffer name) parser
+      (loop for entry across entry-buffer
+        do (let ((meta (make-instance 'table-column-meta)))
+             (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
+                            (elt (aref entry-buffer 0) 4)
+                            (gethash name *index-by-name*))))
+       (setf (aref *meta-by-index* table-index) meta-table)
+
+       ;; create xdump-table instance and entry class
+       (let* ((class-name (string-upcase (format nil "~a-table-entry" name)))
+              (package (find-package "XDUMP-DATA"))
+              (table-instance (make-instance 'xdump-table
+                                             :name name
+                                             :index table-index
+                                             :entry-class (intern class-name package)))
+              (slot-list (loop for entry across entry-buffer
+                            collect (car entry))))
+         (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))))))))
+
+(defun table-finalizer (parser)
+  (with-slots (entry-buffer name timestamp) 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))))
+    (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)))
+      (loop for entry across entry-buffer do
+          (let ((e (make-instance (table-entry-class table)))
+                (index (first entry))
+                (entries (table-entries table)))
+            ; extend array if necessary
+            (unless (> (fill-pointer entries) index)
+              (adjust-array entries (* 2 index) :fill-pointer t))
+            (setf (aref entries index) e)
+            (loop
+               for item in entry
+               for column across meta-table do
+                 (setf (slot-value e (find-symbol (string-upcase (meta-name column)) (find-package "XDUMP-DATA"))) item))))
+      (setf (table-last-update table) timestamp))))
+
+(defmethod finish-table ((parser xdump-parser) number-of-records)
+  (if (not (equal number-of-records (length (entry-buffer parser))))
+      (error "Table row count mismatch"))
+  (funcall (finalizer parser) parser)
+  t) ;; finished
+
+(defmethod parse-entry ((parser xdump-parser) line)
+  (if (char= #\/ (aref line 0))
+      (finish-table parser (parse-integer (subseq line 1)))
+      (let ((fields (mapcar #'read-from-string (cl-ppcre:split " " line))))
+       (with-slots (entry-buffer entry-index) parser
+         (vector-push-extend fields entry-buffer)
+         (incf entry-index))
+       nil)))
+
+(defmethod parse-meta ((parser xdump-parser) input-name input-timestamp)
+  (with-slots (line-parser finalizer name timestamp) parser
+    (setf line-parser #'parse-entry
+         finalizer (if (string= "meta" input-name)
+                       #'meta-meta-finalizer
+                       #'meta-finalizer)
+         name input-name
+         timestamp input-timestamp)))
+
+(defmethod parse-table ((parser xdump-parser) input-name input-timestamp)
+  (with-slots (line-parser finalizer name timestamp) parser
+    (setf line-parser #'parse-entry
+         finalizer #'table-finalizer
+         name input-name
+         timestamp input-timestamp)))
+
+(defmethod header-parser ((parser xdump-parser) line)
+  (multiple-value-bind (fullmatch groups)
+      (cl-ppcre:scan-to-strings "^XDUMP meta (.*) ([0-9]+)$" line)
+    (if fullmatch
+       ;; meta table
+       (let ((name (aref groups 0))
+             (timestamp (parse-integer (aref groups 1))))
+         (parse-meta parser name timestamp))
+       ;; table
+       (multiple-value-bind (fullmatch groups)
+           (cl-ppcre:scan-to-strings "^XDUMP (.*) ([0-9]+)$" line)
+         (declare (ignorable fullmatch))
+         (let ((name (aref groups 0))
+               (timestamp (parse-integer (aref groups 1))))
+           (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))))
+
+(defun test-parse (filename)
+  (with-open-file (s filename)
+    (parse s)))
+
+(defun t1 ()
+  (test-parse "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"))