bknr-cvs July 2008

bknr-cvs@common-lisp.net

1 participants
321 discussions

[bknr-cvs] hans changed trunk/projects/quickhoney/src/handlers.lisp
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3703 Author: hans URL: http://bknr.net/trac/changeset/3703 STREAM->OUTPUT-STREAM to avoid package lock errors U trunk/projects/quickhoney/src/handlers.lisp Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-07-31 06:18:02 UTC (rev 3702) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-07-31 07:44:11 UTC (rev 3703) @@ -433,18 +433,18 @@ (defvar *json-output*) (defclass json-output-stream () - ((stream :reader stream - :initarg :stream) + ((output-stream :reader output-stream + :initarg :output-stream) (stack :accessor stack :initform nil))) (defun next-aggregate-element () (if (car (stack *json-output*)) - (princ #\, (stream *json-output*)) + (princ #\, (output-stream *json-output*)) (setf (car (stack *json-output*)) t))) (defmacro with-json-output ((stream) &body body) - `(let ((*json-output* (make-instance 'json-output-stream :stream ,stream))) + `(let ((*json-output* (make-instance 'json-output-stream :output-stream ,stream))) ,@body)) (defmacro with-json-output-to-string (() &body body) @@ -456,12 +456,12 @@ `(progn (when (stack *json-output*) (next-aggregate-element)) - (princ ,begin-char (stream *json-output*)) + (princ ,begin-char (output-stream *json-output*)) (push nil (stack *json-output*)) (prog1 (progn ,@body) (pop (stack *json-output*)) - (princ ,end-char (stream *json-output*))))) + (princ ,end-char (output-stream *json-output*))))) (defmacro with-json-array (() &body body) `(with-json-aggregate (#\[ #\]) @@ -473,13 +473,13 @@ (defun encode-array-element (object) (next-aggregate-element) - (json:encode-json object (stream *json-output*))) + (json:encode-json object (output-stream *json-output*))) (defun encode-object-element (key value) (next-aggregate-element) - (json:encode-json key (stream *json-output*)) - (princ #\: (stream *json-output*)) - (json:encode-json value (stream *json-output*))) + (json:encode-json key (output-stream *json-output*)) + (princ #\: (output-stream *json-output*)) + (json:encode-json value (output-stream *json-output*))) (defmethod handle-object ((handler news-json-handler) (channel rss-channel)) (with-http-response (:content-type "application/json")

1 0

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

31 Jul '08

Revision: 3702 Author: hans URL: http://bknr.net/trac/changeset/3702 Add streaming JSON encoding infrastructure and handler for news. U trunk/bknr/web/src/rss/rss.lisp U trunk/projects/quickhoney/src/handlers.lisp Modified: trunk/bknr/web/src/rss/rss.lisp =================================================================== --- trunk/bknr/web/src/rss/rss.lisp 2008-07-30 21:06:43 UTC (rev 3701) +++ trunk/bknr/web/src/rss/rss.lisp 2008-07-31 06:18:02 UTC (rev 3702) @@ -117,6 +117,12 @@ (when days-string (parse-integer days-string))))) +(defun month-from-query-parameter () + (when (boundp 'hunchentoot:*request*) + (let ((month-string (bknr.web:query-param "month"))) + (when month-string + (mapcar #'parse-integer (cl-ppcre:split "([-/]|(?<=..))" month-string :limit 2)))))) + (defun rss-channel-archive (channel) "Return the channel archive consisting of lists of lists ((MONTH YEAR) ITEM...)" (group-on (rss-channel-items channel) @@ -129,18 +135,21 @@ (defgeneric rss-channel-items (channel &key) (:documentation "Return all non-expired items in channel.") - (: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))))))) + (:method ((channel rss-channel) &key days month count) + (unless month + (setf month (month-from-query-parameter))) + (unless days + (setf days (or (days-from-query-parameter) + (rss-channel-max-item-age channel)))) + (let ((items (if month + (cdr (find month (rss-channel-archive channel) :test #'equal)) + (let ((expiry-time (- (get-universal-time) (* 60 60 24 days)))) + (remove-if (lambda (item) (or (object-destroyed-p item) + (< (rss-item-pub-date item) expiry-time))) + (slot-value channel 'items)))))) + (if count + (subseq items 0 (min count (length items))) + items)))) (defgeneric rss-channel-archived-months (channel) (:documentation "Return a list of lists (MONTH YEAR) for which the Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-07-30 21:06:43 UTC (rev 3701) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-07-31 06:18:02 UTC (rev 3702) @@ -432,49 +432,61 @@ (defvar *json-output*) +(defclass json-output-stream () + ((stream :reader stream + :initarg :stream) + (stack :accessor stack + :initform nil))) + +(defun next-aggregate-element () + (if (car (stack *json-output*)) + (princ #\, (stream *json-output*)) + (setf (car (stack *json-output*)) t))) + (defmacro with-json-output ((stream) &body body) - `(let ((*json-output* ,stream)) + `(let ((*json-output* (make-instance 'json-output-stream :stream ,stream))) ,@body)) (defmacro with-json-output-to-string (() &body body) - `(with-output-to-string (*json-output*) - ,@body)) + `(with-output-to-string (s) + (with-json-output (s) + ,@body))) +(defmacro with-json-aggregate ((begin-char end-char) &body body) + `(progn + (when (stack *json-output*) + (next-aggregate-element)) + (princ ,begin-char (stream *json-output*)) + (push nil (stack *json-output*)) + (prog1 + (progn ,@body) + (pop (stack *json-output*)) + (princ ,end-char (stream *json-output*))))) + (defmacro with-json-array (() &body body) - (with-gensyms (need-comma) - `(let (,need-comma) - (princ #\[ *json-output*) - (prog1 - (labels ((encode-array-element (value) - (if ,need-comma - (princ #\, *json-output*) - (setf ,need-comma t)) - (json:encode-json value *json-output*))) - ,@body) - (princ #\] *json-output*))))) + `(with-json-aggregate (#\[ #\]) + ,@body)) (defmacro with-json-object (() &body body) - (with-gensyms (need-comma) - `(let (,need-comma) - (princ #\{ *json-output*) - (prog1 - (labels ((encode-object-member (key value) - (when value - (if ,need-comma - (princ #\, *json-output*) - (setf ,need-comma t)) - (json:encode-json key *json-output*) - (princ #\, *json-output*) - (json:encode-json value *json-output*)))) - ,@body) - (princ #\} *json-output*))))) + `(with-json-aggregate (#\{ #\}) + ,@body)) +(defun encode-array-element (object) + (next-aggregate-element) + (json:encode-json object (stream *json-output*))) + +(defun encode-object-element (key value) + (next-aggregate-element) + (json:encode-json key (stream *json-output*)) + (princ #\: (stream *json-output*)) + (json:encode-json value (stream *json-output*))) + (defmethod handle-object ((handler news-json-handler) (channel rss-channel)) (with-http-response (:content-type "application/json") (with-json-output-to-string () (with-json-array () (dolist (item (rss-channel-items channel)) (with-json-object () - (encode-object-member "pubDate" (format-date-time (rss-item-pub-date item) :vms-style t)) - (encode-object-member "title" (rss-item-title item)) - (encode-object-member "description" (rss-item-description item)))))))) \ No newline at end of file + (encode-object-element "pubDate" (format-date-time (rss-item-pub-date item) :vms-style t)) + (encode-object-element "title" (rss-item-title item)) + (encode-object-element "description" (rss-item-description item))))))))

