Array dump support. Create access function package xdump-data.

diff --git a/empire.lisp b/empire.lisp
index 8a1689be7899a089754b8eb98127cd2f2b4bab94..7ac17d498cb742fa7857f912341bc389cb9d882b 100644 (file)
--- a/empire.lisp
+++ b/empire.lisp
@@ -9,6 +9,8 @@
 (defvar *default-empire-server* "localhost")
 (defvar *default-empire-server-port* 6665)
 
+(defvar *last-active-connection* nil)
+
 (defclass connection ()
   ((user
     :initarg :user
@@ -268,6 +270,7 @@
       (let* ((s (network-stream c))
             (line (read-line s)))
        (empire-log:info "~a: < ~a" c line)
+       (setf *last-active-connection* c)
        (multiple-value-bind (message type) (parse-server-line line)
          (let ((handler (lookup-handler type))
                (mode (connection-mode c)))
@@ -287,6 +290,7 @@
 (defgeneric send-message-one (connection string))
 (defmethod send-message-one ((c connection) message)
   (empire-log:info "~a: > ~a" c message)
+  (setf *last-active-connection* c)
   (let ((s (network-stream c)))
     (raw-send-message s message)))
 
@@ -310,38 +314,47 @@
 
 (defmethod handle-data ((m xdump-mode) message)
   (with-slots (connection phase dump-queue dump-index) m
-    (if (xdump:parse-line (xdump connection) message)
-       ;;XXX consider something like a 'pop-mode function
-       (ccase phase
-         (:meta-meta 
-          (setf phase :meta-table)
-          (send-message connection "xdump meta table"))
-         (:meta-table
-          (setf phase :table-table)
-          (send-message connection "xdump table *"))
-         (:table-table
-          (setf phase :tables-meta
-                dump-queue (xdump::table-entries (xdump::get-table "table"))
-                dump-index 0)
-          (send-message connection (format nil "xdump meta ~a" (xdump-data::table-name (aref dump-queue 0)))))
-         (:tables-meta
-          (setf phase :tables-content)
-          (send-message connection (format nil "xdump ~a *" (xdump-data::table-name (aref dump-queue dump-index)))))
-         (:tables-content
-          (if (< dump-index (fill-pointer dump-queue))
-              (progn (setf phase :tables-meta)
-                     (incf dump-index)
-                     (loop while (and (< dump-index (fill-pointer dump-queue))
-                                      (let ((dump-queue-entry (aref dump-queue dump-index)))
-                                        (or (null dump-queue-entry)
-                                            (string= "meta" (xdump-data::table-name dump-queue-entry)))))
-                        do (incf dump-index))
-                     (if (and (<= dump-index (fill-pointer dump-queue))
-                              (not (null (aref dump-queue dump-index))))
-                         (send-message connection (format nil "xdump meta ~a" (xdump-data::table-name (aref dump-queue dump-index))))))
-              (set-new-mode (connection-mode connection) 'play-mode)))))))
+    (xdump:with-parser (xdump connection)
+      (if (xdump:parse-line (xdump connection) message)
+         ;;XXX consider something like a 'pop-mode function
+         (ccase phase
+           (:meta-meta 
+            (setf phase :meta-table)
+            (send-message connection "xdump meta table"))
+           (:meta-table
+            (setf phase :table-table)
+            (send-message connection "xdump table *"))
+           (:table-table
+            (setf phase :meta-type)
+            (send-message connection "xdump meta meta-type"))
+           (:meta-type
+            (setf phase :type-table)
+            (send-message connection "xdump meta-type *"))
+           (:type-table
+            (setf phase :tables-meta
+                  dump-queue (xdump::table-entries (xdump:table "table"))
+                  dump-index 0)
+            (send-message connection (format nil "xdump meta ~a" (xdump-data:name (aref dump-queue 0)))))
+           (:tables-meta
+            (setf phase :tables-content)
+            (send-message connection (format nil "xdump ~a *" (xdump-data:name (aref dump-queue dump-index)))))
+           (:tables-content
+            (if (< dump-index (fill-pointer dump-queue))
+                (progn (setf phase :tables-meta)
+                       (incf dump-index)
+                       (loop while (and (< dump-index (fill-pointer dump-queue))
+                                        (let ((dump-queue-entry (aref dump-queue dump-index)))
+                                          (or (null dump-queue-entry)
+                                              (string= "meta"
+                                                       (xdump-data:name dump-queue-entry)))))
+                          do (incf dump-index))
+                       (if (and (<= dump-index (fill-pointer dump-queue))
+                                (not (null (aref dump-queue dump-index))))
+                           (send-message connection (format nil "xdump meta ~a" (xdump-data:name (aref dump-queue dump-index))))))
+                (set-new-mode (connection-mode connection) 'play-mode))))))))
 
 (defmethod special-xup ((c connection))
+  (setf (xdump c) (xdump:make-parser))
   (send-message c "xdump meta meta" :next-mode 'xdump-mode))
 
 (defmethod special-command ((c connection) line)

diff --git a/eow.asd b/eow.asd
index 1685fab9a2885dffd791da28a647474cbf43d4d4..e4c89478111f7c60b3f59bd042b79186df2c5fec 100644 (file)
--- a/eow.asd
+++ b/eow.asd
@@ -30,6 +30,8 @@
                         :depends-on ("package"))
                  (:file "xdump"
                         :depends-on ("package"))
+                 (:file "xdump-data"
+                        :depends-on ("package" "xdump"))
                 (:file "log"
                         :depends-on ("package"))
                 (:file "web"

diff --git a/package.lisp b/package.lisp
index d3e9d3b308b242a594d6010d24854aa1a47ff339..1eafd00e322513ce45e268abeb8a00d44af08f4f 100644 (file)
--- a/package.lisp
+++ b/package.lisp
@@ -22,9 +22,10 @@
     (:use :cl)
     (:export :info))
   (defpackage :xdump-data
-    (:use :cl))
+    (:use :cl)
+    (:export :name))
   (defpackage :xdump
-    (:use :cl :xdump-data)
-    (:export :make-parser :parse-line :get-table :get-table-entry))
+    (:use :cl)
+    (:export :make-parser :with-parser :parse-line :table :get-table-entry))
   (defpackage :empire-tests
     (:use :cl :lift)))

diff --git a/xdump-data.lisp b/xdump-data.lisp
new file mode 100644 (file)
index 0000000..b4606f5
--- /dev/null
+++ b/xdump-data.lisp
@@ -0,0 +1,5 @@
+(in-package :xdump-data)
+
+(defun name (entry &optional (parser xdump::*current-parser*))
+  (with-slots (xdump::table-classes-package) parser
+    (slot-value entry (find-symbol "NAME" xdump::table-classes-package))))

diff --git a/xdump.lisp b/xdump.lisp
index 3114323a86bd0f40f29b532f89e0ec3ad9499575..dd878eed30efac5c50b1a01efe229171a026afd9 100644 (file)
--- a/xdump.lisp
+++ b/xdump.lisp
@@ -47,6 +47,7 @@
 (defgeneric get-table (xdump-parser table-name))
 (defgeneric get-table-entry (xdump-parser table-name index))
 (defgeneric sym-by-value (xdump-parser table-name value))
+(defgeneric array-p (xdump-parser column))
 (defgeneric finish-table (xdump-parser number-of-records))
 (defgeneric parse-entry (xdump-parser line))
 (defgeneric parse-meta (xdump-parser name timestamp))
@@ -54,6 +55,8 @@
 (defgeneric header-parser (xdump-parser line))
 (defgeneric parse-line (xdump-parser line))
 (defgeneric reset-table-parser (xdump-parser))
+(defgeneric entry-from-vector (xdump-parser class meta-table entry-vector
+                                           &key array-support-p))
 
 (defmethod get-table ((parser xdump-parser) table-name)
   (with-slots (index-by-name table-by-index) parser
@@ -61,6 +64,13 @@
           (table (aref table-by-index table-index)))
       table)))
 
+(defmacro with-parser (parser &body body)
+  `(let ((*current-parser* ,parser))
+     ,@body))
+
+(defun table (table-name &optional (parser *current-parser*))
+  (get-table parser table-name))
+
 (defmethod get-table-entry ((parser xdump-parser) table-name index)
     (aref (table-entries (get-table table-name)) index))
 
@@ -154,16 +164,31 @@
          (eval (table-entry-defclass-form name class-name package
                                           slot-list)))))))
 
-(defun entry-from-vector (class meta-table entry-vector table-classes-package)
-  (let ((new-entry (make-instance class))
-       (i 0))
-    (loop
-       for column across meta-table do
-        (let ((slot (find-symbol (string-upcase (meta-name column))
-                                 table-classes-package)))
-          (setf (slot-value new-entry slot) (nth i entry-vector))
-          (incf i)))
-    new-entry))
+(defmethod array-p ((parser xdump-parser) column)
+  (let ((column-len (meta-len column))
+       (column-type (sym-by-value parser "meta-type" (meta-type column))))
+    (and (> column-len 0)
+        (not (string= column-type "c")))))
+
+(defmethod entry-from-vector (parser class meta-table entry-vector
+                             &key (array-support-p t))
+  (with-slots (table-classes-package) parser
+    (let ((new-entry (make-instance class))
+         (entries entry-vector))
+      (loop
+        for column across meta-table do
+          (let ((slot (find-symbol (string-upcase (meta-name column))
+                                   table-classes-package)))
+            (if (and array-support-p (array-p parser column))
+                ;; then collect array
+                (let ((array nil))
+                  (dotimes (j (meta-len column))
+                    (push (pop entries) array))
+                  (setf (slot-value new-entry slot) array))
+                ;; else collect single entry
+                (progn
+                  (setf (slot-value new-entry slot) (pop entries))))))
+      new-entry)))
 
 (defmethod table-entry-insert-at ((table xdump-table) entry index)
                                        ; extend array if necessary
@@ -184,12 +209,16 @@
     (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)))
+          (has-uid-p (has-uid-p table))
+          (array-support-p (not (or (string= name "table")
+                                    (string= name "meta-type")))))
       (loop for entry across entry-buffer do
-          (let ((entry-instance (entry-from-vector (table-entry-class table)
+          (let ((entry-instance (entry-from-vector parser
+                                                   (table-entry-class table)
                                                    meta-table
                                                    entry
-                                                   table-classes-package)))
+                                                   :array-support-p
+                                                   array-support-p)))
             (if has-uid-p
                 (let ((index (first entry)))
                   (table-entry-insert-at table entry-instance index))