bknr-cvs July 2008

bknr-cvs@common-lisp.net

1 participants
321 discussions

[bknr-cvs] hans changed branches/anon-transaction-fixes/
by BKNR Commits 30 Jul '08

30 Jul '08

Revision: 3693 Author: hans URL: http://bknr.net/trac/changeset/3693 New branch to get anonymous transactions sorted out properly. A branches/anon-transaction-fixes/ Copied: branches/anon-transaction-fixes (from rev 3692, trunk)

1 0

[bknr-cvs] ksprotte changed trunk/bknr/datastore/src/data/object-tests.lisp
by BKNR Commits 30 Jul '08

30 Jul '08

Revision: 3692 Author: ksprotte URL: http://bknr.net/trac/changeset/3692 added two datastore core tests: :make-instance-in-anon-txn, :make-object-in-anon-txn U trunk/bknr/datastore/src/data/object-tests.lisp Modified: trunk/bknr/datastore/src/data/object-tests.lisp =================================================================== --- trunk/bknr/datastore/src/data/object-tests.lisp 2008-07-30 10:11:48 UTC (rev 3691) +++ trunk/bknr/datastore/src/data/object-tests.lisp 2008-07-30 10:12:22 UTC (rev 3692) @@ -47,7 +47,7 @@ (defvar *tests* (make-hash-table)) -(defmacro define-datastore-test (name &rest body) +(defmacro define-datastore-test (name &body body) `(setf (gethash ,name *tests*) (make-instance 'datastore-test-class :unit :datastore @@ -118,6 +118,14 @@ (map-store-objects #'delete-object))) (test-equal (all-store-objects) nil)) +(define-datastore-test :make-instance-in-anon-txn + (with-transaction () + (make-instance 'store-object))) + +(define-datastore-test :make-object-in-anon-txn + (with-transaction () + (make-object 'store-object))) + (define-persistent-class parent () ((child :update :initform nil)))

1 0

[bknr-cvs] hans changed trunk/bknr/datastore/src/data/object.lisp
by BKNR Commits 30 Jul '08

30 Jul '08

Revision: 3691 Author: hans URL: http://bknr.net/trac/changeset/3691 Don't try to log changes to ID slot. U trunk/bknr/datastore/src/data/object.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-30 09:42:58 UTC (rev 3690) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-30 10:11:48 UTC (rev 3691) @@ -91,7 +91,7 @@ slot-name object)) (when (and (persistent-slot-p slotd) (not (eq :restore (store-state *store*))) - (not (eq 'last-change slot-name))) + (not (member slot-name '(last-change id)))) (setf (slot-value object 'last-change) (current-transaction-timestamp))))) (defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd)

1 0

[bknr-cvs] hans changed trunk/bknr/datastore/src/data/object.lisp
by BKNR Commits 30 Jul '08

30 Jul '08

Revision: 3690 Author: hans URL: http://bknr.net/trac/changeset/3690 More changes relating to ALLOCATE-INSTANCE. U trunk/bknr/datastore/src/data/object.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-30 09:36:20 UTC (rev 3689) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-30 09:42:58 UTC (rev 3690) @@ -454,9 +454,10 @@ ;; If the class is NIL, it was not found in the currently ;; running Lisp image and objects of this class will be ignored. (when class + (setf (next-object-id (store-object-subsystem)) object-id) (let ((object (allocate-instance class))) + (assert (= object-id (slot-value object 'id))) (dolist (index (class-slot-indices class 'id)) - (assert (= object-id (slot-value object 'id))) (index-add index object))))))) (defun snapshot-read-slots (stream layouts) @@ -641,12 +642,14 @@ (defun make-object (class-name &rest initargs) "Make a persistent object of class named CLASS-NAME. Calls MAKE-INSTANCE with INITARGS." - (with-store-guard () - (execute (make-instance 'transaction - :function-symbol 'tx-make-object - :args (append (list class-name - :id (next-object-id (store-object-subsystem))) - initargs))))) + (if (in-anonymous-transaction-p) + (apply #'make-instance class-name initargs) + (with-store-guard () + (execute (make-instance 'transaction + :function-symbol 'tx-make-object + :args (append (list class-name + :id (next-object-id (store-object-subsystem))) + initargs)))))) (defun tx-delete-object (id) (destroy-object (store-object-with-id id)))