1 0

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

30 Jul '08

Revision: 3701 Author: hans URL: http://bknr.net/trac/changeset/3701 Work on JSON handler for news. U trunk/projects/quickhoney/src/handlers.lisp U trunk/projects/quickhoney/src/image.lisp A trunk/projects/quickhoney/src/news.lisp U trunk/projects/quickhoney/src/quickhoney.asd U trunk/projects/quickhoney/src/webserver.lisp Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-07-30 15:30:19 UTC (rev 3700) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-07-30 21:06:43 UTC (rev 3701) @@ -313,7 +313,8 @@ ((:script :type "text/javascript" :language "JavaScript") "function done() { window.opener.do_query(); window.close(); }")) (:body - (:p "Image " (:princ-safe (store-image-name image)) " with " (:princ-safe (hash-table-count color-table)) " colors uploaded") + (:p "Image " (:princ-safe (store-image-name image)) " with " + (:princ-safe (hash-table-count color-table)) " colors uploaded") (:p ((:img :src (format nil "/image/~D" (store-object-id image)) :width (round (* ratio width)) :height (round (* ratio height))))) (:p ((:a :href "javascript:done()") "ok"))))))))))) @@ -424,3 +425,56 @@ (:p "Error during upload:") (:p (:princ-safe (apply #'format nil (simple-condition-format-control e) (simple-condition-format-arguments e)))) (:p ((:a :href "javascript:window.close()") "ok")))))))))))) + +(defclass news-json-handler (object-handler) + () + (:default-initargs :object-class 'rss-channel :query-function #'find-rss-channel)) + +(defvar *json-output*) + +(defmacro with-json-output ((stream) &body body) + `(let ((*json-output* ,stream)) + ,@body)) + +(defmacro with-json-output-to-string (() &body body) + `(with-output-to-string (*json-output*) + ,@body)) + +(defmacro with-json-array (() &body body) + (with-gensyms (need-comma) + `(let (,need-comma) + (princ #\[ *json-output*) + (prog1 + (labels ((encode-array-element (value) + (if ,need-comma + (princ #\, *json-output*) + (setf ,need-comma t)) + (json:encode-json value *json-output*))) + ,@body) + (princ #\] *json-output*))))) + +(defmacro with-json-object (() &body body) + (with-gensyms (need-comma) + `(let (,need-comma) + (princ #\{ *json-output*) + (prog1 + (labels ((encode-object-member (key value) + (when value + (if ,need-comma + (princ #\, *json-output*) + (setf ,need-comma t)) + (json:encode-json key *json-output*) + (princ #\, *json-output*) + (json:encode-json value *json-output*)))) + ,@body) + (princ #\} *json-output*))))) + +(defmethod handle-object ((handler news-json-handler) (channel rss-channel)) + (with-http-response (:content-type "application/json") + (with-json-output-to-string () + (with-json-array () + (dolist (item (rss-channel-items channel)) + (with-json-object () + (encode-object-member "pubDate" (format-date-time (rss-item-pub-date item) :vms-style t)) + (encode-object-member "title" (rss-item-title item)) + (encode-object-member "description" (rss-item-description item)))))))) \ No newline at end of file Modified: trunk/projects/quickhoney/src/image.lisp =================================================================== --- trunk/projects/quickhoney/src/image.lisp 2008-07-30 15:30:19 UTC (rev 3700) +++ trunk/projects/quickhoney/src/image.lisp 2008-07-30 21:06:43 UTC (rev 3701) @@ -8,32 +8,6 @@ (spider-keywords :update :initform nil) (products :update :initform nil))) -(defmethod rss-item-pub-date ((item quickhoney-image)) - (blob-timestamp item)) - -(defmethod quickhoney-image-explicit ((image quickhoney-image)) - (member :explicit (store-image-keywords image))) - -(defmethod rss-item-encoded-content ((image quickhoney-image)) - (let* ((category (first (intersection (store-image-keywords image) '(:vector :pixel)))) - (is-vector (eq category :vector))) - (with-output-to-string (s) - (html-stream - s - ((:div :class (format nil "newsentry news_~(~A~)" category)) - ((:img :src (format nil "http://~A/image/~A/cutout-button,,~A,98,4" - (website-host) - (store-object-id image) - (if is-vector "00ccff" "ff00ff"))) - (:div - (:h1 (:princ (store-image-name image))) - (:princ (format nil "~A by ~A | " - (format-date-time (blob-timestamp image)) - (if is-vector "Peter" "Nana"))) - ((:a :href (make-image-link image)) "permalink"))))) - (when (quickhoney-image-client image) - (html-stream s :br "Client: " (:princ (quickhoney-image-client image))))))) - (defvar *last-image-upload-timestamp* 0) (defmethod initialize-transient-instance :after ((image quickhoney-image)) @@ -48,21 +22,6 @@ (store-object-remove-keywords image 'bknr.web::keywords '(:import))) (get-keywords-intersection-store-images '(:import)))) -(defmethod rss-item-channel ((item quickhoney-image)) - "quickhoney") - -(defmethod rss-item-title ((image quickhoney-image)) - (store-image-name image)) - -(defmethod rss-item-description ((image quickhoney-image)) - (format nil "~A~@[ (Client: ~A)~]" (store-image-name image) (quickhoney-image-client image))) - -(defmethod rss-item-link ((image quickhoney-image)) - (make-image-link image)) - -(defmethod rss-item-guid ((image quickhoney-image)) - (make-image-link image)) - (defmethod quickhoney-image-category ((image quickhoney-image)) (first (intersection (store-image-keywords image) '(:pixel :vector :news :contact)))) @@ -81,27 +40,3 @@ (defmethod destroy-object :before ((image quickhoney-animation-image)) (delete-object (quickhoney-animation-image-animation image))) -(define-persistent-class quickhoney-news-item (quickhoney-image) - ((title :update) - (text :update))) - -(defmethod quickhoney-image-spider-keywords ((item quickhoney-news-item)) - (quickhoney-news-item-title item)) - -(defmethod rss-item-title ((item quickhoney-news-item)) - (quickhoney-news-item-title item)) - -(defmethod rss-item-encoded-content ((item quickhoney-news-item)) - (concatenate 'string - (call-next-method) - (quickhoney-news-item-text item))) - -(defclass quickhoney-rss-channel (rss-channel) - () - (:metaclass persistent-class)) - -(defmethod rss-channel-items ((channel quickhoney-rss-channel) &key) - (remove-if (lambda (item) - (and (typep item 'quickhoney-image) - (quickhoney-image-explicit item))) - (call-next-method))) \ No newline at end of file Added: trunk/projects/quickhoney/src/news.lisp =================================================================== --- trunk/projects/quickhoney/src/news.lisp (rev 0) +++ trunk/projects/quickhoney/src/news.lisp 2008-07-30 21:06:43 UTC (rev 3701) @@ -0,0 +1,68 @@ +(in-package :quickhoney) + +(defmethod rss-item-pub-date ((item quickhoney-image)) + (blob-timestamp item)) + +(defmethod quickhoney-image-explicit ((image quickhoney-image)) + (member :explicit (store-image-keywords image))) + +(defmethod rss-item-encoded-content ((image quickhoney-image)) + (let* ((category (first (intersection (store-image-keywords image) '(:vector :pixel)))) + (is-vector (eq category :vector))) + (with-output-to-string (s) + (html-stream + s + ((:div :class (format nil "newsentry news_~(~A~)" category)) + ((:img :src (format nil "http://~A/image/~A/cutout-button,,~A,98,4" + (website-host) + (store-object-id image) + (if is-vector "00ccff" "ff00ff"))) + (:div + (:h1 (:princ (store-image-name image))) + (:princ (format nil "~A by ~A | " + (format-date-time (blob-timestamp image)) + (if is-vector "Peter" "Nana"))) + ((:a :href (make-image-link image)) "permalink"))))) + (when (quickhoney-image-client image) + (html-stream s :br "Client: " (:princ (quickhoney-image-client image))))))) + +(defmethod rss-item-channel ((item quickhoney-image)) + "quickhoney") + +(defmethod rss-item-title ((image quickhoney-image)) + (store-image-name image)) + +(defmethod rss-item-description ((image quickhoney-image)) + (format nil "~A~@[ (Client: ~A)~]" (store-image-name image) (quickhoney-image-client image))) + +(defmethod rss-item-link ((image quickhoney-image)) + (make-image-link image)) + +(defmethod rss-item-guid ((image quickhoney-image)) + (make-image-link image)) + +(define-persistent-class quickhoney-news-item (quickhoney-image) + ((title :update) + (text :update))) + +(defmethod quickhoney-image-spider-keywords ((item quickhoney-news-item)) + (quickhoney-news-item-title item)) + +(defmethod rss-item-title ((item quickhoney-news-item)) + (quickhoney-news-item-title item)) + +(defmethod rss-item-encoded-content ((item quickhoney-news-item)) + (concatenate 'string + (call-next-method) + (quickhoney-news-item-text item))) + +(defclass quickhoney-rss-channel (rss-channel) + () + (:metaclass persistent-class)) + +(defmethod rss-channel-items ((channel quickhoney-rss-channel) &key) + (remove-if (lambda (item) + (and (typep item 'quickhoney-image) + (quickhoney-image-explicit item))) + (call-next-method))) + Modified: trunk/projects/quickhoney/src/quickhoney.asd =================================================================== --- trunk/projects/quickhoney/src/quickhoney.asd 2008-07-30 15:30:19 UTC (rev 3700) +++ trunk/projects/quickhoney/src/quickhoney.asd 2008-07-30 21:06:43 UTC (rev 3701) @@ -29,6 +29,7 @@ :components ((:file "packages") (:file "config" :depends-on ("packages")) (:file "image" :depends-on ("config")) + (:file "news" :depends-on ("image")) (:file "layout" :depends-on ("config")) (:file "imageproc" :depends-on ("config")) (:file "handlers" :depends-on ("layout" "config" "image")) Modified: trunk/projects/quickhoney/src/webserver.lisp =================================================================== --- trunk/projects/quickhoney/src/webserver.lisp 2008-07-30 15:30:19 UTC (rev 3700) +++ trunk/projects/quickhoney/src/webserver.lisp 2008-07-30 21:06:43 UTC (rev 3701) @@ -33,6 +33,7 @@ ("/admin" admin-handler) ("/upload-news" upload-news-handler) ("/digg-image" digg-image-handler) + ("/news-json" news-json-handler) ("/" template-handler :default-template "frontpage" :destination ,(namestring (merge-pathnames "templates/" *website-directory*))

