[bknr-cvs] ksprotte changed trunk/

BKNR Commits bknr at bknr.net
Tue Jul 29 12:56:24 UTC 2008


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)




More information about the Bknr-cvs mailing list