From: Gerd Flaig Date: Sat, 12 Feb 2011 11:58:50 +0000 (+0100) Subject: Array dump support. Create access function package xdump-data. X-Git-Url: http://git.pond.sub.org/?p=eow;a=commitdiff_plain;h=debbb67bcc0276b5e9793824c4240e3dd5ba83ea;hp=702b7b803394d5db770b4137bd1d3698d632b227 Array dump support. Create access function package xdump-data. --- diff --git a/empire.lisp b/empire.lisp index 8a1689b..7ac17d4 100644 --- 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 1685fab..e4c8947 100644 --- 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 d3e9d3b..1eafd00 100644 --- 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 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 3114323..dd878ee 100644 --- 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))