1 0

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

30 Jul '08

Revision: 3700 Author: ksprotte URL: http://bknr.net/trac/changeset/3700 checkpoint U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/test/poi.lisp Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-30 14:34:52 UTC (rev 3699) +++ trunk/projects/bos/m2/poi.lisp 2008-07-30 15:30:19 UTC (rev 3700) @@ -197,3 +197,15 @@ (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))) + +(defun pois-sanity-check () + (labels ((poi-sanity-check (poi) + (dolist (medium (poi-media poi)) + (unless (eq poi (poi-medium-poi medium)) + (warn "~s does not point to ~s" medium poi))) + (dolist (movie (poi-movies poi)) + (unless (stringp (poi-movie-url movie)) + (warn "~s has a url of ~s" movie (poi-movie-url movie)))))) + (mapc #'poi-sanity-check (class-instances 'poi)) + (values))) + Modified: trunk/projects/bos/test/poi.lisp =================================================================== --- trunk/projects/bos/test/poi.lisp 2008-07-30 14:34:52 UTC (rev 3699) +++ trunk/projects/bos/test/poi.lisp 2008-07-30 15:30:19 UTC (rev 3700) @@ -40,20 +40,20 @@ (is (string= "a subtitle" (slot-string poi2 'subtitle "de"))) (is (string= "a description" (slot-string poi2 'description "de")))))) -(defun test-make-poi-javascript () +(defun finishes-make-poi-javascript () (dolist (language '("de" "en" "da")) (finishes (make-poi-javascript language)))) (test make-poi-javascript (with-fixture initial-bos-store () - (test-make-poi-javascript) + (finishes-make-poi-javascript) (make-poi "turm" :area (list 50 60)) - (test-make-poi-javascript) + (finishes-make-poi-javascript) (make-poi "brunnen" :language "de" :title "a title" :subtitle "a subtitle" :description "a description") - (test-make-poi-javascript))) + (finishes-make-poi-javascript))) (test make-poi-image (with-fixture initial-bos-store () @@ -71,4 +71,4 @@ (is (= 120 (store-image-height (first (poi-media poi))))) (let ((medium (first (poi-media poi)))) (is (eq poi (poi-medium-poi medium)))) - (test-make-poi-javascript)))) + (finishes-make-poi-javascript))))

