bknr-cvs

bknr-cvs@common-lisp.net

1964 discussions

[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

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

30 Jul '08

Revision: 3683 Author: hans URL: http://bknr.net/trac/changeset/3683 Checkpoint Quickhoney. Added archive to RSS feed class. U trunk/bknr/modules/text/blog.lisp U trunk/bknr/web/src/packages.lisp U trunk/bknr/web/src/rss/rss.lisp U trunk/projects/quickhoney/src/image.lisp U trunk/projects/quickhoney/src/packages.lisp A trunk/projects/quickhoney/src/twitter.lisp U trunk/projects/quickhoney/website/static/javascript.js U trunk/projects/quickhoney/website/static/styles.css U trunk/projects/quickhoney/website/templates/index.xml Modified: trunk/bknr/modules/text/blog.lisp =================================================================== --- trunk/bknr/modules/text/blog.lisp 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/bknr/modules/text/blog.lisp 2008-07-29 22:25:41 UTC (rev 3683) @@ -16,7 +16,7 @@ (articles :update :initform nil) (owners :update :initform nil))) -(defmethod rss-channel-items ((blog blog)) +(defmethod rss-channel-items ((blog blog) &key) (blog-articles blog)) (defmethod print-object ((object blog) stream) Modified: trunk/bknr/web/src/packages.lisp =================================================================== --- trunk/bknr/web/src/packages.lisp 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/bknr/web/src/packages.lisp 2008-07-29 22:25:41 UTC (rev 3683) @@ -33,6 +33,8 @@ #:rss-channel-image #:rss-channel-textinput #:rss-channel-items + #:rss-channel-archive + #:rss-channel-archived-months #:rss-channel-xml ;; item Modified: trunk/bknr/web/src/rss/rss.lisp =================================================================== --- trunk/bknr/web/src/rss/rss.lisp 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/bknr/web/src/rss/rss.lisp 2008-07-29 22:25:41 UTC (rev 3683) @@ -21,8 +21,10 @@ (path :update :initform nil) (description :update :initform nil) (last-update :update :initform (get-universal-time)) - (max-item-age :update :initform (* 4 7 24 60 60)) - (items :update :initform nil)) + (max-item-age :update + :initform 28 + :documentation "default maximum item age in days") + (items :none :initform nil)) (:documentation "RSS-CHANNEL models one rss channel. Items are added to a channel by deriving other persistent classes from the mixin class RSS-ITEM. When an object of such a derived class is created, it @@ -60,7 +62,8 @@ (defmethod prepare-for-snapshot ((channel rss-channel)) "When snapshotting, remove items from CHANNEL that are destroyed." - (setf (slot-value channel 'items) (remove-if #'object-destroyed-p (rss-channel-items channel)))) + (setf (slot-value channel 'items) + (remove-if #'object-destroyed-p (rss-channel-items channel)))) ;; Mixin for items @@ -108,16 +111,42 @@ (rss-channel-items channel))) (rss-item-xml item))))))) -(defgeneric rss-channel-items (channel) +(defun days-from-query-parameter () + (when (boundp 'hunchentoot:*request*) + (let ((days-string (bknr.web:query-param "days"))) + (when days-string + (parse-integer days-string))))) + +(defun rss-channel-archive (channel) + "Return the channel archive consisting of lists of lists ((MONTH YEAR) ITEM...)" + (group-on (rss-channel-items channel) + :test #'equal + :key (lambda (item) + (multiple-value-bind (seconds minutes hours day month year) + (decode-universal-time (rss-item-pub-date item)) + (declare (ignore seconds minutes hours day)) + (list month year))))) + +(defgeneric rss-channel-items (channel &key) (:documentation "Return all non-expired items in channel.") - (:method ((channel rss-channel)) - (let ((days (when (boundp 'hunchentoot:*request*) (bknr.web:query-param "days")))) - (let ((expiry-time (- (get-universal-time) (if days - (* 60 60 25 (parse-integer days)) - (rss-channel-max-item-age channel))))) - (remove-if (lambda (item) (or (object-destroyed-p item) - (< (rss-item-pub-date item) expiry-time))) - (slot-value channel 'items)))))) + (:method ((channel rss-channel) &key days month) + (cond + (month + (cdr (find month (rss-channel-archive channel) :test #'equal))) + (t + (let* ((days (or days + (days-from-query-parameter) + (rss-channel-max-item-age channel))) + (expiry-time (- (get-universal-time) (* 60 60 25 days)))) + (remove-if (lambda (item) (or (object-destroyed-p item) + (< (rss-item-pub-date item) expiry-time))) + (slot-value channel 'items))))))) + +(defgeneric rss-channel-archived-months (channel) + (:documentation "Return a list of lists (MONTH YEAR) for which the + CHANNEL has archived entries.") + (:method (channel) + (mapcar #'car (rss-channel-archive channel)))) (deftransaction rss-channel-cleanup (channel) "Remove expired items from the items list. Can be used to reduce Modified: trunk/projects/quickhoney/src/image.lisp =================================================================== --- trunk/projects/quickhoney/src/image.lisp 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/projects/quickhoney/src/image.lisp 2008-07-29 22:25:41 UTC (rev 3683) @@ -100,7 +100,7 @@ () (:metaclass persistent-class)) -(defmethod rss-channel-items ((channel quickhoney-rss-channel)) +(defmethod rss-channel-items ((channel quickhoney-rss-channel) &key) (remove-if (lambda (item) (and (typep item 'quickhoney-image) (quickhoney-image-explicit item))) Modified: trunk/projects/quickhoney/src/packages.lisp =================================================================== --- trunk/projects/quickhoney/src/packages.lisp 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/projects/quickhoney/src/packages.lisp 2008-07-29 22:25:41 UTC (rev 3683) @@ -63,4 +63,8 @@ #:response-error)) (defpackage :paypal-test - (:use :cl)) \ No newline at end of file + (:use :cl)) + +(defpackage :twitter + (:use :cl) + (:export #:update-status)) \ No newline at end of file Added: trunk/projects/quickhoney/src/twitter.lisp =================================================================== --- trunk/projects/quickhoney/src/twitter.lisp (rev 0) +++ trunk/projects/quickhoney/src/twitter.lisp 2008-07-29 22:25:41 UTC (rev 3683) @@ -0,0 +1,12 @@ +(in-package :twitter) + +(defparameter *authorization* '("QuickHoneyTest" "autotwitter") + "Authorization (USER PASSWORD) to use to identify to twitter") + +(defun update-status (status-string) + (babel:octets-to-string + (drakma:http-request "http://twitter.com/statuses/update.xml" + :method :post + :content (format nil "status=~A" status-string) + :content-type "application/x-www-form-urlencoded" + :basic-authorization *authorization*))) \ No newline at end of file Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/projects/quickhoney/website/static/javascript.js 2008-07-29 22:25:41 UTC (rev 3683) @@ -23,10 +23,6 @@ /* current colors */ -var foreground_color = '000000'; -var background_color = 'ffffff'; -var link_color; - /* ie 5 / mac compatibility routine */ function push(array, item) { @@ -215,49 +211,15 @@ this.products.push(product); $('checkout').style.visibility = 'visible'; } -} +}; /* news */ -function loadXMLDoc(fname) +function load_news() { - var xmlDoc; - - // code for IE - if (window.ActiveXObject) { - xmlDoc = new ActiveXObject("Microsoft.XMLDOM"); - } - else if (document.implementation - && document.implementation.createDocument) { - // code for Mozilla, Firefox, Opera, etc. - xmlDoc = document.implementation.createDocument("","",null); - } else { - alert('Your browser cannot handle this script'); - } - xmlDoc.async = false; - xmlDoc.load(fname); - - return xmlDoc; + } -function xstlTransformDocumentToElement(document, stylesheet, elementId) -{ - xml = loadXMLDoc(document); - xsl = loadXMLDoc(stylesheet); - if (window.ActiveXObject) { - // code for IE - ex = xml.transformNode(xsl); - document.getElementById(elementId).innerHTML = ex; - } else if (document.implementation - && document.implementation.createDocument) { - // code for Mozilla, Firefox, Opera, etc. - xsltProcessor = new XSLTProcessor(); - xsltProcessor.importStylesheet(xsl); - resultDocument = xsltProcessor.transformToFragment(xml,document); - document.getElementById(elementId).appendChild(resultDocument); - } -} - /* image database */ var current_directory; @@ -386,15 +348,15 @@ var pages = []; -function Page(elements, colors, action) { +function Page(elements, link_color, action) { this.elements = elements; - this.colors = colors; + this.link_color = link_color; this.action = action; } pages['home'] = new Page(['home_page'], - ['000000', 'ffffff', '953cfd'], + '953cfd', function() { footer_down(); @@ -410,7 +372,7 @@ pages['pixel'] = new Page(['directory_page'], - ['000000', 'ffffff', 'ff00ff'], + 'ff00ff', function() { footer_up(); directory('pixel'); @@ -418,7 +380,7 @@ pages['vector'] = new Page(['directory_page'], - ['000000', 'ffffff', '00ccff'], + '00ccff', function() { footer_up(); directory('vector'); @@ -426,21 +388,22 @@ pages['news'] = new Page(['news_page'], - ['000000', 'ffffff', '30be01'], + '30be01', function() { footer_hide(); + load_news(); }); pages['shop'] = new Page(['results'], - ['000000', 'ffffff', '0054ff'], + '0054ff', function() { footer_hide(); }); pages['cart'] = new Page(['cart_page'], - ['000000', 'ffffff', '0054ff'], + '0054ff', function() { show_shopping_cart(); footer_hide(); @@ -448,7 +411,7 @@ pages['contact'] = new Page(['contact_page'], - ['000000', 'ffffff', 'ffa200'], + 'ffa200', function() { footer_hide(); @@ -459,17 +422,6 @@ current_directory = 'contact'; }); -function change_colors(pagename, colors) { - - foreground_color = colors[0]; - background_color = colors[1]; - link_color = colors[2]; - - // change text colors - $("body").style.backgroundColor = "#" + background_color; - $("body").style.color = "#" + foreground_color; -} - function display_cms_window() { if (logged_in) { @@ -504,7 +456,6 @@ debug('show_page ' + pagename); // Activate the menu by coloring the buttons correctly - change_colors(pagename, page.colors); $('menu').className = pagename; document.body.className = pagename; @@ -820,7 +771,7 @@ + current_directory + '/' + current_subdirectory + '/' + image.name + '" onclick="display_image(' + "'" + image.position + "'" + ');">' + '<img class="inherited_image" width="' + cell_width + '" height="' + cell_height + '" ' - + ' src="/image/' + image.name + '/cell,' + background_color + ',' + cell_width + ',' + cell_height + ',8" ' + + ' src="/image/' + image.name + '/cell,ffffff,' + cell_width + ',' + cell_height + ',8" ' + ' onload="reveal_image(this);" />' + '</a>'; } @@ -1143,7 +1094,7 @@ overlay.className = current_directory; replaceChildNodes(overlay, H1(null, title), - IMG({ src: '/image/overlay-close/color,000000,' + pages[current_directory].colors[2], + IMG({ src: '/image/overlay-close/color,000000,' + pages[current_directory].link_color, id: 'close', width: 13, height: 13})); overlay.style.width = width + 'px'; $('close').style.left = (width - 23) + 'px'; @@ -1318,7 +1269,7 @@ function recolored_image_path(name) { - return '/image/' + name + '/color,ff00ff,' + pages[current_directory].colors[2]; + return '/image/' + name + '/color,ff00ff,' + pages[current_directory].link_color; } function make_image_action_button(name, action, height) Modified: trunk/projects/quickhoney/website/static/styles.css =================================================================== --- trunk/projects/quickhoney/website/static/styles.css 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/projects/quickhoney/website/static/styles.css 2008-07-29 22:25:41 UTC (rev 3683) @@ -109,6 +109,8 @@ #menu.contact a#m_contact img.selected { visibility: visible } #menu.contact a#m_contact img.unselected { visibility: hidden } +.autonews a { color: #30be01; } + #menu img.selected { visibility: hidden; z-index: 110; @@ -431,16 +433,18 @@ width: 428px; height: 108px; position: relative; - } +} .newsentry img { position: absolute; top: 5px; left: 5px; - } +} + .newsentry div { position: absolute; top: 5px; left: 118px; - } +} + .newsentry h1 { margin: 0px 0px 2px 0px; font-size: 120%; @@ -450,8 +454,7 @@ .news_vector { background-color: #00ccff; } .news_pixel { background-color: #ff00ff; } -.news_pixel a { background-color: #ff00ff; } - +.autonews a { color: white } div.news_sep { width: 428px; height: 17px; background-image: url(/image/news-sep); } /* cms styles */ Modified: trunk/projects/quickhoney/website/templates/index.xml =================================================================== --- trunk/projects/quickhoney/website/templates/index.xml 2008-07-29 20:25:57 UTC (rev 3682) +++ trunk/projects/quickhoney/website/templates/index.xml 2008-07-29 22:25:41 UTC (rev 3683) @@ -131,7 +131,7 @@ <div id="news_page"> <p id="news_content"> - <div class="newsentry news_vector"> + <div class="newsentry news_vector autonews"> <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/> <div> <h1>Jan and Ella</h1> @@ -141,7 +141,7 @@ </div> <div class="news_sep"> </div> <br/> - <div class="newsentry news_pixel"> + <div class="newsentry news_pixel autonews"> <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/> <div> March 8th, 2008 by Peter | <a href="foo">permalink</a><br/>

1 0

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

29 Jul '08

Revision: 3682 Author: hans URL: http://bknr.net/trac/changeset/3682 Fix anonymous transactions: Instead of storing the subtransactions and then serializing them at the end of the transaction, they are now serialized immediately to an in-memory buffer and written to the transaction log at the end of the transaction in one fell swoop. Add condition classes for most errors that are signaled from txn.lisp U trunk/bknr/datastore/src/data/object-tests.lisp U trunk/bknr/datastore/src/data/object.lisp U trunk/bknr/datastore/src/data/txn.lisp Modified: trunk/bknr/datastore/src/data/object-tests.lisp =================================================================== --- trunk/bknr/datastore/src/data/object-tests.lisp 2008-07-29 15:07:40 UTC (rev 3681) +++ trunk/bknr/datastore/src/data/object-tests.lisp 2008-07-29 20:25:57 UTC (rev 3682) @@ -45,22 +45,25 @@ (call-next-method) (close-store))) +(defvar *tests* (make-hash-table)) + (defmacro define-datastore-test (name &rest body) - `(make-instance 'datastore-test-class - :unit :datastore - :name ,name - :body (lambda () - ,@body))) + `(setf (gethash ,name *tests*) + (make-instance 'datastore-test-class + :unit :datastore + :name ,name + :body (lambda () + ,@body)))) -(define-datastore-test "Datastore setup" +(define-datastore-test :store-setup (test-assert *test-datastore*)) -(define-datastore-test "Create object" +(define-datastore-test :create-object (let ((obj (make-object 'store-object))) (test-assert obj) (test-equal (list obj) (all-store-objects)))) -(define-datastore-test "Create multiple objects" +(define-datastore-test :create-multiple-objects (let ((o1 (make-object 'store-object)) (o2 (make-object 'store-object))) (test-assert o1) @@ -68,7 +71,7 @@ (test-equal (length (all-store-objects)) 2) (test-assert (subsetp (list o1 o2) (all-store-objects))))) -(define-datastore-test "Delete multiple objects" +(define-datastore-test :delete-multiple-objects (let ((o1 (make-object 'store-object)) (o2 (make-object 'store-object))) (test-assert o1) @@ -80,23 +83,23 @@ (delete-object o2) (test-equal (all-store-objects) nil))) -(define-datastore-test "Restore" +(define-datastore-test :restore (make-object 'store-object) (restore) (test-equal (length (all-store-objects)) 1)) -(define-datastore-test "Snapshot and Restore" +(define-datastore-test :snapshot-and-restore (make-object 'store-object) (snapshot) (restore) (test-equal (length (all-store-objects)) 1)) -(define-datastore-test "Restore multiple objects" +(define-datastore-test :restore-multiple-objects (dotimes (i 10) (make-object 'store-object)) (restore) (test-equal (length (all-store-objects)) 10)) -(define-datastore-test "Snapshot and Restore multiple objects" +(define-datastore-test :snapshot-restore-multiple-objects (dotimes (i 10) (make-object 'store-object)) (snapshot) (restore) @@ -104,7 +107,7 @@ (defconstant +stress-size+ 10000) -(define-datastore-test "Stress test object creation" +(define-datastore-test :stress-test (format t "Creating ~a objects~%" +stress-size+) (time (bknr.datastore::without-sync () (dotimes (i +stress-size+) @@ -121,10 +124,19 @@ (define-persistent-class child () ()) -(define-datastore-test "Serialize circular dependency in anonymous txn" +(define-datastore-test :serialize-circular-in-anon-txn (let ((parent (make-object 'parent))) (with-transaction (:circular) (setf (parent-child parent) (make-object 'child)))) (restore) (test-equal (find-class 'child) - (class-of (parent-child (first (class-instances 'parent)))))) \ No newline at end of file + (class-of (parent-child (first (class-instances 'parent)))))) + +(define-datastore-test :delete-object-in-anon-txn + (let (object) + (with-transaction (:make) + (setf object (make-object 'child))) + (with-transaction (:delete) + (delete-object object)) + (restore) + (test-assert (object-destroyed-p object)))) \ No newline at end of file Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-29 15:07:40 UTC (rev 3681) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-29 20:25:57 UTC (rev 3682) @@ -96,11 +96,11 @@ (defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd) (when (in-anonymous-transaction-p) - (push (make-instance 'transaction - :timestamp (get-universal-time) - :function-symbol 'tx-change-slot-values - :args (list object (slot-definition-name slotd) newval)) - (anonymous-transaction-transactions *current-transaction*)))) + (encode (make-instance 'transaction + :timestamp (get-universal-time) + :function-symbol 'tx-change-slot-values + :args (list object (slot-definition-name slotd) newval)) + (anonymous-transaction-log-buffer *current-transaction*)))) (defmethod direct-slot-definition-class ((class persistent-class) &key &allow-other-keys) 'persistent-direct-slot-definition) @@ -195,17 +195,17 @@ (if (in-anonymous-transaction-p) (prog1 (call-next-method) - (push (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))))) - (anonymous-transaction-transactions *current-transaction*))) + (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))))) + (anonymous-transaction-log-buffer *current-transaction*))) (call-next-method))) (defmethod initialize-instance :after ((object store-object) &key id &allow-other-keys) @@ -661,7 +661,8 @@ (destroy-object (store-object-with-id id))) (defun delete-object (object) - (if (in-transaction-p) + (if (and (in-transaction-p) + (not (in-anonymous-transaction-p))) (destroy-object object) (execute (make-instance 'transaction :function-symbol 'tx-delete-object :timestamp (get-universal-time) Modified: trunk/bknr/datastore/src/data/txn.lisp =================================================================== --- trunk/bknr/datastore/src/data/txn.lisp 2008-07-29 15:07:40 UTC (rev 3681) +++ trunk/bknr/datastore/src/data/txn.lisp 2008-07-29 20:25:57 UTC (rev 3682) @@ -10,13 +10,67 @@ (define-condition not-in-transaction (error) () (:documentation - "Thrown when an operation on persistent slots is executed outside a transaction context")) + "Signaled when an operation on persistent slots is executed outside + a transaction context")) (define-condition store-not-open (error) () (:documentation - "Thrown when a transaction is executed on a store that is not opened")) + "Signaled when a transaction is executed on a store that is not + opened")) +(define-condition store-already-open (error) + () + (:documentation + "Signaled when an attempt is made to open a store with another + store being open")) + +(define-condition invalid-store-random-state (error) + () + (:documentation + "Signaled when the on-disk store random state cannot be read, + typically because it has been written with another Lisp")) + +(define-condition unsupported-lambda-list-option (error) + ((option :initarg :option :reader option)) + (:documentation + "Signaled when DEFTRANSACTION is used with an unsupported option in + its lambda list")) + +(define-condition default-arguments-unsupported (error) + ((tx-name :initarg :tx-name :reader tx-name) + (argument :initarg :argument :reader argument)) + (:report (lambda (c stream) + (format stream "argument ~A defaulted in DEFTRANSACTION ~S" + (argument c) (tx-name c)))) + (:documentation + "Signaled when an argument in a DEFTRANSACTION definition has a + default declaration")) + +(define-condition undefined-transaction (error) + ((tx-name :initarg :tx-name :reader tx-name)) + (:report (lambda (c stream) + (format stream "undefined transaction ~A in transaction log, please ensure that all the necessary code is loaded." + (tx-name c)))) + (:documentation + "Signaled when a named transaction is loaded from the transaction + log and no matching function definition could be found")) + +(define-condition invalid-transaction-nesting (error) + () + (:documentation + "Signaled when WITH-TRANSACTION forms are nested.")) + +(define-condition anonymous-transaction-in-named-transaction (error) + () + (:documentation + "Signaled when an anonymous transaction is started from within a named transaction.")) + +(define-condition no-subsystems (error) + () + (:documentation + "Signaled when an attempt is made to snapshot a store without subsystems")) + ;;; store (defvar *store*) @@ -74,7 +128,7 @@ (restart-case (when (and (boundp '*store*) *store*) - (error "A store is already opened.")) + (error 'store-already-open)) (close-store () :report "Close the opened store." (close-store))))) @@ -153,7 +207,7 @@ (read f) (error (e) (declare (ignore e)) - (error "Invalid store random state")))) + (error 'invalid-store-random-state)))) (initialize-store-random-state () :report "Initialize the random state of the store. Use this to reinitialize the random state of the store when porting over a @@ -245,7 +299,7 @@ (defun store-current-transaction () (if (in-transaction-p) *current-transaction* - (error "store-current-transaction called outside of a transaction"))) + (error 'not-in-transaction))) ;;; All transactions are executed by an 'executor', which is the store ;;; itself or, in the case of a nested transaction, the parent @@ -262,7 +316,7 @@ (defmethod execute-transaction :before (executor transaction) (unless (store-open-p) - (error (make-condition 'store-not-open)))) + (error 'store-not-open))) (defmethod execute-transaction ((executor transaction) transaction) (execute-unlogged transaction)) @@ -317,7 +371,7 @@ (&optional) (&rest (setf args (cdr args))) ; skip argument, too (&key (setf in-keywords-p t)) - (otherwise (error "unsupported lambda list option ~A in DEFTRANSACTION" arg)))) + (otherwise (error 'unsupported-lambda-list-option :option arg)))) (t (when in-keywords-p (push (intern (symbol-name arg) :keyword) result)) @@ -335,7 +389,7 @@ (body body)) (dolist (arg args) (when (listp arg) - (error "can't have argument defaults in transaction declaration for transaction ~A, please implement a wrapper" name))) + (error 'default-arguments-unsupported :tx-name name :argument (car arg)))) (let ((tx-name (intern (format nil "TX-~A" name) (symbol-package name)))) `(progn @@ -408,8 +462,8 @@ (with-store-guard () (let ((*current-transaction* transaction)) (apply (or (symbol-function (transaction-function-symbol transaction)) - (error "Undefined transaction function ~A, please ensure that all the necessary code is loaded." - (transaction-function-symbol transaction))) + (error 'undefined-transaction + :tx-name (transaction-function-symbol transaction))) (transaction-args transaction))))) (defun fsync (stream) @@ -436,7 +490,7 @@ (check-type transaction symbol) ; otherwise care for multiple evaluation `(with-store-guard () (when (in-transaction-p) - (error "can't open nested with-transaction-log blocks")) + (error 'invalid-transaction-nesting)) (with-store-state (:transaction) (prog1 (let ((*current-transaction* ,transaction)) @@ -472,61 +526,54 @@ ;;; The actual writing to the transaction log is performed by the ;;; with-transaction macro. -;;; An anonymous transaction has an optional label which is stored in -;;; the transaction log in order to make the source code location where +;;; An anonymous transaction has a label which is stored in the +;;; transaction log in order to make the source code location where ;;; the actual transaction code lives identifieable. (defclass anonymous-transaction (transaction) - ((label :initarg :label :accessor anonymous-transaction-label) - (transactions :initarg :transactions :accessor anonymous-transaction-transactions)) - (:default-initargs :transactions nil :label nil)) + ((label :initarg :label + :accessor anonymous-transaction-label + :initform (error "missing label in anonymous transaction definition")) + (log-buffer :initarg :log-buffer + :accessor anonymous-transaction-log-buffer + :initform (flex:make-in-memory-output-stream)))) (defmethod print-object ((transaction anonymous-transaction) stream) (print-unreadable-object (transaction stream :type t) - (format stream "~A ~A ~A" + (format stream "~A ~A (~A)" (format-date-time (transaction-timestamp transaction)) (anonymous-transaction-label transaction) - (anonymous-transaction-transactions transaction)))) + (class-name (class-of (anonymous-transaction-log-buffer transaction)))))) (defmethod in-anonymous-transaction-p () (subtypep (type-of *current-transaction*) 'anonymous-transaction)) (defmethod encode-object ((transaction anonymous-transaction) stream) - (cond - ((anonymous-transaction-label transaction) - (%write-tag #\N stream) - (%encode-string (anonymous-transaction-label transaction) stream)) - (t - (%write-tag #\G stream))) - (%encode-list (reverse (anonymous-transaction-transactions transaction)) stream)) + (%write-tag #\N stream) + (%encode-string (anonymous-transaction-label transaction) stream) + (let ((subtxns (flex:get-output-stream-sequence (anonymous-transaction-log-buffer transaction)))) + (%encode-integer (length subtxns) stream) + (write-sequence subtxns stream))) -(defmethod decode-object ((tag (eql #\G)) stream) - (make-instance 'anonymous-transaction - :transactions (%decode-list stream))) - (defvar *txn-log-stream* nil "This variable is bound to the transaction log stream while loading the transaction log. It is used by anonymous transactions to read the subtransactions from the log.") (defmethod decode-object ((tag (eql #\N)) stream) - ;; When decoding an anonymous transaction from the transaction log, - ;; we only read its name. The subtransaction are not read here, but - ;; rather in EXECUTE-UNLOGGED below. The reason for this is that we - ;; need to execute the subtransactions while reading them, as we'd - ;; otherwise not be able to properly deserialize references to - ;; objects that have been created within this anonymous transaction. + (let* ((label (%decode-string stream)) + (length (%decode-integer stream)) + (buffer (make-array length :element-type '(unsigned-byte 8)))) + (read-sequence buffer stream) + (make-instance 'anonymous-transaction + :label label + :log-buffer (flex:make-in-memory-input-stream buffer)))) - ;; Thus, while restoring, the TRANSACTIONS slot of the anonymous - ;; transaction object is not used. - (make-instance 'anonymous-transaction - :label (%decode-string stream))) - (defmacro with-transaction ((&optional label) &body body) (let ((txn (gensym))) `(progn (when (in-transaction-p) - (error "tried to start anonymous transaction while in a transaction")) + (error 'anonymous-transaction-in-named-transaction)) (let ((,txn (make-instance 'anonymous-transaction :label ,(if (symbolp label) (symbol-name label) label)))) (with-transaction-log (,txn) ,@body))))) @@ -537,15 +584,14 @@ ;; subtransactions from the transaction log. (assert (eq :restore (store-state *store*)) () "Unexpected store state ~A for EXECUTE-UNLOGGED on an anonymous transaction" (store-state *store*)) - (let ((subtxns (%decode-integer *txn-log-stream*))) - (dotimes (i subtxns) - (execute-unlogged (decode *txn-log-stream*))) - (when (plusp subtxns) - ;; In order to maintain the previous on-disk format, we read the last cdr of the list - (assert (eq nil (decode *txn-log-stream*)))))) + (let ((stream (anonymous-transaction-log-buffer transaction))) + (handler-case + (loop + (execute-unlogged (decode stream))) + (end-of-file ())))) -(defmethod execute-transaction :after ((executor anonymous-transaction) transaction) - (push transaction (anonymous-transaction-transactions executor))) +(defmethod execute-transaction :before ((executor anonymous-transaction) transaction) + (encode transaction (anonymous-transaction-log-buffer executor))) ;;; Subsystems @@ -571,9 +617,9 @@ (defmethod snapshot-store ((store store)) (unless (store-open-p) - (error (make-condition 'store-not-open))) + (error 'store-not-open)) (when (null (store-subsystems store)) - (error "Cannot snapshot store without subsystems...")) + (error 'no-subsystems)) (ensure-store-current-directory store) (with-store-state (:read-only store) (with-store-guard ()

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/
by BKNR Commits 29 Jul '08

29 Jul '08

Revision: 3681 Author: ksprotte URL: http://bknr.net/trac/changeset/3681 checkpoint U trunk/projects/bos/m2/contract-expiry.lisp U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/test/allocation.lisp U trunk/projects/bos/web/contract-tree.lisp U trunk/projects/bos/web/kml-handlers.lisp U trunk/projects/bos/web/reports-xml-handler.lisp Modified: trunk/projects/bos/m2/contract-expiry.lisp =================================================================== --- trunk/projects/bos/m2/contract-expiry.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/m2/contract-expiry.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -1,7 +1,7 @@ (in-package :bos.m2) (defun delete-expired-contracts () - (let ((unpaid-contracts (remove-if #'contract-paidp (class-instances 'contract))) + (let ((unpaid-contracts (remove-if #'contract-paidp (all-contracts))) deleting) (dolist (contract unpaid-contracts) (when (contract-is-expired contract) Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/m2/m2.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -257,7 +257,9 @@ (download-only :update) (cert-issued :read) (worldpay-trans-id :update :initform nil) - (expires :read :documentation "universal time which specifies the time the contract expires (is deleted) when it has not been paid for" :initform nil) + (expires :read :documentation "universal time which specifies the + time the contract expires (is deleted) when it has not been paid for" + :initform nil) (largest-rectangle :update)) (:default-initargs :m2s nil @@ -379,7 +381,7 @@ (defun all-contracts () "Return list of all contracts in the system." - (class-instances 'all-contracts)) + (class-instances 'contract)) (defun contracts-bounding-box (&optional (contracts (all-contracts))) (geometry:with-bounding-box-collect (collect) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/m2/packages.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -139,6 +139,7 @@ #:contract #:make-contract + #:all-contracts #:contract-p #:get-contract #:contract-sponsor Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/m2/poi.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -28,20 +28,20 @@ (define-persistent-class poi-medium (textual-attributes-mixin) ((poi :read))) -(deftransaction make-poi-medium (class-name &key language title subtitle description poi initargs) +(deftransaction make-poi-medium (class-name &rest rest &key language title subtitle description poi initargs) + (declare (ignore poi initargs)) (assert (if (or title subtitle description) language t) nil "language needs to be specified, if any of title, subtitle or description is given") - (let ((medium (apply #'make-object class-name :poi poi initargs))) - (update-textual-attributes medium language - :title title - :subtitle subtitle - :description description) - medium)) + (apply #'make-object class-name rest)) (defmethod initialize-persistent-instance :after ((poi-medium poi-medium) &key language title subtitle description poi) - (when (poi-medium-poi poi-medium) - (push poi-medium (poi-media (poi-medium-poi poi-medium))))) + (when poi + (push poi-medium (poi-media poi))) + (update-textual-attributes poi-medium language + :title title + :subtitle subtitle + :description description)) (defmethod print-object ((object poi-medium) stream) (print-unreadable-object (object stream :type t :identity nil) @@ -56,6 +56,14 @@ (define-persistent-class poi-image (store-image poi-medium) ()) +;;; poi-airal +(define-persistent-class poi-airal (store-image poi-medium) + ()) + +;;; poi-panorama +(define-persistent-class poi-panorama (store-image poi-medium) + ()) + ;;; poi-movie (define-persistent-class poi-movie (poi-medium) ((url :update :initform nil))) @@ -65,10 +73,10 @@ ((name :read :index-type string-unique-index :index-reader find-poi :index-values all-pois :documentation "Symbolischer Name") - (published :update :initform nil :documentation "Wenn dieses Flag NIL ist, wird der POI in den UIs nicht angezeigt") + (published :update :initform nil :documentation "Wenn dieses Flag NIL ist, wird der POI in den UIs nicht angezeigt") (area :update :initform nil :documentation "Polygon mit den POI-Koordinaten") - (icon :update :initform "palme" :documentation "Name des Icons") - (media :update :initform nil))) + (icon :update :initform "palme" :documentation "Name des Icons") + (media :update :initform nil :documentation "Liste aller POI-Medien, wie POI-IMAGE, POI-AIRAL ..."))) (deftransaction make-poi (language name &key title description area) (let ((poi (make-object 'poi :name name :area area))) @@ -76,12 +84,18 @@ (setf (slot-string poi 'description language) description) poi)) +(defmethod initialize-persistent-instance :after ((poi poi) &key language title subtitle description) + (update-textual-attributes poi language + :title title + :subtitle subtitle + :description description)) + (defmethod destroy-object :before ((poi poi)) (mapc #'delete-object (poi-media poi))) (defmethod poi-complete ((poi poi) language) (and (every #'(lambda (slot-name) (slot-string poi slot-name language nil)) '(title subtitle description)) - (poi-area poi) + (poi-area poi) (<= 6 (count-if (lambda (medium) (typep medium 'poi-image)) (poi-media poi))) t)) @@ -94,6 +108,16 @@ (defun poi-center-lon-lat (poi) (geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ (poi-center-x poi)) (- +nw-utm-y+ (poi-center-y poi)) +utm-zone+ t)) +(macrolet ((define-poi-medium-reader (name) + (let ((type (find-symbol (subseq (symbol-name name) 0 (1- (length (symbol-name name))))))) + (assert type) + `(defun ,name (poi) + (remove-if-not (lambda (medium) (typep medium ',type)) (poi-media poi)))))) + (define-poi-medium-reader poi-images) + (define-poi-medium-reader poi-airals) + (define-poi-medium-reader poi-panoramas) + (define-poi-medium-reader poi-movies)) + (defun make-poi-javascript (language) "Erzeugt das POI-Javascript für das Infosystem" (with-output-to-string (*standard-output*) @@ -148,3 +172,19 @@ (format t "poi['y'] = ~D;~%" y) (format t "poi['thumbnail'] = 0;~%") (format t "pois.push(poi);~%"))))) + +;;; poi schema evolution aids + +(define-modify-macro appendf (&rest args) append) + +(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'airals)) value) + (appendf (poi-media poi) (mapcar (lambda (obj) (change-class obj 'poi-airal :poi poi)) value))) + +(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'images)) value) + (appendf (poi-media poi) (mapcar (lambda (obj) (change-class obj 'poi-image :poi poi)) value))) + +(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'movies)) value) + (appendf (poi-media poi) (mapcar (lambda (url) (make-instance 'poi-movie :url url :poi poi)) value))) + +(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'panoramas)) value) + (appendf (poi-media poi) (mapcar (lambda (obj) (change-class obj 'poi-panorama :poi poi)) value))) Modified: trunk/projects/bos/test/allocation.lisp =================================================================== --- trunk/projects/bos/test/allocation.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/test/allocation.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -83,7 +83,7 @@ (with-transaction () (iter (while (> size total-free)) - (for contract = (first (class-instances 'contract))) + (for contract = (first (all-contracts))) (incf total-free (length (contract-m2s contract))) (destroy-object contract))) (finishes (make-contract sponsor size)) Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -355,7 +355,7 @@ ;; has already been called :base-node *quad-tree* :name '*contract-tree*)) - (dolist (contract (class-instances 'contract)) + (dolist (contract (all-contracts)) (when (contract-published-p contract) (insert-contract *contract-tree* contract))) (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree* Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -249,7 +249,7 @@ ()) (defmethod handle ((handler country-stats-handler)) - (let* ((contracts (class-instances 'contract)) + (let* ((contracts (all-contracts)) (timestamp (reduce #'max contracts :key (lambda (contract) (if (contract-paidp contract) (store-object-last-change contract 0) Modified: trunk/projects/bos/web/reports-xml-handler.lisp =================================================================== --- trunk/projects/bos/web/reports-xml-handler.lisp 2008-07-29 12:56:24 UTC (rev 3680) +++ trunk/projects/bos/web/reports-xml-handler.lisp 2008-07-29 15:07:40 UTC (rev 3681) @@ -32,7 +32,7 @@ (or (not (contract-paidp contract)) (and *year* (not (eql *year* (contract-year contract)))))) - (class-instances 'contract)) + (all-contracts)) #'< :key #'contract-date))) (setf name (intern (string-upcase name) :bos.web)) (apply (or (gethash name *report-generators*)

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