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) ()