1 0

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

30 Jul '08

Revision: 3699 Author: ksprotte URL: http://bknr.net/trac/changeset/3699 finished m2 poi schema U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/test/poi.lisp U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-30 13:44:57 UTC (rev 3698) +++ trunk/projects/bos/m2/poi.lisp 2008-07-30 14:34:52 UTC (rev 3699) @@ -16,6 +16,13 @@ (description :initform (make-string-hash-table) :documentation "beschreibungstext"))) +(defmethod initialize-persistent-instance :after ((obj textual-attributes-mixin) + &key language title subtitle description) + (update-textual-attributes obj language + :title title + :subtitle subtitle + :description description)) + (deftransaction update-textual-attributes (obj language &key title subtitle description) (when title (setf (slot-string obj 'title language) title)) @@ -36,13 +43,9 @@ 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-persistent-instance :after ((poi-medium poi-medium) &key poi) (when poi - (push poi-medium (poi-media poi))) - (update-textual-attributes poi-medium language - :title title - :subtitle subtitle - :description description)) + (push poi-medium (poi-media poi)))) (defmethod print-object ((object poi-medium) stream) (print-unreadable-object (object stream :type t :identity nil) @@ -70,7 +73,7 @@ ((url :accessor poi-movie-url :initarg :url :initform nil))) ;;; poi -(defpersistent-class poi (textual-attributes-mixin) +(defpersistent-class poi (textual-attributes-mixin) ((name :reader poi-name :initarg :name :index-type string-unique-index @@ -89,18 +92,13 @@ :accessor poi-media :initarg :media :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))) - (setf (slot-string poi 'title language) title) - (setf (slot-string poi 'description language) description) - poi)) +(deftransaction make-poi (name &rest rest &key area language title subtitle description) + (declare (ignore area)) + (assert (if (or title subtitle description) language t) nil + "language needs to be specified, if any of title, subtitle + or description is given") + (apply #'make-object 'poi :name name rest)) -(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))) Modified: trunk/projects/bos/test/poi.lisp =================================================================== --- trunk/projects/bos/test/poi.lisp 2008-07-30 13:44:57 UTC (rev 3698) +++ trunk/projects/bos/test/poi.lisp 2008-07-30 14:34:52 UTC (rev 3699) @@ -8,3 +8,67 @@ (is (string= "a title" (slot-string medium 'title "de")))) (signals (error) (make-poi-medium 'poi-medium :title "a title")))) +(test make-poi-medium.with-poi + (with-fixture initial-bos-store () + (let* ((poi (make-poi "turm")) + (medium (make-poi-medium 'poi-medium :language "de" + :title "a title" + :poi poi))) + (is (eq poi (poi-medium-poi medium))) + (is (member medium (poi-media poi)))))) + +(test make-poi + (with-fixture initial-bos-store () + (let ((poi (make-poi "turm" :area (list 50 60)))) + (is (string= "turm" (poi-name poi))) + (is (= 50 (poi-center-x poi))) + (is (= 60 (poi-center-y poi))) + (is (string= "" (slot-string poi 'title "de"))) + (is (string= "" (slot-string poi 'subtitle "de"))) + (is (string= "" (slot-string poi 'description "de"))) + (is (null (poi-images poi))) + (is (null (poi-airals poi))) + (is (null (poi-panoramas poi))) + (is (null (poi-movies poi)))) + (signals (error) (make-poi "brunnen" :title "title")) + (let ((poi2 (make-poi "brunnen" :language "de" + :title "a title" + :subtitle "a subtitle" + :description "a description"))) + (is (string= "brunnen" (poi-name poi2))) + (is (string= "a title" (slot-string poi2 'title "de"))) + (is (string= "a subtitle" (slot-string poi2 'subtitle "de"))) + (is (string= "a description" (slot-string poi2 'description "de")))))) + +(defun test-make-poi-javascript () + (dolist (language '("de" "en" "da")) + (finishes (make-poi-javascript language)))) + +(test make-poi-javascript + (with-fixture initial-bos-store () + (test-make-poi-javascript) + (make-poi "turm" :area (list 50 60)) + (test-make-poi-javascript) + (make-poi "brunnen" :language "de" + :title "a title" + :subtitle "a subtitle" + :description "a description") + (test-make-poi-javascript))) + +(test make-poi-image + (with-fixture initial-bos-store () + + (let ((test-image-path (merge-pathnames "test.png" (bknr.datastore::store-directory *store*))) + (poi (make-poi "turm"))) + (cl-gd:with-image* (100 120 t) + (cl-gd:write-image-to-file test-image-path)) + (is (null (poi-media poi))) + (import-image test-image-path :class-name 'poi-image + :initargs `(:poi ,poi :language "de" :title "a title")) + (is (poi-media poi)) + (is (string= "a title" (slot-string (first (poi-media poi)) 'title "de"))) + (is (= 100 (store-image-width (first (poi-media poi))))) + (is (= 120 (store-image-height (first (poi-media poi))))) + (let ((medium (first (poi-media poi)))) + (is (eq poi (poi-medium-poi medium)))) + (test-make-poi-javascript)))) Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-30 13:44:57 UTC (rev 3698) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-30 14:34:52 UTC (rev 3699) @@ -17,7 +17,7 @@ (html (:h2 "Bad technical name") "Please use only alphanumerical characters, - and _ for technical POI names"))) (t - (redirect (edit-object-url (make-poi (request-language) name))))))) + (redirect (edit-object-url (make-poi name))))))) (defclass edit-poi-handler (editor-only-handler edit-object-handler) ()