1 0

[bknr-cvs] hans changed trunk/
by BKNR Commits 30 Jul '08

30 Jul '08

Revision: 3689 Author: hans URL: http://bknr.net/trac/changeset/3689 Remove INITIALIZE-PERSISTENT-INSTANCE, use INITIALIZE-INSTANCE instead. During restore, use ALLOCATE-INSTANCE to reinstantiate persistent objects. U trunk/bknr/datastore/src/data/object.lisp U trunk/bknr/datastore/src/data/package.lisp U trunk/bknr/datastore/src/data/tutorial.lisp U trunk/bknr/modules/feed/feed.lisp U trunk/bknr/modules/text/article.lisp U trunk/bknr/web/src/rss/rss.lisp U trunk/bknr/web/src/sysclasses/user.lisp U trunk/projects/bos/m2/allocation.lisp U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/poi.lisp U trunk/projects/lisp-ecoop/src/participant.lisp U trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp U trunk/projects/unmaintained/raw-data/mcp/sensors.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-30 08:42:31 UTC (rev 3688) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-30 09:36:20 UTC (rev 3689) @@ -190,36 +190,32 @@ #+allegro (aclmop::finalize-inheritance (find-class 'store-object)) -(defmethod initialize-instance :around - ((object store-object) &key &allow-other-keys) +(defmethod initialize-instance :around ((object store-object) &rest initargs &key) (if (in-anonymous-transaction-p) (prog1 (call-next-method) (encode (make-instance 'transaction :function-symbol 'make-instance :timestamp (get-universal-time) - :args (cons (class-name (class-of object)) - (loop for slotd in (class-slots (class-of object)) - for slot-name = (slot-definition-name slotd) - for slot-initarg = (first (slot-definition-initargs slotd)) - when (and slot-initarg - (slot-boundp object slot-name)) - appending (list slot-initarg (slot-value object slot-name))))) + :args (cons (class-name (class-of object)) initargs)) (anonymous-transaction-log-buffer *current-transaction*))) (call-next-method))) -(defmethod initialize-instance :after ((object store-object) &key id &allow-other-keys) - (let ((subsystem (store-object-subsystem))) - (cond (id - ;; during restore, use the given ID - (when (>= id (next-object-id subsystem)) - (setf (next-object-id subsystem) (1+ id)))) - (t - ;; normal transaction: assign a new ID - (setf id (next-object-id subsystem)) - (incf (next-object-id subsystem)) - (setf (slot-value object 'id) id))))) +(defmethod allocate-instance :around ((class persistent-class) &key) + (let* ((object (call-next-method)) + (subsystem (store-object-subsystem)) + (id (next-object-id subsystem))) + (incf (next-object-id subsystem)) + (setf (slot-value object 'id) id) + object)) +(defmethod initialize-instance :after ((object store-object) &key) + ;; This is called only when initially creating the (persistent) + ;; instance, not during restore. During restore, the + ;; INITIALIZE-TRANSIENT-INSTANCE function is called after the + ;; snapshot has been read, but before running the transaction log. + (initialize-transient-instance object)) + (defmethod print-object ((object store-object) stream) (print-unreadable-object (object stream :type t) (format stream "ID: ~D" (store-object-id object)))) @@ -244,19 +240,13 @@ :timestamp (get-universal-time) :args (append (list object (if (symbolp class) class (class-name class))) args)))) -(defgeneric initialize-persistent-instance (store-object &key &allow-other-keys) - (:documentation - "Initializes the persistent aspects of a persistent object. This -method is called at the creation of a persistent object, but not when -the object is loaded from a snapshot.")) - (defgeneric initialize-transient-instance (store-object) (:documentation "Initializes the transient aspects of a persistent object. This -method is called whenever a persistent object is initialized, also -when the object is loaded from a snapshot.")) +method is called after a persistent object has been initialized, also +when the object is loaded from a snapshot, but before reading the +transaction log.")) -(defmethod initialize-persistent-instance ((object store-object) &key)) (defmethod initialize-transient-instance ((object store-object))) (defmethod store-object-persistent-slots ((object store-object)) @@ -464,7 +454,10 @@ ;; If the class is NIL, it was not found in the currently ;; running Lisp image and objects of this class will be ignored. (when class - (make-instance class :id object-id))))) + (let ((object (allocate-instance class))) + (dolist (index (class-slot-indices class 'id)) + (assert (= object-id (slot-value object 'id))) + (index-add index object))))))) (defun snapshot-read-slots (stream layouts) (let* ((layout-id (%decode-integer stream)) @@ -641,15 +634,13 @@ (if restoring (remove-transient-slot-initargs (find-class class-name) initargs) initargs))) - (apply #'initialize-persistent-instance obj initargs) - (initialize-transient-instance obj) (setf error nil) obj) (when (and error obj) (destroy-object obj))))) (defun make-object (class-name &rest initargs) - "Make a persistent object of class named CLASS-NAME. Calls MAKE-INSTANCE with INITARGS." + "Make a persistent object of class named CLASS-NAME. Calls MAKE-INSTANCE with INITARGS." (with-store-guard () (execute (make-instance 'transaction :function-symbol 'tx-make-object Modified: trunk/bknr/datastore/src/data/package.lisp =================================================================== --- trunk/bknr/datastore/src/data/package.lisp 2008-07-30 08:42:31 UTC (rev 3688) +++ trunk/bknr/datastore/src/data/package.lisp 2008-07-30 09:36:20 UTC (rev 3689) @@ -51,7 +51,6 @@ #:cascade-delete-p #:cascading-delete-object - #:initialize-persistent-instance #:initialize-transient-instance #:store-object-with-id Modified: trunk/bknr/datastore/src/data/tutorial.lisp =================================================================== --- trunk/bknr/datastore/src/data/tutorial.lisp 2008-07-30 08:42:31 UTC (rev 3688) +++ trunk/bknr/datastore/src/data/tutorial.lisp 2008-07-30 09:36:20 UTC (rev 3689) @@ -458,14 +458,13 @@ ;;; Persistent objects have the metaclass `PERSISTENT-CLASS', and have ;;; to be created using the function `MAKE-OBJECT'. This creates an ;;; instance of the object inside a transaction, sets its ID slot -;;; appropriately, and then calls `INITIALIZE-PERSISTENT-INSTANCE' and -;;; `INITIALIZE-TRANSIENT-INSTANCE'. The first method is called when -;;; the object is created inside a transaction, but not if the object -;;; is being restored from the snapshot file. This method has to be -;;; overridden in order to initialize persistent -;;; slots. `INITIALIZE-TRANSIENT-INSTANCE' is called at object -;;; creation inside a transaction and at object creation during -;;; restore. It is used to initialize the transient slots (not logged +;;; appropriately, and then calls `INITIALIZE-TRANSIENT-INSTANCE'. The +;;; standard CLOS function `INITIALIZE-INSTANCE' is called when the +;;; object is created inside a transaction, but not if the object is +;;; being restored from the snapshot file. +;;; `INITIALIZE-TRANSIENT-INSTANCE' is called at object creation +;;; inside a transaction and at object creation during restore. It +;;; must be specialized to initialize the transient slots (not logged ;;; to the snapshot file) of a persistent object. ;;; ;;; We can define the following class with a transient and a @@ -816,9 +815,7 @@ ;;; resolved (check the section about relaxed references). Finally, ;;; after each slot value has been set, the method ;;; `INITIALIZE-TRANSIENT-INSTANCE' is called for each created -;;; object. The method `INITIALIZE-PERSISTENT-INSTANCE' is not called, -;;; as it has to be executed only once at the time the persistent -;;; object is created. +;;; object. ;;;## Garbage collecting blobs Modified: trunk/bknr/modules/feed/feed.lisp =================================================================== --- trunk/bknr/modules/feed/feed.lisp 2008-07-30 08:42:31 UTC (rev 3688) +++ trunk/bknr/modules/feed/feed.lisp 2008-07-30 09:36:20 UTC (rev 3689) @@ -24,9 +24,6 @@ (type :update :documentation "(or :rss091 :rss10 :rss20 :atom)") (encoding :update :initform :iso-8859-1 :documentation "(or :utf8 :iso-8859-1)"))) -;(defmethod initialize-transient-instance ((feed feed)) -; (ignore-errors (update-feed feed))) - (defmethod print-object ((object feed) stream) (format stream "#<~a ID: ~A \"~a\">" (class-name (class-of object)) Modified: trunk/bknr/modules/text/article.lisp =================================================================== --- trunk/bknr/modules/text/article.lisp 2008-07-30 08:42:31 UTC (rev 3688) +++ trunk/bknr/modules/text/article.lisp 2008-07-30 09:36:20 UTC (rev 3689) @@ -36,7 +36,7 @@ (article-subject article) " " (article-text article)))) -(defmethod initialize-persistent-instance :after ((article article) &key) +(defmethod initialize-instance :after ((article article) &key) (setf (article-search-vector article) (article-to-search-vector article))) Modified: trunk/bknr/web/src/rss/rss.lisp =================================================================== --- trunk/bknr/web/src/rss/rss.lisp 2008-07-30 08:42:31 UTC (rev 3688) +++ trunk/bknr/web/src/rss/rss.lisp 2008-07-30 09:36:20 UTC (rev 3689) @@ -176,7 +176,7 @@ (:method ((channel (eql nil)) item) (warn "no RSS channel defined for item ~A" item))) -(defmethod initialize-persistent-instance :after ((rss-item rss-item) &key) +(defmethod initialize-instance :after ((rss-item rss-item) &key) (add-item (rss-item-channel rss-item) rss-item)) (defmethod destroy-object :before ((rss-item rss-item)) Modified: trunk/bknr/web/src/sysclasses/user.lisp =================================================================== --- trunk/bknr/web/src/sysclasses/user.lisp 2008-07-30 08:42:31 UTC (rev 3688) +++ trunk/bknr/web/src/sysclasses/user.lisp 2008-07-30 09:36:20 UTC (rev 3689) @@ -60,7 +60,7 @@ (user-login object) "unbound")))) -(defmethod initialize-persistent-instance ((user user) &key) +(defmethod initialize-instance ((user user) &key) (let* ((plaintext-password (slot-value user 'password)) (password (when plaintext-password (crypt-md5 plaintext-password (make-salt))))) (setf (slot-value user 'password) password))) @@ -72,7 +72,7 @@ (define-persistent-class smb-user (user) ()) -(defmethod initialize-persistent-instance ((user smb-user) &key) +(defmethod initialize-instance ((user smb-user) &key) (let* ((plaintext-password (slot-value user 'password))) (when plaintext-password (set-smb-password (user-login user) plaintext-password)) Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-30 08:42:31 UTC (rev 3688) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-30 09:36:20 UTC (rev 3689) @@ -34,7 +34,7 @@ :unbound) (store-object-id allocation-area)))) -(defmethod initialize-persistent-instance :after ((allocation-area allocation-area) &key) +(defmethod initialize-instance :after ((allocation-area allocation-area) &key) (with-slots (total-m2s free-m2s) allocation-area (setf total-m2s (calculate-total-m2-count allocation-area)) (setf free-m2s (- total-m2s (calculate-allocated-m2-count allocation-area)))) Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-30 08:42:31 UTC (rev 3688) +++ trunk/projects/bos/m2/m2.lisp 2008-07-30 09:36:20 UTC (rev 3689) @@ -278,7 +278,7 @@ (defun contract-p (object) (equal (class-of object) (find-class 'contract))) -(defmethod initialize-persistent-instance :after ((contract contract) &key) +(defmethod initialize-instance :after ((contract contract) &key) (pushnew contract (sponsor-contracts (contract-sponsor contract))) (dolist (m2 (contract-m2s contract)) (setf (m2-contract m2) contract)) Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-30 08:42:31 UTC (rev 3688) +++ trunk/projects/bos/m2/poi.lisp 2008-07-30 09:36:20 UTC (rev 3689) @@ -35,7 +35,7 @@ or description is given") (apply #'make-object class-name rest)) -(defmethod initialize-persistent-instance :after ((poi-medium poi-medium) &key language title subtitle description poi) +(defmethod initialize-instance :after ((poi-medium poi-medium) &key language title subtitle description poi) (when poi (push poi-medium (poi-media poi))) (update-textual-attributes poi-medium language @@ -84,7 +84,7 @@ (setf (slot-string poi 'description language) description) poi)) -(defmethod initialize-persistent-instance :after ((poi poi) &key language title subtitle description) +(defmethod initialize-instance :after ((poi poi) &key language title subtitle description) (update-textual-attributes poi language :title title :subtitle subtitle Modified: trunk/projects/lisp-ecoop/src/participant.lisp =================================================================== --- trunk/projects/lisp-ecoop/src/participant.lisp 2008-07-30 08:42:31 UTC (rev 3688) +++ trunk/projects/lisp-ecoop/src/participant.lisp 2008-07-30 09:36:20 UTC (rev 3689) @@ -7,7 +7,7 @@ (submission :read :documentation "Submission that this document belongs to")) (:default-initargs :type "application/pdf" :submission (error ":submission argument missing while creating document"))) -(defmethod initialize-persistent-instance :after ((document document) &key) +(defmethod initialize-instance :after ((document document) &key) (with-slots (submission) document (push document (submission-documents submission)))) @@ -92,7 +92,7 @@ #'(lambda (&rest more) (apply fun (append args more)))) -(defmethod initialize-persistent-instance :after ((participant participant) &key) +(defmethod initialize-instance :after ((participant participant) &key) (make-email-list)) (defun make-email-list () Modified: trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp =================================================================== --- trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp 2008-07-30 08:42:31 UTC (rev 3688) +++ trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp 2008-07-30 09:36:20 UTC (rev 3689) @@ -88,7 +88,7 @@ ((device :initarg :device :reader bluetooth-event-device)) (:metaclass persistent-class)) -(defmethod initialize-persistent-instance :after ((event bluetooth-event) &key) +(defmethod initialize-instance :after ((event bluetooth-event) &key) (with-slots (device) event (push event (bluetooth-device-events device)) (setf (sample-event-value event) (or (bluetooth-device-name device) (bluetooth-device-mac-address device))))) Modified: trunk/projects/unmaintained/raw-data/mcp/sensors.lisp =================================================================== --- trunk/projects/unmaintained/raw-data/mcp/sensors.lisp 2008-07-30 08:42:31 UTC (rev 3688) +++ trunk/projects/unmaintained/raw-data/mcp/sensors.lisp 2008-07-30 09:36:20 UTC (rev 3689) @@ -60,7 +60,7 @@ (defmethod sample-event-table-name ((sensor sensor)) (format nil "sample_event_~(~A~)" (sensor-type sensor))) -(defmethod initialize-persistent-instance :after ((sensor sensor) &key) +(defmethod initialize-instance :after ((sensor sensor) &key) (let ((id (store-object-id sensor))) (with-slots (name unit type) sensor (postgres-execute

