From: Gerd Flaig Date: Sat, 29 Aug 2009 23:28:45 +0000 (+0200) Subject: Start integration of xdump with protocol X-Git-Url: http://git.pond.sub.org/?p=eow;a=commitdiff_plain;h=7964c4eff78de2fcca3c0b79161fa1f4cf626690;ds=sidebyside Start integration of xdump with protocol --- diff --git a/empire.lisp b/empire.lisp index 2f3452e..c8993e8 100644 --- a/empire.lisp +++ b/empire.lisp @@ -303,20 +303,22 @@ (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 587b648..2c8ded1 100644 --- 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)) diff --git a/package.lisp b/package.lisp index 64ff316..5459b50 100644 --- a/package.lisp +++ b/package.lisp @@ -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 index 928748c..0000000 --- a/xdump-test.lisp +++ /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 index 0000000..c2f866e --- /dev/null +++ b/xdump.lisp @@ -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"))