1 0

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

30 Jul '08

Revision: 3698 Author: hans URL: http://bknr.net/trac/changeset/3698 back out changeset 3682, too - this needs more thought 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-30 13:23:06 UTC (rev 3697) +++ trunk/bknr/datastore/src/data/object-tests.lisp 2008-07-30 13:44:57 UTC (rev 3698) @@ -45,25 +45,22 @@ (call-next-method) (close-store))) -(defvar *tests* (make-hash-table)) - (defmacro define-datastore-test (name &rest body) - `(setf (gethash ,name *tests*) - (make-instance 'datastore-test-class - :unit :datastore - :name ,name - :body (lambda () - ,@body)))) + `(make-instance 'datastore-test-class + :unit :datastore + :name ,name + :body (lambda () + ,@body))) -(define-datastore-test :store-setup +(define-datastore-test "Datastore 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) @@ -71,7 +68,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) @@ -83,23 +80,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-restore-multiple-objects +(define-datastore-test "Snapshot and Restore multiple objects" (dotimes (i 10) (make-object 'store-object)) (snapshot) (restore) @@ -107,7 +104,7 @@ (defconstant +stress-size+ 10000) -(define-datastore-test :stress-test +(define-datastore-test "Stress test object creation" (format t "Creating ~a objects~%" +stress-size+) (time (bknr.datastore::without-sync () (dotimes (i +stress-size+) @@ -124,19 +121,10 @@ (define-persistent-class child () ()) -(define-datastore-test :serialize-circular-in-anon-txn +(define-datastore-test "Serialize circular dependency in anonymous 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)))))) - -(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 + (class-of (parent-child (first (class-instances 'parent)))))) \ No newline at end of file Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-30 13:23:06 UTC (rev 3697) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-30 13:44:57 UTC (rev 3698) @@ -96,11 +96,11 @@ (defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd) (when (in-anonymous-transaction-p) - (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*)))) + (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*)))) (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) - (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*))) + (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*))) (call-next-method))) (defmethod initialize-instance :after ((object store-object) &key id &allow-other-keys) @@ -661,8 +661,7 @@ (destroy-object (store-object-with-id id))) (defun delete-object (object) - (if (and (in-transaction-p) - (not (in-anonymous-transaction-p))) + (if (in-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-30 13:23:06 UTC (rev 3697) +++ trunk/bknr/datastore/src/data/txn.lisp 2008-07-30 13:44:57 UTC (rev 3698) @@ -10,67 +10,13 @@ (define-condition not-in-transaction (error) () (:documentation - "Signaled when an operation on persistent slots is executed outside - a transaction context")) + "Thrown when an operation on persistent slots is executed outside a transaction context")) (define-condition store-not-open (error) () (:documentation - "Signaled when a transaction is executed on a store that is not - opened")) + "Thrown 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*) @@ -128,7 +74,7 @@ (restart-case (when (and (boundp '*store*) *store*) - (error 'store-already-open)) + (error "A store is already opened.")) (close-store () :report "Close the opened store." (close-store))))) @@ -207,7 +153,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 @@ -299,7 +245,7 @@ (defun store-current-transaction () (if (in-transaction-p) *current-transaction* - (error 'not-in-transaction))) + (error "store-current-transaction called outside of a transaction"))) ;;; All transactions are executed by an 'executor', which is the store ;;; itself or, in the case of a nested transaction, the parent @@ -316,7 +262,7 @@ (defmethod execute-transaction :before (executor transaction) (unless (store-open-p) - (error 'store-not-open))) + (error (make-condition 'store-not-open)))) (defmethod execute-transaction ((executor transaction) transaction) (execute-unlogged transaction)) @@ -371,7 +317,7 @@ (&optional) (&rest (setf args (cdr args))) ; skip argument, too (&key (setf in-keywords-p t)) - (otherwise (error 'unsupported-lambda-list-option :option arg)))) + (otherwise (error "unsupported lambda list option ~A in DEFTRANSACTION" arg)))) (t (when in-keywords-p (push (intern (symbol-name arg) :keyword) result)) @@ -389,7 +335,7 @@ (body body)) (dolist (arg args) (when (listp arg) - (error 'default-arguments-unsupported :tx-name name :argument (car arg)))) + (error "can't have argument defaults in transaction declaration for transaction ~A, please implement a wrapper" name))) (let ((tx-name (intern (format nil "TX-~A" name) (symbol-package name)))) `(progn @@ -462,8 +408,8 @@ (with-store-guard () (let ((*current-transaction* transaction)) (apply (or (symbol-function (transaction-function-symbol transaction)) - (error 'undefined-transaction - :tx-name (transaction-function-symbol transaction))) + (error "Undefined transaction function ~A, please ensure that all the necessary code is loaded." + (transaction-function-symbol transaction))) (transaction-args transaction))))) (defun fsync (stream) @@ -490,7 +436,7 @@ (check-type transaction symbol) ; otherwise care for multiple evaluation `(with-store-guard () (when (in-transaction-p) - (error 'invalid-transaction-nesting)) + (error "can't open nested with-transaction-log blocks")) (with-store-state (:transaction) (prog1 (let ((*current-transaction* ,transaction)) @@ -526,54 +472,61 @@ ;;; The actual writing to the transaction log is performed by the ;;; with-transaction macro. -;;; An anonymous transaction has a label which is stored in the -;;; transaction log in order to make the source code location where +;;; An anonymous transaction has an optional 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 - :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)))) + ((label :initarg :label :accessor anonymous-transaction-label) + (transactions :initarg :transactions :accessor anonymous-transaction-transactions)) + (:default-initargs :transactions nil :label nil)) (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) - (class-name (class-of (anonymous-transaction-log-buffer transaction)))))) + (anonymous-transaction-transactions transaction)))) (defmethod in-anonymous-transaction-p () (subtypep (type-of *current-transaction*) 'anonymous-transaction)) (defmethod encode-object ((transaction anonymous-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))) + (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)) +(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) - (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)))) + ;; 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. + ;; 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 'anonymous-transaction-in-named-transaction)) + (error "tried to start anonymous transaction while in a transaction")) (let ((,txn (make-instance 'anonymous-transaction :label ,(if (symbolp label) (symbol-name label) label)))) (with-transaction-log (,txn) ,@body))))) @@ -584,14 +537,15 @@ ;; 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 ((stream (anonymous-transaction-log-buffer transaction))) - (handler-case - (loop - (execute-unlogged (decode stream))) - (end-of-file ())))) + (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*)))))) -(defmethod execute-transaction :before ((executor anonymous-transaction) transaction) - (encode transaction (anonymous-transaction-log-buffer executor))) +(defmethod execute-transaction :after ((executor anonymous-transaction) transaction) + (push transaction (anonymous-transaction-transactions executor))) ;;; Subsystems @@ -617,9 +571,9 @@ (defmethod snapshot-store ((store store)) (unless (store-open-p) - (error 'store-not-open)) + (error (make-condition 'store-not-open))) (when (null (store-subsystems store)) - (error 'no-subsystems)) + (error "Cannot snapshot store without subsystems...")) (ensure-store-current-directory store) (with-store-state (:read-only store) (with-store-guard ()

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/test/poi.lisp
by BKNR Commits 30 Jul '08