1 0

[bknr-cvs] ksprotte changed trunk/build.lisp
by BKNR Commits 30 Jul '08

30 Jul '08

Revision: 3688 Author: ksprotte URL: http://bknr.net/trac/changeset/3688 removed again print-object hack for testing - sorry for the noise U trunk/build.lisp Modified: trunk/build.lisp =================================================================== --- trunk/build.lisp 2008-07-30 08:31:31 UTC (rev 3687) +++ trunk/build.lisp 2008-07-30 08:42:31 UTC (rev 3688) @@ -191,11 +191,7 @@ (zerop (nth-value 8 (5am::partition-results results))))) (defun test () - (cl-gd::load-gd-glue) - (eval '(defmethod print-object :around ((object t) stream) - (handler-case - (call-next-method) - (error (c) (print-unreadable-object (object stream :type t :identity t)))))) + (cl-gd::load-gd-glue) (format t "~&;;; --- running tests~%") (run-tests #+(or)

1 0

[bknr-cvs] ksprotte changed trunk/build.lisp
by BKNR Commits 30 Jul '08

30 Jul '08

Revision: 3687 Author: ksprotte URL: http://bknr.net/trac/changeset/3687 again a commit to avoid printer errors when testing U trunk/build.lisp Modified: trunk/build.lisp =================================================================== --- trunk/build.lisp 2008-07-30 08:20:42 UTC (rev 3686) +++ trunk/build.lisp 2008-07-30 08:31:31 UTC (rev 3687) @@ -193,7 +193,9 @@ (defun test () (cl-gd::load-gd-glue) (eval '(defmethod print-object :around ((object t) stream) - (print-unreadable-object (object stream :type t :identity t)))) + (handler-case + (call-next-method) + (error (c) (print-unreadable-object (object stream :type t :identity t)))))) (format t "~&;;; --- running tests~%") (run-tests #+(or)

