Revision: 3680 Author: ksprotte URL: http://bknr.net/trac/changeset/3680

add &allow-other-keys to initialize-persistent-instance for now U trunk/bknr/datastore/src/data/object.lisp U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/m2/slot-strings.lisp

Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-29 12:30:55 UTC (rev 3679) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-29 12:56:24 UTC (rev 3680) @@ -244,7 +244,7 @@ :timestamp (get-universal-time) :args (append (list object (if (symbolp class) class (class-name class))) args))))

-(defgeneric initialize-persistent-instance (store-object &key) +(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

Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-29 12:30:55 UTC (rev 3679) +++ trunk/projects/bos/m2/poi.lisp 2008-07-29 12:56:24 UTC (rev 3680) @@ -7,68 +7,69 @@

;;; POI-Anwendungsklassen und Konstruktoren

-;;; poi-image -(define-persistent-class poi-image (store-image) - ((poi :read) - (title :update :initform (make-string-hash-table)) - (subtitle :update :initform (make-string-hash-table)) - (description :update :initform (make-string-hash-table)))) +;;; 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")))

-(defmethod print-object ((object poi-image) stream) +(deftransaction update-textual-attributes (obj language &key title subtitle description) + (when title + (setf (slot-string obj 'title language) title)) + (when subtitle + (setf (slot-string obj 'subtitle language) subtitle)) + (when description + (setf (slot-string obj 'description language) description))) + +;;; poi-medium +(define-persistent-class poi-medium (textual-attributes-mixin) + ((poi :read))) + +(deftransaction make-poi-medium (class-name &key language title subtitle description 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)) + +(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))))) + +(defmethod print-object ((object poi-medium) stream) (print-unreadable-object (object stream :type t :identity nil) (format stream "~D" (store-object-id object))))

-(deftransaction make-poi-image (language &key title subtitle description poi) - (let ((poi-image (make-object 'poi-image :poi poi))) - (setf (slot-string poi-image 'title language) title) - (setf (slot-string poi-image 'subtitle language) subtitle) - (setf (slot-string poi-image 'description language) description) - poi-image)) - -(defmethod destroy-object :before ((poi-image poi-image)) - (with-slots (poi) poi-image +(defmethod destroy-object :before ((poi-medium poi-medium)) + (with-slots (poi) poi-medium (when poi - (setf (poi-images poi) (remove poi-image (poi-images poi)))))) + (setf (poi-media poi) (remove poi-medium (poi-media poi))))))

-(defmethod initialize-persistent-instance :after ((poi-image poi-image) &key) - (setf (poi-images (poi-image-poi poi-image)) (append (poi-images (poi-image-poi poi-image)) (list poi-image)))) +;;; poi-image +(define-persistent-class poi-image (store-image poi-medium) + ())

-(deftransaction update-poi-image (poi-image language - &key title subtitle description) - (when title - (setf (slot-string poi-image 'title language) title)) - (when subtitle - (setf (slot-string poi-image 'subtitle language) subtitle)) - (when description - (setf (slot-string poi-image 'description language) description))) - ;;; poi-movie -(define-persistent-class poi-movie () - ((poi :read) - (url :update :initform nil))) +(define-persistent-class poi-movie (poi-medium) + ((url :update :initform nil)))

;;; poi -(define-persistent-class 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") - (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") + (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") - (medias :update :initform nil))) + (media :update :initform nil)))

-(defmethod poi-movies :before ((poi poi)) - "Lazily update the db schema. Method can be removed later." - (macrolet ((movie (tail) `(car ,tail))) - (mapl (lambda (tail) - (when (stringp (movie tail)) - (setf (movie tail) - (make-object 'poi-movie :poi poi :url (movie tail))))) - (slot-value poi 'movies)))) - (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) @@ -76,32 +77,14 @@ poi))

(defmethod destroy-object :before ((poi poi)) - (mapc #'delete-object (poi-images 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-images poi) + (poi-area poi) + (<= 6 (count-if (lambda (medium) (typep medium 'poi-image)) (poi-media poi))) t))

-(defun update-poi (poi language &key title subtitle description area icon published (images :not-set) (movies :not-set)) - (with-transaction () - (setf (slot-value poi 'published) published) - (when title - (setf (slot-string poi 'title language) title)) - (when subtitle - (setf (slot-string poi 'subtitle language) subtitle)) - (when description - (setf (slot-string poi 'description language) description)) - (when area - (setf (poi-area poi) area)) - (when icon - (setf (poi-icon poi) icon)) - (when (listp images) - (setf (poi-images poi) images)) - (when (listp movies) - (setf (poi-movies poi) movies)))) - (defmethod poi-center-x ((poi poi)) (first (poi-area poi)))

Modified: trunk/projects/bos/m2/slot-strings.lisp =================================================================== --- trunk/projects/bos/m2/slot-strings.lisp 2008-07-29 12:30:55 UTC (rev 3679) +++ trunk/projects/bos/m2/slot-strings.lisp 2008-07-29 12:56:24 UTC (rev 3680) @@ -17,7 +17,8 @@

(defun set-slot-string (object slot-name language new-value) (unless (in-transaction-p) - (error "attempt to set string in multi-language string slot ~a of object ~a outside of transaction" slot-name object)) + (error "attempt to set string in multi-language string slot ~a of ~ + object ~a outside of transaction" slot-name object)) (setf (gethash language (slot-value object slot-name)) new-value))

(defsetf slot-string set-slot-string)