30 Jul '08

Revision: 3697 Author: ksprotte URL: http://bknr.net/trac/changeset/3697 forgot to check in test/poi.lisp A trunk/projects/bos/test/poi.lisp Added: trunk/projects/bos/test/poi.lisp =================================================================== --- trunk/projects/bos/test/poi.lisp (rev 0) +++ trunk/projects/bos/test/poi.lisp 2008-07-30 13:23:06 UTC (rev 3697) @@ -0,0 +1,10 @@ +(in-package :bos.test) +(in-suite :bos.test.poi) + +(test make-poi-medium.without-poi + (with-fixture initial-bos-store () + (let ((medium (make-poi-medium 'poi-medium :language "de" + :title "a title"))) + (is (string= "a title" (slot-string medium 'title "de")))) + (signals (error) (make-poi-medium 'poi-medium :title "a title")))) +

1 0

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

30 Jul '08

Revision: 3696 Author: ksprotte URL: http://bknr.net/trac/changeset/3696 made print-object (m2 t) more robust wrt unbound slots U trunk/projects/bos/m2/m2.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-30 13:18:21 UTC (rev 3695) +++ trunk/projects/bos/m2/m2.lisp 2008-07-30 13:22:08 UTC (rev 3696) @@ -38,12 +38,17 @@ :tile-size +m2tile-width+ :tile-class 'image-tile)))) -(defmethod print-object ((object m2) stream) - (print-unreadable-object (object stream :type t :identity nil) - (format stream "at (~D,~D), ~A" - (m2-x object) - (m2-y object) - (if (m2-contract object) "sold" "free")))) +(defmethod print-object ((m2 m2) stream) + (if (and (slot-boundp m2 'x) + (slot-boundp m2 'y) + (slot-boundp m2 'contract)) + (print-unreadable-object (m2 stream :type t :identity nil) + (format stream "at (~D,~D), ~A" + (m2-x m2) + (m2-y m2) + (if (m2-contract m2) "sold" "free"))) + (print-unreadable-object (m2 stream :type t :identity t) + (format stream "(unbound slots)")))) (defun get-m2 (&rest coords) (m2-at coords))

1 0

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

30 Jul '08