1 0

[bknr-cvs] ksprotte changed trunk/build.lisp
by BKNR Commits 30 Jul '08

30 Jul '08

Revision: 3686 Author: ksprotte URL: http://bknr.net/trac/changeset/3686 oops - "typo" in last patch U trunk/build.lisp Modified: trunk/build.lisp =================================================================== --- trunk/build.lisp 2008-07-30 08:11:13 UTC (rev 3685) +++ trunk/build.lisp 2008-07-30 08:20:42 UTC (rev 3686) @@ -192,9 +192,8 @@ (defun test () (cl-gd::load-gd-glue) - (compile - (eval '(defmethod print-object :around ((object t) stream) - (print-unreadable-object (object stream :type t :identity t))))) + (eval '(defmethod print-object :around ((object t) stream) + (print-unreadable-object (object stream :type t :identity t)))) (format t "~&;;; --- running tests~%") (run-tests #+(or)

1 0

[bknr-cvs] ksprotte changed trunk/build.lisp
by BKNR Commits 30 Jul '08

30 Jul '08

Revision: 3685 Author: ksprotte URL: http://bknr.net/trac/changeset/3685 when running tests override print-object, so that any object can be printed without error U trunk/build.lisp Modified: trunk/build.lisp =================================================================== --- trunk/build.lisp 2008-07-30 06:29:44 UTC (rev 3684) +++ trunk/build.lisp 2008-07-30 08:11:13 UTC (rev 3685) @@ -192,20 +192,23 @@ (defun test () (cl-gd::load-gd-glue) + (compile + (eval '(defmethod print-object :around ((object t) stream) + (print-unreadable-object (object stream :type t :identity t))))) (format t "~&;;; --- running tests~%") (run-tests - #+(or) - (cl-ppcre-run-no-failures-p) - (cl-gd-run-no-failures-p) - #+(or) - (flexi-streams-no-failures-p) - (unit-test:run-all-tests) - (rt:do-tests) - (fiveam-run-no-failures-p :bknr.datastore) - #-darwin (fiveam-run-no-failures-p :bos.test) - (progn #+(or) (fiveam-run-no-failures-p :it.bese.FiveAM) - (warn "skipping :it.bese.FiveAM tests") - t) - (fiveam-run-no-failures-p 'json-test::json) - )) + #+(or) + (cl-ppcre-run-no-failures-p) + (cl-gd-run-no-failures-p) + #+(or) + (flexi-streams-no-failures-p) + (unit-test:run-all-tests) + (rt:do-tests) + (fiveam-run-no-failures-p :bknr.datastore) + #-darwin (fiveam-run-no-failures-p :bos.test) + (progn #+(or) (fiveam-run-no-failures-p :it.bese.FiveAM) + (warn "skipping :it.bese.FiveAM tests") + t) + (fiveam-run-no-failures-p 'json-test::json) + ))