Revision: 3695 Author: ksprotte URL: http://bknr.net/trac/changeset/3695 working on new m2 poi schema; cleaned up exprted poi symbols U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/test/bos.test.asd U trunk/projects/bos/test/suites.lisp Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-30 11:21:33 UTC (rev 3694) +++ trunk/projects/bos/m2/packages.lisp 2008-07-30 13:18:21 UTC (rev 3695) @@ -200,47 +200,40 @@ #:allocation-area-percent-used #:left #:top #:width #:height #:active-p - ;; pois - #:*current-language* + ;; slot-strings #:slot-string #:set-slot-string-values - + + ;; pois + #:title #:subtitle #:description ; for slot-string access + #:update-textual-attributes + #:poi-medium + #:poi-medium-poi + #:make-poi-medium #:poi-image - #:poi-image-poi - #:poi-image-title - #:poi-image-subtitle - #:poi-image-description - #:poi-airals - #:airals - #:poi-panoramas - #:panoramas - #:poi-movies - #:movies + #:poi-airal + #:poi-panorama #:poi-movie - #:poi-movie-poi #:poi-movie-url - #:make-poi-image - #:update-poi-image #:poi #:poi-name + #:find-poi + #:all-pois #:poi-published - #:poi-title - #:poi-subtitle - #:poi-description #:poi-area #:poi-icon - #:poi-images - #:poi-complete - #:title #:subtitle #:description ; for slot-string access + #:poi-media #:make-poi - #:update-poi - #:find-poi - + #:poi-complete #:poi-center-x #:poi-center-y #:poi-center-lon-lat + #:poi-images + #:poi-airals + #:poi-panoramas + #:poi-movies #:make-poi-javascript - + ;; news #:news-item #:make-news-item Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-30 11:21:33 UTC (rev 3694) +++ trunk/projects/bos/m2/poi.lisp 2008-07-30 13:18:21 UTC (rev 3695) @@ -8,13 +8,13 @@ ;;; POI-Anwendungsklassen und Konstruktoren ;;; textual-attributes-mixin -(define-persistent-class textual-attributes-mixin () - ((title :update :initform (make-string-hash-table) - :documentation "Angezeigter Name") - (subtitle :update :initform (make-string-hash-table) - :documentation "Unterschrift") - (description :update :initform (make-string-hash-table) - :documentation "Beschreibungstext"))) +(defpersistent-class textual-attributes-mixin () + ((title :initform (make-string-hash-table) + :documentation "angezeigter name") + (subtitle :initform (make-string-hash-table) + :documentation "unterschrift") + (description :initform (make-string-hash-table) + :documentation "beschreibungstext"))) (deftransaction update-textual-attributes (obj language &key title subtitle description) (when title @@ -22,11 +22,12 @@ (when subtitle (setf (slot-string obj 'subtitle language) subtitle)) (when description - (setf (slot-string obj 'description language) description))) + (setf (slot-string obj 'description language) description)) + obj) ;;; poi-medium -(define-persistent-class poi-medium (textual-attributes-mixin) - ((poi :read))) +(defpersistent-class poi-medium (textual-attributes-mixin) + ((poi :reader poi-medium-poi :initarg :poi))) (deftransaction make-poi-medium (class-name &rest rest &key language title subtitle description poi initargs) (declare (ignore poi initargs)) @@ -53,30 +54,40 @@ (setf (poi-media poi) (remove poi-medium (poi-media poi)))))) ;;; poi-image -(define-persistent-class poi-image (store-image poi-medium) +(defpersistent-class poi-image (store-image poi-medium) ()) ;;; poi-airal -(define-persistent-class poi-airal (store-image poi-medium) +(defpersistent-class poi-airal (store-image poi-medium) ()) ;;; poi-panorama -(define-persistent-class poi-panorama (store-image poi-medium) +(defpersistent-class poi-panorama (store-image poi-medium) ()) ;;; poi-movie -(define-persistent-class poi-movie (poi-medium) - ((url :update :initform nil))) +(defpersistent-class poi-movie (poi-medium) + ((url :accessor poi-movie-url :initarg :url :initform nil))) ;;; poi -(define-persistent-class poi (textual-attributes-mixin) - ((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") - (area :update :initform nil :documentation "Polygon mit den POI-Koordinaten") - (icon :update :initform "palme" :documentation "Name des Icons") - (media :update :initform nil :documentation "Liste aller POI-Medien, wie POI-IMAGE, POI-AIRAL ..."))) +(defpersistent-class poi (textual-attributes-mixin) + ((name + :reader poi-name :initarg :name + :index-type string-unique-index + :index-reader find-poi :index-values all-pois + :documentation "symbolischer name") + (published + :accessor poi-published :initarg :published :initform nil + :documentation "wenn dieses flag nil ist, wird der poi in den uis nicht angezeigt") + (area + :accessor poi-area :initarg :area :initform nil + :documentation "polygon mit den poi-koordinaten") + (icon + :accessor poi-icon :initarg :icon :initform "palme" + :documentation "name des icons") + (media + :accessor poi-media :initarg :media :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))) Modified: trunk/projects/bos/test/bos.test.asd =================================================================== --- trunk/projects/bos/test/bos.test.asd 2008-07-30 11:21:33 UTC (rev 3694) +++ trunk/projects/bos/test/bos.test.asd 2008-07-30 13:18:21 UTC (rev 3695) @@ -1,18 +1,20 @@ - (in-package :cl-user) +;; -*- Lisp -*- +(in-package :cl-user) - (asdf:defsystem :bos.test - :description "BOS Online-System test-suite" - :depends-on (:bos.web :fiveam :drakma) - :components ((:file "package") - (:file "suites" :depends-on ("package")) - (:file "fixtures" :depends-on ("package")) - (:file "allocation" :depends-on ("suites" "fixtures")) - (:file "geometry" :depends-on ("suites")) - (:file "geo-utm" :depends-on ("suites")) - ;; (:file "utils" :depends-on ("config")) - (:module :web - :depends-on ("suites" "fixtures") - :components - ((:file "drakma-requests") - (:file "quad-tree") - (:file "sat-tree"))))) +(asdf:defsystem :bos.test + :description "BOS Online-System test-suite" + :depends-on (:bos.web :fiveam :drakma) + :components ((:file "package") + (:file "suites" :depends-on ("package")) + (:file "fixtures" :depends-on ("package")) + (:file "allocation" :depends-on ("suites" "fixtures")) + (:file "geometry" :depends-on ("suites")) + (:file "geo-utm" :depends-on ("suites")) + (:file "poi" :depends-on ("suites")) + ;; (:file "utils" :depends-on ("config")) + (:module :web + :depends-on ("suites" "fixtures") + :components + ((:file "drakma-requests") + (:file "quad-tree") + (:file "sat-tree"))))) Modified: trunk/projects/bos/test/suites.lisp =================================================================== --- trunk/projects/bos/test/suites.lisp 2008-07-30 11:21:33 UTC (rev 3694) +++ trunk/projects/bos/test/suites.lisp 2008-07-30 13:18:21 UTC (rev 3695) @@ -7,6 +7,9 @@ :in :bos.test :description "Tests for everything about allocation, including the allocation-cache.") +(def-suite :bos.test.poi + :in :bos.test) + (def-suite :bos.test.geometry :in :bos.test :description "Tests for the small geometry helper package.")

1 0

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

30 Jul '08