1 0

[bknr-cvs] hans changed trunk/bknr/datastore/src/
by BKNR Commits 30 Jul '08

30 Jul '08

Revision: 3684 Author: hans URL: http://bknr.net/trac/changeset/3684 Add JSON serialization method for store objects from scrabble project. U trunk/bknr/datastore/src/bknr.datastore.asd A trunk/bknr/datastore/src/data/json.lisp U trunk/bknr/datastore/src/data/package.lisp Modified: trunk/bknr/datastore/src/bknr.datastore.asd =================================================================== --- trunk/bknr/datastore/src/bknr.datastore.asd 2008-07-29 22:25:41 UTC (rev 3683) +++ trunk/bknr/datastore/src/bknr.datastore.asd 2008-07-30 06:29:44 UTC (rev 3684) @@ -22,12 +22,14 @@ :unit-test :bknr.utils :bknr.indices - :trivial-utf-8) + :trivial-utf-8 + :cl-json) :components ((:module "data" :components ((:file "package") (:file "encoding" :depends-on ("package")) (:file "txn" :depends-on ("encoding" "package")) (:file "object" :depends-on ("txn" "package")) + (:file "json" :depends-on ("object")) (:file "blob" :depends-on ("txn" "object" "package")))))) (defsystem :bknr.datastore.test Added: trunk/bknr/datastore/src/data/json.lisp =================================================================== --- trunk/bknr/datastore/src/data/json.lisp (rev 0) +++ trunk/bknr/datastore/src/data/json.lisp 2008-07-30 06:29:44 UTC (rev 3684) @@ -0,0 +1,22 @@ +(in-package :bknr.datastore) + +(defparameter *ignore-slots* '(bknr.datastore::id bknr.indices::destroyed-p)) + +(defmacro with-json-ignore-slots ((&rest slots) &body body) + `(let ((*ignore-slots* (append *ignore-slots* ,slots))) + ,@body)) + +(defmethod json:encode-json ((object store-object) stream) + (let (printed) + (princ #\{ stream) + (dolist (slotdef (closer-mop:class-slots (class-of object))) + (when (and (slot-boundp object (closer-mop:slot-definition-name slotdef)) + (not (find (closer-mop:slot-definition-name slotdef) *ignore-slots*))) + (if printed + (princ #\, stream) + (setf printed t)) + (json:encode-json (closer-mop:slot-definition-name slotdef) stream) + (princ #\: stream) + (json:encode-json (slot-value object (closer-mop:slot-definition-name slotdef)) stream))) + (princ #\} stream))) + Modified: trunk/bknr/datastore/src/data/package.lisp =================================================================== --- trunk/bknr/datastore/src/data/package.lisp 2008-07-29 22:25:41 UTC (rev 3683) +++ trunk/bknr/datastore/src/data/package.lisp 2008-07-30 06:29:44 UTC (rev 3684) @@ -116,6 +116,9 @@ #:initialize-subsystem #:snapshot-subsystem #:restore-subsystem - #:ensure-store-current-directory)) + #:ensure-store-current-directory + ;; JSON serialization + #:with-json-ignore-slots)) +

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

bknr-cvs July 2008