Revision: 3694 Author: hans URL: http://bknr.net/trac/changeset/3694 back out 3685-3692, that was too much to swallow U trunk/bknr/datastore/src/data/object-tests.lisp 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/build.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-tests.lisp =================================================================== --- trunk/bknr/datastore/src/data/object-tests.lisp 2008-07-30 11:17:36 UTC (rev 3693) +++ trunk/bknr/datastore/src/data/object-tests.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -47,7 +47,7 @@ (defvar *tests* (make-hash-table)) -(defmacro define-datastore-test (name &body body) +(defmacro define-datastore-test (name &rest body) `(setf (gethash ,name *tests*) (make-instance 'datastore-test-class :unit :datastore @@ -118,14 +118,6 @@ (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))) Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-30 11:17:36 UTC (rev 3693) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -91,7 +91,7 @@ slot-name object)) (when (and (persistent-slot-p slotd) (not (eq :restore (store-state *store*))) - (not (member slot-name '(last-change id)))) + (not (eq 'last-change slot-name))) (setf (slot-value object 'last-change) (current-transaction-timestamp))))) (defmethod (setf slot-value-using-class) :after (newval (class persistent-class) object slotd) @@ -190,32 +190,36 @@ #+allegro (aclmop::finalize-inheritance (find-class 'store-object)) -(defmethod initialize-instance :around ((object store-object) &rest initargs &key) +(defmethod initialize-instance :around + ((object store-object) &key &allow-other-keys) (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)) initargs)) + :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 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 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 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)))) @@ -240,13 +244,19 @@ :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 after a persistent object has been initialized, also -when the object is loaded from a snapshot, but before reading the -transaction log.")) +method is called whenever a persistent object is initialized, also +when the object is loaded from a snapshot.")) +(defmethod initialize-persistent-instance ((object store-object) &key)) (defmethod initialize-transient-instance ((object store-object))) (defmethod store-object-persistent-slots ((object store-object)) @@ -454,11 +464,7 @@ ;; 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)) - (index-add index object))))))) + (make-instance class :id object-id))))) (defun snapshot-read-slots (stream layouts) (let* ((layout-id (%decode-integer stream)) @@ -635,21 +641,21 @@ (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." - (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)))))) + "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))))) (defun tx-delete-object (id) (destroy-object (store-object-with-id id))) Modified: trunk/bknr/datastore/src/data/package.lisp =================================================================== --- trunk/bknr/datastore/src/data/package.lisp 2008-07-30 11:17:36 UTC (rev 3693) +++ trunk/bknr/datastore/src/data/package.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -51,6 +51,7 @@ #: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 11:17:36 UTC (rev 3693) +++ trunk/bknr/datastore/src/data/tutorial.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -458,13 +458,14 @@ ;;; 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-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 +;;; 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 ;;; to the snapshot file) of a persistent object. ;;; ;;; We can define the following class with a transient and a @@ -815,7 +816,9 @@ ;;; 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. +;;; 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. ;;;## Garbage collecting blobs Modified: trunk/bknr/modules/feed/feed.lisp =================================================================== --- trunk/bknr/modules/feed/feed.lisp 2008-07-30 11:17:36 UTC (rev 3693) +++ trunk/bknr/modules/feed/feed.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -24,6 +24,9 @@ (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 11:17:36 UTC (rev 3693) +++ trunk/bknr/modules/text/article.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -36,7 +36,7 @@ (article-subject article) " " (article-text article)))) -(defmethod initialize-instance :after ((article article) &key) +(defmethod initialize-persistent-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 11:17:36 UTC (rev 3693) +++ trunk/bknr/web/src/rss/rss.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -176,7 +176,7 @@ (:method ((channel (eql nil)) item) (warn "no RSS channel defined for item ~A" item))) -(defmethod initialize-instance :after ((rss-item rss-item) &key) +(defmethod initialize-persistent-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 11:17:36 UTC (rev 3693) +++ trunk/bknr/web/src/sysclasses/user.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -60,7 +60,7 @@ (user-login object) "unbound")))) -(defmethod initialize-instance ((user user) &key) +(defmethod initialize-persistent-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-instance ((user smb-user) &key) +(defmethod initialize-persistent-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/build.lisp =================================================================== --- trunk/build.lisp 2008-07-30 11:17:36 UTC (rev 3693) +++ trunk/build.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -191,21 +191,21 @@ (zerop (nth-value 8 (5am::partition-results results))))) (defun test () - (cl-gd::load-gd-glue) + (cl-gd::load-gd-glue) (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) + )) Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-30 11:17:36 UTC (rev 3693) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -34,7 +34,7 @@ :unbound) (store-object-id allocation-area)))) -(defmethod initialize-instance :after ((allocation-area allocation-area) &key) +(defmethod initialize-persistent-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 11:17:36 UTC (rev 3693) +++ trunk/projects/bos/m2/m2.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -278,7 +278,7 @@ (defun contract-p (object) (equal (class-of object) (find-class 'contract))) -(defmethod initialize-instance :after ((contract contract) &key) +(defmethod initialize-persistent-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 11:17:36 UTC (rev 3693) +++ trunk/projects/bos/m2/poi.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -35,7 +35,7 @@ or description is given") (apply #'make-object class-name rest)) -(defmethod initialize-instance :after ((poi-medium poi-medium) &key language title subtitle description poi) +(defmethod initialize-persistent-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-instance :after ((poi poi) &key language title subtitle description) +(defmethod initialize-persistent-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 11:17:36 UTC (rev 3693) +++ trunk/projects/lisp-ecoop/src/participant.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -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-instance :after ((document document) &key) +(defmethod initialize-persistent-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-instance :after ((participant participant) &key) +(defmethod initialize-persistent-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 11:17:36 UTC (rev 3693) +++ trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -88,7 +88,7 @@ ((device :initarg :device :reader bluetooth-event-device)) (:metaclass persistent-class)) -(defmethod initialize-instance :after ((event bluetooth-event) &key) +(defmethod initialize-persistent-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 11:17:36 UTC (rev 3693) +++ trunk/projects/unmaintained/raw-data/mcp/sensors.lisp 2008-07-30 11:21:33 UTC (rev 3694) @@ -60,7 +60,7 @@ (defmethod sample-event-table-name ((sensor sensor)) (format nil "sample_event_~(~A~)" (sensor-type sensor))) -(defmethod initialize-instance :after ((sensor sensor) &key) +(defmethod initialize-persistent-instance :after ((sensor sensor) &key) (let ((id (store-object-id sensor))) (with-slots (name unit type) sensor (postgres-execute

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