bknr-cvs

bknr-cvs@common-lisp.net

1964 discussions

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

29 Jul '08

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)

1 0

[bknr-cvs] hans changed trunk/projects/bos/m2/poi.lisp
by BKNR Commits 29 Jul '08

29 Jul '08

Revision: 3679 Author: hans URL: http://bknr.net/trac/changeset/3679 Remove accidentially duplicated slot PUBLISHED from POI U trunk/projects/bos/m2/poi.lisp Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-29 12:21:03 UTC (rev 3678) +++ trunk/projects/bos/m2/poi.lisp 2008-07-29 12:30:55 UTC (rev 3679) @@ -49,11 +49,10 @@ ;;; poi (define-persistent-class poi () - ((published :update :initform nil) - (name :read :index-type string-unique-index + ((name :read :index-type string-unique-index :index-reader find-poi :index-values all-pois :documentation "Symbolischer Name") - (published :update :initform nil) + (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")

1 0

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

29 Jul '08

Revision: 3678 Author: hans URL: http://bknr.net/trac/changeset/3678 Fix a few more methods for INITIALIZE-PERSISTENT-INSTANCE to include &KEY. U trunk/bknr/modules/text/article.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/modules/text/article.lisp =================================================================== --- trunk/bknr/modules/text/article.lisp 2008-07-29 12:13:33 UTC (rev 3677) +++ trunk/bknr/modules/text/article.lisp 2008-07-29 12:21:03 UTC (rev 3678) @@ -36,7 +36,7 @@ (article-subject article) " " (article-text article)))) -(defmethod initialize-persistent-instance :after ((article article)) +(defmethod initialize-persistent-instance :after ((article article) &key) (setf (article-search-vector article) (article-to-search-vector article))) Modified: trunk/projects/lisp-ecoop/src/participant.lisp =================================================================== --- trunk/projects/lisp-ecoop/src/participant.lisp 2008-07-29 12:13:33 UTC (rev 3677) +++ trunk/projects/lisp-ecoop/src/participant.lisp 2008-07-29 12:21:03 UTC (rev 3678) @@ -7,7 +7,7 @@ (submission :read :documentation "Submission that this document belongs to")) (:default-initargs :type "application/pdf" :submission (error ":submission argument missing while creating document"))) -(defmethod initialize-persistent-instance :after ((document document)) +(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-persistent-instance :after ((participant participant)) +(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-29 12:13:33 UTC (rev 3677) +++ trunk/projects/unmaintained/raw-data/mcp/bluetooth.lisp 2008-07-29 12:21:03 UTC (rev 3678) @@ -88,7 +88,7 @@ ((device :initarg :device :reader bluetooth-event-device)) (:metaclass persistent-class)) -(defmethod initialize-persistent-instance :after ((event bluetooth-event)) +(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-29 12:13:33 UTC (rev 3677) +++ trunk/projects/unmaintained/raw-data/mcp/sensors.lisp 2008-07-29 12:21:03 UTC (rev 3678) @@ -60,7 +60,7 @@ (defmethod sample-event-table-name ((sensor sensor)) (format nil "sample_event_~(~A~)" (sensor-type sensor))) -(defmethod initialize-persistent-instance :after ((sensor sensor)) +(defmethod initialize-persistent-instance :after ((sensor sensor) &key) (let ((id (store-object-id sensor))) (with-slots (name unit type) sensor (postgres-execute

1 0

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

29 Jul '08

Revision: 3677 Author: hans URL: http://bknr.net/trac/changeset/3677 INITIALIZE-PERSISTENT-INSTANCE now receives the initargs supplied to MAKE-OBJECT. U trunk/bknr/datastore/src/data/object.lisp U trunk/bknr/web/src/frontend/frontend-config.lisp U trunk/bknr/web/src/rss/rss.lisp U trunk/bknr/web/src/sysclasses/user.lisp U trunk/projects/bos/m2/allocation.lisp U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/poi.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-29 12:09:21 UTC (rev 3676) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-29 12:13:33 UTC (rev 3677) @@ -244,19 +244,19 @@ :timestamp (get-universal-time) :args (append (list object (if (symbolp class) class (class-name class))) args)))) -(defgeneric initialize-persistent-instance (store-object) +(defgeneric initialize-persistent-instance (store-object &key) (:documentation - "Initializes the persistent aspects of a persistent object. This method is called -at the creationg of a persistent object, but not when the object is loaded from a -snapshot.")) + "Initializes the persistent aspects of a persistent object. This +method is called at the creation of a persistent object, but not when +the object is loaded from a snapshot.")) (defgeneric initialize-transient-instance (store-object) (:documentation - "Initializes the transient aspects of a persistent object. This method is called -whenever a persistent object is initialized, also when the object is loaded from -a snapshot.")) + "Initializes the transient aspects of a persistent object. This +method is called whenever a persistent object is initialized, also +when the object is loaded from a snapshot.")) -(defmethod initialize-persistent-instance ((object store-object))) +(defmethod initialize-persistent-instance ((object store-object) &key)) (defmethod initialize-transient-instance ((object store-object))) (defmethod store-object-persistent-slots ((object store-object)) @@ -641,7 +641,7 @@ (if restoring (remove-transient-slot-initargs (find-class class-name) initargs) initargs))) - (initialize-persistent-instance obj) + (apply #'initialize-persistent-instance obj initargs) (initialize-transient-instance obj) (setf error nil) obj) Modified: trunk/bknr/web/src/frontend/frontend-config.lisp =================================================================== --- trunk/bknr/web/src/frontend/frontend-config.lisp 2008-07-29 12:09:21 UTC (rev 3676) +++ trunk/bknr/web/src/frontend/frontend-config.lisp 2008-07-29 12:13:33 UTC (rev 3677) @@ -9,7 +9,8 @@ (cl-interpol:disable-interpol-syntax)))) (defun cachable-prefixes-regex () - (format nil "^(~{~A~^|~})" (mapcar #'page-handler-prefix (website-cachable-handlers bknr.web:*website*)))) + (format nil "^(~{~A~^|~})" + (mapcar #'page-handler-prefix (website-cachable-handlers bknr.web::*website*)))) (defun generate-frontend-config (stream &key backend-port) Modified: trunk/bknr/web/src/rss/rss.lisp =================================================================== --- trunk/bknr/web/src/rss/rss.lisp 2008-07-29 12:09:21 UTC (rev 3676) +++ trunk/bknr/web/src/rss/rss.lisp 2008-07-29 12:13:33 UTC (rev 3677) @@ -147,7 +147,7 @@ (:method ((channel (eql nil)) item) (warn "no RSS channel defined for item ~A" item))) -(defmethod initialize-persistent-instance :after ((rss-item rss-item)) +(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-29 12:09:21 UTC (rev 3676) +++ trunk/bknr/web/src/sysclasses/user.lisp 2008-07-29 12:13:33 UTC (rev 3677) @@ -60,7 +60,7 @@ (user-login object) "unbound")))) -(defmethod initialize-persistent-instance ((user user)) +(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-persistent-instance ((user smb-user)) +(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/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-07-29 12:09:21 UTC (rev 3676) +++ trunk/projects/bos/m2/allocation.lisp 2008-07-29 12:13:33 UTC (rev 3677) @@ -34,7 +34,7 @@ :unbound) (store-object-id allocation-area)))) -(defmethod initialize-persistent-instance :after ((allocation-area allocation-area)) +(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-29 12:09:21 UTC (rev 3676) +++ trunk/projects/bos/m2/m2.lisp 2008-07-29 12:13:33 UTC (rev 3677) @@ -276,7 +276,7 @@ (defun contract-p (object) (equal (class-of object) (find-class 'contract))) -(defmethod initialize-persistent-instance :after ((contract contract)) +(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)) @@ -377,7 +377,11 @@ (dolist (m2 (contract-m2s contract)) (collect (list (m2-x m2) (m2-y m2)))))) -(defun contracts-bounding-box (&optional (contracts (class-instances 'contract))) +(defun all-contracts () + "Return list of all contracts in the system." + (class-instances 'all-contracts)) + +(defun contracts-bounding-box (&optional (contracts (all-contracts))) (geometry:with-bounding-box-collect (collect) (dolist (contract contracts) (dolist (m2 (contract-m2s contract)) Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-29 12:09:21 UTC (rev 3676) +++ trunk/projects/bos/m2/poi.lisp 2008-07-29 12:13:33 UTC (rev 3677) @@ -30,7 +30,7 @@ (when poi (setf (poi-images poi) (remove poi-image (poi-images poi)))))) -(defmethod initialize-persistent-instance :after ((poi-image poi-image)) +(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)))) (deftransaction update-poi-image (poi-image language @@ -53,6 +53,7 @@ (name :read :index-type string-unique-index :index-reader find-poi :index-values all-pois :documentation "Symbolischer Name") + (published :update :initform nil) (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")

1 0

[bknr-cvs] hans changed trunk/projects/bos/web/countries.lisp
by BKNR Commits 29 Jul '08

29 Jul '08

Revision: 3676 Author: hans URL: http://bknr.net/trac/changeset/3676 Move LABELS into value position in order to preserve top-levelness of DEFVAR. U trunk/projects/bos/web/countries.lisp Modified: trunk/projects/bos/web/countries.lisp =================================================================== --- trunk/projects/bos/web/countries.lisp 2008-07-29 10:06:05 UTC (rev 3675) +++ trunk/projects/bos/web/countries.lisp 2008-07-29 12:09:21 UTC (rev 3676) @@ -4,98 +4,99 @@ (in-package :bos.web) -(labels ((degrees2float (string) - (ppcre:register-groups-bind (degrees minutes orientation) - ("(\\d+) +(\\d+) +([WESN])" string) - (assert (and degrees minutes orientation)) - (* (case (char orientation 0) ((#\W #\S) -1d0) (otherwise 1d0)) - (+ (float (parse-integer degrees) 0d0) - (/ (float (parse-integer minutes) 0d0) 60d0))))) - (parse-coord (args) - (destructuring-bind (country lon lat) - args - (list country (degrees2float lon) (degrees2float lat))))) - (defvar *country-coords* (mapcar #'parse-coord - '((:AW "12 30 N" "69 58 W") (:AG "17 03 N" "61 48 W") (:AE "24 00 N" "54 00 E") - (:AF "33 00 N" "65 00 E") (:DZ "28 00 N" "3 00 E") (:AZ "40 30 N" "47 30 E") - (:AL "41 00 N" "20 00 E") (:AM "40 00 N" "45 00 E") (:AD "42 30 N" "1 30 E") - (:AO "12 30 S" "18 30 E") (:AS "14 20 S" "170 00 W") (:AR "34 00 S" "64 00 W") - (:AU "27 00 S" "133 00 E") (:AT "47 20 N" "13 20 E") (:AI "18 15 N" "63 10 W") - (:AQ "90 00 S" "0 00 E") (:BH "26 00 N" "50 33 E") (:BB "13 10 N" "59 32 W") - (:BW "22 00 S" "24 00 E") (:BM "32 20 N" "64 45 W") (:BE "50 50 N" "4 00 E") - (:BS "24 15 N" "76 00 W") (:BD "24 00 N" "90 00 E") (:BZ "17 15 N" "88 45 W") - (:BA "44 00 N" "18 00 E") (:BO "17 00 S" "65 00 W") (:MM "22 00 N" "98 00 E") - (:BJ "9 30 N" "2 15 E") (:BY "53 00 N" "28 00 E") (:SB "8 00 S" "159 00 E") - (:BR "10 00 S" "55 00 W") (:BT "27 30 N" "90 30 E") (:BG "43 00 N" "25 00 E") - (:BV "54 26 S" "3 24 E") (:BN "4 30 N" "114 40 E") (:BI "3 30 S" "30 00 E") - (:CA "60 00 N" "95 00 W") (:KH "13 00 N" "105 00 E") (:TD "15 00 N" "19 00 E") - (:LK "7 00 N" "81 00 E") (:CG "1 00 S" "15 00 E") (:CD "0 00 N" "25 00 E") - (:CN "35 00 N" "105 00 E") (:CL "30 00 S" "71 00 W") (:KY "19 30 N" "80 30 W") - (:CC "12 30 S" "96 50 E") (:CM "6 00 N" "12 00 E") (:KM "12 10 S" "44 15 E") - (:CO "4 00 N" "72 00 W") (:MP "15 12 N" "145 45 E") (:CR "10 00 N" "84 00 W") - (:CF "7 00 N" "21 00 E") (:CU "21 30 N" "80 00 W") (:CV "16 00 N" "24 00 W") - (:CK "21 14 S" "159 46 W") (:CY "35 00 N" "33 00 E") (:DK "56 00 N" "10 00 E") - (:DJ "11 30 N" "43 00 E") (:DM "15 25 N" "61 20 W") (:DO "19 00 N" "70 40 W") - (:EC "2 00 S" "77 30 W") (:EG "27 00 N" "30 00 E") (:IE "53 00 N" "8 00 W") - (:GQ "2 00 N" "10 00 E") (:EE "59 00 N" "26 00 E") (:ER "15 00 N" "39 00 E") - (:SV "13 50 N" "88 55 W") (:ET "8 00 N" "38 00 E") (:CZ "49 45 N" "15 30 E") - (:FI "64 00 N" "26 00 E") (:FJ "18 00 S" "175 00 E") (:FK "51 45 S" "59 00 W") - (:FM "6 55 N" "158 15 E") (:FO "62 00 N" "7 00 W") (:PF "15 00 S" "140 00 W") - (:FR "46 00 N" "2 00 E") (:GM "13 28 N" "16 34 W") (:GA "1 00 S" "11 45 E") - (:GE "42 00 N" "43 30 E") (:GH "8 00 N" "2 00 W") (:GI "36 08 N" "5 21 W") - (:GD "12 07 N" "61 40 W") (:GG "49 28 N" "2 35 W") (:GL "72 00 N" "40 00 W") - (:DE "51 00 N" "9 00 E") (:GU "13 28 N" "144 47 E") (:GR "39 00 N" "22 00 E") - (:GT "15 30 N" "90 15 W") (:GN "11 00 N" "10 00 W") (:GY "5 00 N" "59 00 W") - (:PS "31 25 N" "34 20 E") (:HT "19 00 N" "72 25 W") (:HK "22 15 N" "114 10 E") - (:HM "53 06 S" "72 31 E") (:HN "15 00 N" "86 30 W") (:HR "45 10 N" "15 30 E") - (:HU "47 00 N" "20 00 E") (:IS "65 00 N" "18 00 W") (:ID "5 00 S" "120 00 E") - (:IM "54 15 N" "4 30 W") (:IN "20 00 N" "77 00 E") (:IO "6 00 S" "71 30 E") - (:IR "32 00 N" "53 00 E") (:IL "31 30 N" "34 45 E") (:IT "42 50 N" "12 50 E") - (:CI "8 00 N" "5 00 W") (:IQ "33 00 N" "44 00 E") (:JP "36 00 N" "138 00 E") - (:JE "49 15 N" "2 10 W") (:JM "18 15 N" "77 30 W") (:JO "31 00 N" "36 00 E") - (:KE "1 00 N" "38 00 E") (:KG "41 00 N" "75 00 E") (:KP "40 00 N" "127 00 E") - (:KI "1 25 N" "173 00 E") (:KR "37 00 N" "127 30 E") - (:CX "10 30 S" "105 40 E") (:KW "29 30 N" "45 45 E") (:KZ "48 00 N" "68 00 E") - (:LA "18 00 N" "105 00 E") (:LB "33 50 N" "35 50 E") (:LV "57 00 N" "25 00 E") - (:LT "56 00 N" "24 00 E") (:LR "6 30 N" "9 30 W") (:SK "48 40 N" "19 30 E") - (:LI "47 16 N" "9 32 E") (:LS "29 30 S" "28 30 E") (:LU "49 45 N" "6 10 E") - (:LY "25 00 N" "17 00 E") (:MG "20 00 S" "47 00 E") (:MO "22 10 N" "113 33 E") - (:MD "47 00 N" "29 00 E") (:YT "12 50 S" "45 10 E") (:MN "46 00 N" "105 00 E") - (:MS "16 45 N" "62 12 W") (:MW "13 30 S" "34 00 E") (:ME "42 30 N" "19 18 E") - (:MK "41 50 N" "22 00 E") (:ML "17 00 N" "4 00 W") (:MC "43 44 N" "7 24 E") - (:MA "32 00 N" "5 00 W") (:MU "20 17 S" "57 33 E") (:MR "20 00 N" "12 00 W") - (:MT "35 50 N" "14 35 E") (:OM "21 00 N" "57 00 E") (:MV "3 15 N" "73 00 E") - (:MX "23 00 N" "102 00 W") (:MY "2 30 N" "112 30 E") (:MZ "18 15 S" "35 00 E") - (:NC "21 30 S" "165 30 E") (:NU "19 02 S" "169 52 W") - (:NF "29 02 S" "167 57 E") (:NE "16 00 N" "8 00 E") (:VU "16 00 S" "167 00 E") - (:NG "10 00 N" "8 00 E") (:NL "52 30 N" "5 45 E") (:NO "62 00 N" "10 00 E") - (:NP "28 00 N" "84 00 E") (:NR "0 32 S" "166 55 E") (:SR "4 00 N" "56 00 W") - (:AN "12 15 N" "68 45 W") (:NI "13 00 N" "85 00 W") (:NZ "41 00 S" "174 00 E") - (:PY "23 00 S" "58 00 W") (:PN "25 04 S" "130 06 W") (:PE "10 00 S" "76 00 W") - (:PK "30 00 N" "70 00 E") (:PL "52 00 N" "20 00 E") (:PA "9 00 N" "80 00 W") - (:PT "39 30 N" "8 00 W") (:PG "6 00 S" "147 00 E") (:PW "7 30 N" "134 30 E") - (:GW "12 00 N" "15 00 W") (:QA "25 30 N" "51 15 E") (:RS "44 00 N" "21 00 E") - (:MH "9 00 N" "168 00 E") (:MF "18 05 N" "63 57 W") (:RO "46 00 N" "25 00 E") - (:PH "13 00 N" "122 00 E") (:PR "18 15 N" "66 30 W") - (:RU "60 00 N" "100 00 E") (:RW "2 00 S" "30 00 E") (:SA "25 00 N" "45 00 E") - (:PM "46 50 N" "56 20 W") (:KN "17 20 N" "62 45 W") (:SC "4 35 S" "55 40 E") - (:ZA "29 00 S" "24 00 E") (:SN "14 00 N" "14 00 W") (:SI "46 07 N" "14 49 E") - (:SL "8 30 N" "11 30 W") (:SM "43 46 N" "12 25 E") (:SG "1 22 N" "103 48 E") - (:SO "10 00 N" "49 00 E") (:ES "40 00 N" "4 00 W") (:LC "13 53 N" "60 58 W") - (:SD "15 00 N" "30 00 E") (:SJ "78 00 N" "20 00 E") (:SE "62 00 N" "15 00 E") - (:GS "54 30 S" "37 00 W") (:SY "35 00 N" "38 00 E") (:CH "47 00 N" "8 00 E") - (:BL "17 90 N" "62 85 W") (:TT "11 00 N" "61 00 W") (:TH "15 00 N" "100 00 E") - (:TJ "39 00 N" "71 00 E") (:TC "21 45 N" "71 35 W") (:TK "9 00 S" "172 00 W") - (:TO "20 00 S" "175 00 W") (:TG "8 00 N" "1 10 E") (:ST "1 00 N" "7 00 E") - (:TN "34 00 N" "9 00 E") (:TL "8 50 S" "125 55 E") (:TR "39 00 N" "35 00 E") - (:TV "8 00 S" "178 00 E") (:TW "23 30 N" "121 00 E") (:TM "40 00 N" "60 00 E") - (:TZ "6 00 S" "35 00 E") (:UG "1 00 N" "32 00 E") (:GB "54 00 N" "2 00 W") - (:UA "49 00 N" "32 00 E") (:US "38 00 N" "97 00 W") (:BF "13 00 N" "2 00 W") - (:UY "33 00 S" "56 00 W") (:UZ "41 00 N" "64 00 E") (:VC "13 15 N" "61 12 W") - (:VE "8 00 N" "66 00 W") (:VG "18 30 N" "64 30 W") (:VN "16 00 N" "106 00 E") - (:VI "18 20 N" "64 50 W") (:VA "41 54 N" "12 27 E") (:NA "22 00 S" "17 00 E") - (:PS "32 00 N" "35 15 E") (:WF "13 18 S" "176 12 W") (:EH "24 30 N" "13 00 W") - (:WS "13 35 S" "172 20 W") (:SZ "26 30 S" "31 30 E") (:YE "15 00 N" "48 00 E"))))) +(defvar *country-coords* + (labels ((degrees2float (string) + (ppcre:register-groups-bind (degrees minutes orientation) + ("(\\d+) +(\\d+) +([WESN])" string) + (assert (and degrees minutes orientation)) + (* (case (char orientation 0) ((#\W #\S) -1d0) (otherwise 1d0)) + (+ (float (parse-integer degrees) 0d0) + (/ (float (parse-integer minutes) 0d0) 60d0))))) + (parse-coord (args) + (destructuring-bind (country lon lat) + args + (list country (degrees2float lon) (degrees2float lat))))) + (mapcar #'parse-coord + '((:AW "12 30 N" "69 58 W") (:AG "17 03 N" "61 48 W") (:AE "24 00 N" "54 00 E") + (:AF "33 00 N" "65 00 E") (:DZ "28 00 N" "3 00 E") (:AZ "40 30 N" "47 30 E") + (:AL "41 00 N" "20 00 E") (:AM "40 00 N" "45 00 E") (:AD "42 30 N" "1 30 E") + (:AO "12 30 S" "18 30 E") (:AS "14 20 S" "170 00 W") (:AR "34 00 S" "64 00 W") + (:AU "27 00 S" "133 00 E") (:AT "47 20 N" "13 20 E") (:AI "18 15 N" "63 10 W") + (:AQ "90 00 S" "0 00 E") (:BH "26 00 N" "50 33 E") (:BB "13 10 N" "59 32 W") + (:BW "22 00 S" "24 00 E") (:BM "32 20 N" "64 45 W") (:BE "50 50 N" "4 00 E") + (:BS "24 15 N" "76 00 W") (:BD "24 00 N" "90 00 E") (:BZ "17 15 N" "88 45 W") + (:BA "44 00 N" "18 00 E") (:BO "17 00 S" "65 00 W") (:MM "22 00 N" "98 00 E") + (:BJ "9 30 N" "2 15 E") (:BY "53 00 N" "28 00 E") (:SB "8 00 S" "159 00 E") + (:BR "10 00 S" "55 00 W") (:BT "27 30 N" "90 30 E") (:BG "43 00 N" "25 00 E") + (:BV "54 26 S" "3 24 E") (:BN "4 30 N" "114 40 E") (:BI "3 30 S" "30 00 E") + (:CA "60 00 N" "95 00 W") (:KH "13 00 N" "105 00 E") (:TD "15 00 N" "19 00 E") + (:LK "7 00 N" "81 00 E") (:CG "1 00 S" "15 00 E") (:CD "0 00 N" "25 00 E") + (:CN "35 00 N" "105 00 E") (:CL "30 00 S" "71 00 W") (:KY "19 30 N" "80 30 W") + (:CC "12 30 S" "96 50 E") (:CM "6 00 N" "12 00 E") (:KM "12 10 S" "44 15 E") + (:CO "4 00 N" "72 00 W") (:MP "15 12 N" "145 45 E") (:CR "10 00 N" "84 00 W") + (:CF "7 00 N" "21 00 E") (:CU "21 30 N" "80 00 W") (:CV "16 00 N" "24 00 W") + (:CK "21 14 S" "159 46 W") (:CY "35 00 N" "33 00 E") (:DK "56 00 N" "10 00 E") + (:DJ "11 30 N" "43 00 E") (:DM "15 25 N" "61 20 W") (:DO "19 00 N" "70 40 W") + (:EC "2 00 S" "77 30 W") (:EG "27 00 N" "30 00 E") (:IE "53 00 N" "8 00 W") + (:GQ "2 00 N" "10 00 E") (:EE "59 00 N" "26 00 E") (:ER "15 00 N" "39 00 E") + (:SV "13 50 N" "88 55 W") (:ET "8 00 N" "38 00 E") (:CZ "49 45 N" "15 30 E") + (:FI "64 00 N" "26 00 E") (:FJ "18 00 S" "175 00 E") (:FK "51 45 S" "59 00 W") + (:FM "6 55 N" "158 15 E") (:FO "62 00 N" "7 00 W") (:PF "15 00 S" "140 00 W") + (:FR "46 00 N" "2 00 E") (:GM "13 28 N" "16 34 W") (:GA "1 00 S" "11 45 E") + (:GE "42 00 N" "43 30 E") (:GH "8 00 N" "2 00 W") (:GI "36 08 N" "5 21 W") + (:GD "12 07 N" "61 40 W") (:GG "49 28 N" "2 35 W") (:GL "72 00 N" "40 00 W") + (:DE "51 00 N" "9 00 E") (:GU "13 28 N" "144 47 E") (:GR "39 00 N" "22 00 E") + (:GT "15 30 N" "90 15 W") (:GN "11 00 N" "10 00 W") (:GY "5 00 N" "59 00 W") + (:PS "31 25 N" "34 20 E") (:HT "19 00 N" "72 25 W") (:HK "22 15 N" "114 10 E") + (:HM "53 06 S" "72 31 E") (:HN "15 00 N" "86 30 W") (:HR "45 10 N" "15 30 E") + (:HU "47 00 N" "20 00 E") (:IS "65 00 N" "18 00 W") (:ID "5 00 S" "120 00 E") + (:IM "54 15 N" "4 30 W") (:IN "20 00 N" "77 00 E") (:IO "6 00 S" "71 30 E") + (:IR "32 00 N" "53 00 E") (:IL "31 30 N" "34 45 E") (:IT "42 50 N" "12 50 E") + (:CI "8 00 N" "5 00 W") (:IQ "33 00 N" "44 00 E") (:JP "36 00 N" "138 00 E") + (:JE "49 15 N" "2 10 W") (:JM "18 15 N" "77 30 W") (:JO "31 00 N" "36 00 E") + (:KE "1 00 N" "38 00 E") (:KG "41 00 N" "75 00 E") (:KP "40 00 N" "127 00 E") + (:KI "1 25 N" "173 00 E") (:KR "37 00 N" "127 30 E") + (:CX "10 30 S" "105 40 E") (:KW "29 30 N" "45 45 E") (:KZ "48 00 N" "68 00 E") + (:LA "18 00 N" "105 00 E") (:LB "33 50 N" "35 50 E") (:LV "57 00 N" "25 00 E") + (:LT "56 00 N" "24 00 E") (:LR "6 30 N" "9 30 W") (:SK "48 40 N" "19 30 E") + (:LI "47 16 N" "9 32 E") (:LS "29 30 S" "28 30 E") (:LU "49 45 N" "6 10 E") + (:LY "25 00 N" "17 00 E") (:MG "20 00 S" "47 00 E") (:MO "22 10 N" "113 33 E") + (:MD "47 00 N" "29 00 E") (:YT "12 50 S" "45 10 E") (:MN "46 00 N" "105 00 E") + (:MS "16 45 N" "62 12 W") (:MW "13 30 S" "34 00 E") (:ME "42 30 N" "19 18 E") + (:MK "41 50 N" "22 00 E") (:ML "17 00 N" "4 00 W") (:MC "43 44 N" "7 24 E") + (:MA "32 00 N" "5 00 W") (:MU "20 17 S" "57 33 E") (:MR "20 00 N" "12 00 W") + (:MT "35 50 N" "14 35 E") (:OM "21 00 N" "57 00 E") (:MV "3 15 N" "73 00 E") + (:MX "23 00 N" "102 00 W") (:MY "2 30 N" "112 30 E") (:MZ "18 15 S" "35 00 E") + (:NC "21 30 S" "165 30 E") (:NU "19 02 S" "169 52 W") + (:NF "29 02 S" "167 57 E") (:NE "16 00 N" "8 00 E") (:VU "16 00 S" "167 00 E") + (:NG "10 00 N" "8 00 E") (:NL "52 30 N" "5 45 E") (:NO "62 00 N" "10 00 E") + (:NP "28 00 N" "84 00 E") (:NR "0 32 S" "166 55 E") (:SR "4 00 N" "56 00 W") + (:AN "12 15 N" "68 45 W") (:NI "13 00 N" "85 00 W") (:NZ "41 00 S" "174 00 E") + (:PY "23 00 S" "58 00 W") (:PN "25 04 S" "130 06 W") (:PE "10 00 S" "76 00 W") + (:PK "30 00 N" "70 00 E") (:PL "52 00 N" "20 00 E") (:PA "9 00 N" "80 00 W") + (:PT "39 30 N" "8 00 W") (:PG "6 00 S" "147 00 E") (:PW "7 30 N" "134 30 E") + (:GW "12 00 N" "15 00 W") (:QA "25 30 N" "51 15 E") (:RS "44 00 N" "21 00 E") + (:MH "9 00 N" "168 00 E") (:MF "18 05 N" "63 57 W") (:RO "46 00 N" "25 00 E") + (:PH "13 00 N" "122 00 E") (:PR "18 15 N" "66 30 W") + (:RU "60 00 N" "100 00 E") (:RW "2 00 S" "30 00 E") (:SA "25 00 N" "45 00 E") + (:PM "46 50 N" "56 20 W") (:KN "17 20 N" "62 45 W") (:SC "4 35 S" "55 40 E") + (:ZA "29 00 S" "24 00 E") (:SN "14 00 N" "14 00 W") (:SI "46 07 N" "14 49 E") + (:SL "8 30 N" "11 30 W") (:SM "43 46 N" "12 25 E") (:SG "1 22 N" "103 48 E") + (:SO "10 00 N" "49 00 E") (:ES "40 00 N" "4 00 W") (:LC "13 53 N" "60 58 W") + (:SD "15 00 N" "30 00 E") (:SJ "78 00 N" "20 00 E") (:SE "62 00 N" "15 00 E") + (:GS "54 30 S" "37 00 W") (:SY "35 00 N" "38 00 E") (:CH "47 00 N" "8 00 E") + (:BL "17 90 N" "62 85 W") (:TT "11 00 N" "61 00 W") (:TH "15 00 N" "100 00 E") + (:TJ "39 00 N" "71 00 E") (:TC "21 45 N" "71 35 W") (:TK "9 00 S" "172 00 W") + (:TO "20 00 S" "175 00 W") (:TG "8 00 N" "1 10 E") (:ST "1 00 N" "7 00 E") + (:TN "34 00 N" "9 00 E") (:TL "8 50 S" "125 55 E") (:TR "39 00 N" "35 00 E") + (:TV "8 00 S" "178 00 E") (:TW "23 30 N" "121 00 E") (:TM "40 00 N" "60 00 E") + (:TZ "6 00 S" "35 00 E") (:UG "1 00 N" "32 00 E") (:GB "54 00 N" "2 00 W") + (:UA "49 00 N" "32 00 E") (:US "38 00 N" "97 00 W") (:BF "13 00 N" "2 00 W") + (:UY "33 00 S" "56 00 W") (:UZ "41 00 N" "64 00 E") (:VC "13 15 N" "61 12 W") + (:VE "8 00 N" "66 00 W") (:VG "18 30 N" "64 30 W") (:VN "16 00 N" "106 00 E") + (:VI "18 20 N" "64 50 W") (:VA "41 54 N" "12 27 E") (:NA "22 00 S" "17 00 E") + (:PS "32 00 N" "35 15 E") (:WF "13 18 S" "176 12 W") (:EH "24 30 N" "13 00 W") + (:WS "13 35 S" "172 20 W") (:SZ "26 30 S" "31 30 E") (:YE "15 00 N" "48 00 E"))))) (defvar *country-english-names* '((:AD "Andorra") (:AE "United Arab Emirates") (:AF "Afghanistan")

1 0

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

29 Jul '08

Revision: 3675 Author: ksprotte URL: http://bknr.net/trac/changeset/3675 factored slot-strings into a seperate file U trunk/projects/bos/m2/bos.m2.asd U trunk/projects/bos/m2/poi.lisp A trunk/projects/bos/m2/slot-strings.lisp Modified: trunk/projects/bos/m2/bos.m2.asd =================================================================== --- trunk/projects/bos/m2/bos.m2.asd 2008-07-29 09:59:45 UTC (rev 3674) +++ trunk/projects/bos/m2/bos.m2.asd 2008-07-29 10:06:05 UTC (rev 3675) @@ -11,7 +11,7 @@ (:file "geometry" :depends-on ("packages")) (:file "config" :depends-on ("packages")) (:file "utils" :depends-on ("packages")) - (:file "news" :depends-on ("packages" "poi")) + (:file "news" :depends-on ("packages" "slot-strings")) (:file "tiled-index" :depends-on ("packages")) (:file "mail-generator" :depends-on ("packages")) (:file "make-certificate" :depends-on ("packages")) @@ -24,7 +24,8 @@ (:file "allocation" :depends-on ("geometry" "packages")) (:file "allocation-cache" :depends-on ("allocation" "initialization-subsystem" "packages" "utils")) - (:file "poi" :depends-on ("packages")) + (:file "slot-strings" :depends-on ("packages")) + (:file "poi" :depends-on ("packages" "slot-strings")) (:file "import" :depends-on ("packages")) (:file "map" :depends-on ("config" "packages" "tiled-index")) (:file "export" :depends-on ("packages")) Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-29 09:59:45 UTC (rev 3674) +++ trunk/projects/bos/m2/poi.lisp 2008-07-29 10:06:05 UTC (rev 3675) @@ -3,34 +3,8 @@ ;; Klassen und Funktione für die "Points of Information", die für die ;; Quadratmeter-Datenbank gespeichert werden. -;; Die Implementation kurvt ein bisschen um den aktuellen Datastore -;; herum, da eine ästhetische Implementation der mehrsprachigen -;; Strings MOP erforderlich machen würde, die Umstellung des Datastore -;; auf MOP jedoch noch nicht fertig ist. - (in-package :bos.m2) -;; Multilinguale Strings als Slots, werden als Hashes im Objekt -;; gespeichert und über slot-string bzw. (setf slot-string) -;; angesprochen. - -(defun make-string-hash-table () - (make-hash-table :test #'equal)) - -(defun slot-string (object slot-name language &optional (not-found-value "")) - (or (gethash language (slot-value object slot-name)) not-found-value)) - -(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)) - (setf (gethash language (slot-value object slot-name)) new-value)) - -(defsetf slot-string set-slot-string) - -(deftransaction set-slot-string-values (object language &rest args) - (loop for (slot-name value) on args by #'cddr - do (setf (slot-string object slot-name language) value))) - ;;; POI-Anwendungsklassen und Konstruktoren ;;; poi-image @@ -75,19 +49,16 @@ ;;; poi (define-persistent-class poi () - ((name :read :index-type string-unique-index + ((published :update :initform nil) + (name :read :index-type string-unique-index :index-reader find-poi :index-values all-pois :documentation "Symbolischer Name") (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") (area :update :initform nil :documentation "Polygon mit den POI-Koordinaten") - (icon :update :initform "palme" :documentation "Name des Icons") - (images :update :initform nil) - (airals :update :initform nil) - (panoramas :update :initform nil) - (movies :update :initform nil) - (published :update :initform nil))) + (icon :update :initform "palme" :documentation "Name des Icons") + (medias :update :initform nil))) (defmethod poi-movies :before ((poi poi)) "Lazily update the db schema. Method can be removed later." Added: trunk/projects/bos/m2/slot-strings.lisp =================================================================== --- trunk/projects/bos/m2/slot-strings.lisp (rev 0) +++ trunk/projects/bos/m2/slot-strings.lisp 2008-07-29 10:06:05 UTC (rev 3675) @@ -0,0 +1,28 @@ +(in-package :bos.m2) + +;; Die Implementation kurvt ein bisschen um den aktuellen Datastore +;; herum, da eine ästhetische Implementation der mehrsprachigen +;; Strings MOP erforderlich machen würde, die Umstellung des Datastore +;; auf MOP jedoch noch nicht fertig ist. + +;; Multilinguale Strings als Slots, werden als Hashes im Objekt +;; gespeichert und über slot-string bzw. (setf slot-string) +;; angesprochen. + +(defun make-string-hash-table () + (make-hash-table :test #'equal)) + +(defun slot-string (object slot-name language &optional (not-found-value "")) + (or (gethash language (slot-value object slot-name)) not-found-value)) + +(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)) + (setf (gethash language (slot-value object slot-name)) new-value)) + +(defsetf slot-string set-slot-string) + +(deftransaction set-slot-string-values (object language &rest args) + (loop for (slot-name value) on args by #'cddr + do (setf (slot-string object slot-name language) value))) +

1 0

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

29 Jul '08

Revision: 3674 Author: hans URL: http://bknr.net/trac/changeset/3674 Export slot value conversion function U trunk/bknr/datastore/src/data/package.lisp Modified: trunk/bknr/datastore/src/data/package.lisp =================================================================== --- trunk/bknr/datastore/src/data/package.lisp 2008-07-29 08:56:38 UTC (rev 3673) +++ trunk/bknr/datastore/src/data/package.lisp 2008-07-29 09:59:45 UTC (rev 3674) @@ -71,6 +71,8 @@ #:store-object-remove-keywords #:store-object-set-keywords + #:convert-slot-value-while-restoring + #:persistent-change-class #:map-class-instances

1 0

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

29 Jul '08

Revision: 3673 Author: hans URL: http://bknr.net/trac/changeset/3673 Always call CONVERT-SLOT-VALUE-WHILE-RESTORING and supply a default method that just sets the slot's value to whatever was found in the snapshot. U trunk/bknr/datastore/src/data/object.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-29 08:42:50 UTC (rev 3672) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-29 08:56:38 UTC (rev 3673) @@ -381,7 +381,9 @@ (:documentation "Generic function to be called to convert a slot's value from a previous snapshot layout. OBJECT is the object that is being restored, SLOT-NAME is the name of the slot in the old schema, - VALUE is the value of the slot in the old schema.")) + VALUE is the value of the slot in the old schema.") + (:method (object slot-name value) + (setf (slot-value object slot-name) value))) (defun find-slot-name-with-automatic-rename (class slot-name) (if (find slot-name (class-slots class) :key #'slot-definition-name) @@ -445,9 +447,7 @@ (let ((bknr.indices::*indices-remove-p* nil)) (if (eq value 'unbound) (slot-makunbound object slot-name) - (if (slot-boundp object slot-name) - (convert-slot-value-while-restoring object slot-name value) - (setf (slot-value object slot-name) value)))))) + (convert-slot-value-while-restoring object slot-name value))))) (set-slot-nil () :report "Set slot to NIL." (setf (slot-value object slot-name) nil))

1 0

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

29 Jul '08

Revision: 3672 Author: hans URL: http://bknr.net/trac/changeset/3672 Schema evolution aid: In order to make it possible to restore snapshots from older schema when slots of a class have been deleted, provide for a CONVERT-SLOT-VALUE-WHILE-RESTORING generic function that can be defined to convert old slot values into the new object layout. U trunk/bknr/datastore/src/data/object.lisp Modified: trunk/bknr/datastore/src/data/object.lisp =================================================================== --- trunk/bknr/datastore/src/data/object.lisp 2008-07-29 07:40:57 UTC (rev 3671) +++ trunk/bknr/datastore/src/data/object.lisp 2008-07-29 08:42:50 UTC (rev 3672) @@ -377,6 +377,12 @@ (find (symbol-name slot-name) (mapcar #'slot-definition-name (class-slots class)) :key #'symbol-name :test #'equal))) +(defgeneric convert-slot-value-while-restoring (object slot-name value) + (:documentation "Generic function to be called to convert a slot's + value from a previous snapshot layout. OBJECT is the object that is + being restored, SLOT-NAME is the name of the slot in the old schema, + VALUE is the value of the slot in the old schema.")) + (defun find-slot-name-with-automatic-rename (class slot-name) (if (find slot-name (class-slots class) :key #'slot-definition-name) slot-name @@ -390,6 +396,9 @@ (t (error "can't find a slot in class ~A which matches the name ~A used in the store snapshot" (class-name class) slot-name)))) + (convert-values () + :report "Convert slot values using CONVERT-SLOT-VALUE-WHILE-RESTORING" + (cons 'convert-slot-values slot-name)) (ignore-slot () :report "Ignore slot, discarding values found in the snapshot file" nil)))) @@ -419,24 +428,32 @@ the slots are read from the snapshot and ignored." (declare (optimize (speed 3))) (dolist (slot-name slots) - (if slot-name ; NIL for slots which are not restored because of schema changes - (restart-case - (let ((*current-object-slot* (list object slot-name)) - (*current-slot-relaxed-p* (or (null object) - (store-object-relaxed-object-reference-p object slot-name)))) - (let ((value (decode stream))) - (when object - (let ((bknr.indices::*indices-remove-p* nil)) - (if (eq value 'unbound) - (slot-makunbound object slot-name) - (setf (slot-value object slot-name) value)))))) - (set-slot-nil () - :report "Set slot to NIL." - (setf (slot-value object slot-name) nil)) - (make-slot-unbound () - :report "Make slot unbound." - (slot-makunbound object slot-name))) - (decode stream)))) ; read and ignore value + (let ((value (decode stream))) + (cond + ((consp slot-name) + (assert (eq 'convert-slot-values (car slot-name))) + (convert-slot-value-while-restoring object (cdr slot-name) value)) + ((null slot-name) + ;; ignore value + ) + (t + (restart-case + (let ((*current-object-slot* (list object slot-name)) + (*current-slot-relaxed-p* (or (null object) + (store-object-relaxed-object-reference-p object slot-name)))) + (when object + (let ((bknr.indices::*indices-remove-p* nil)) + (if (eq value 'unbound) + (slot-makunbound object slot-name) + (if (slot-boundp object slot-name) + (convert-slot-value-while-restoring object slot-name value) + (setf (slot-value object slot-name) value)))))) + (set-slot-nil () + :report "Set slot to NIL." + (setf (slot-value object slot-name) nil)) + (make-slot-unbound () + :report "Make slot unbound." + (slot-makunbound object slot-name)))))))) (defun snapshot-read-object (stream layouts) (declare (optimize (speed 3))) @@ -496,23 +513,30 @@ (%decode-store-object stream))) (defun %decode-store-object (stream) - ;; This is actually called in two contexts, when a slot-value is to be filled with a reference to a store object - ;; and when a list of store objects is read from the transaction log (%decode-list). In the former case, references - ;; two deleted objects are accepted when the slot pointing to the object is marked as being a "relaxed-object-reference", - ;; in the latter case, no such information is available. To ensure maximum restorability of transaction logs, object - ;; references stored in lists are always considered to be relaxed references, which means that references to deleted - ;; objects are restored as NIL. Applications must be prepared to cope with NIL entries in such object lists (usually + ;; This is actually called in two contexts, when a slot-value is to + ;; be filled with a reference to a store object and when a list of + ;; store objects is read from the transaction log (%decode-list). + ;; In the former case, references two deleted objects are accepted + ;; when the slot pointing to the object is marked as being a + ;; "relaxed-object-reference", in the latter case, no such + ;; information is available. To ensure maximum restorability of + ;; transaction logs, object references stored in lists are always + ;; considered to be relaxed references, which means that references + ;; to deleted objects are restored as NIL. Applications must be + ;; prepared to cope with NIL entries in such object lists (usually ;; lists in slots). (let* ((id (%decode-integer stream)) (object (or (store-object-with-id id) - (warn "internal inconsistency during restore: can't find store object ~A in loaded store" id))) + (warn "internal inconsistency during restore: can't find store object ~A in loaded store" + id))) (container (first *current-object-slot*)) (slot-name (second *current-object-slot*))) (cond (object object) ((or *current-slot-relaxed-p* (not container)) (if container - (warn "Reference to inexistent object with id ~A in relaxed slot ~A of object with class ~A with ID ~A." + (warn "Reference to inexistent object with id ~A in relaxed slot ~A of object ~ + with class ~A with ID ~A." id slot-name (type-of container) (store-object-id container)) (warn "Reference to inexistent object with id ~A from unnamed container, returning NIL." id)) @@ -521,7 +545,8 @@ (setf (next-object-id (store-object-subsystem)) (1+ id))) nil) - (t (error "Reference to inexistent object with id ~A from slot ~A of object ~A with ID ~A." id slot-name (type-of container) + (t (error "Reference to inexistent object with id ~A from slot ~A of object ~A with ID ~A." + id slot-name (type-of container) (if container (store-object-id container) "unknown object")))))) (defmethod snapshot-subsystem ((store store) (subsystem store-object-subsystem))

1 0

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

29 Jul '08

Revision: 3671 Author: ksprotte URL: http://bknr.net/trac/changeset/3671 again whitespace cleanup + removed tabs U trunk/projects/bos/m2/allocation-cache.lisp U trunk/projects/bos/m2/allocation.lisp U trunk/projects/bos/m2/cert-daemon.lisp U trunk/projects/bos/m2/config.lisp U trunk/projects/bos/m2/contract-expiry.lisp U trunk/projects/bos/m2/export.lisp U trunk/projects/bos/m2/geometry.lisp U trunk/projects/bos/m2/m2-store.lisp U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/mail-generator.lisp U trunk/projects/bos/m2/make-certificate.lisp U trunk/projects/bos/m2/map.lisp U trunk/projects/bos/m2/news.lisp U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/m2/tiled-index.lisp U trunk/projects/bos/web/allocation-area-handlers.lisp U trunk/projects/bos/web/allocation-cache-handlers.lisp U trunk/projects/bos/web/boi-handlers.lisp U trunk/projects/bos/web/contract-handlers.lisp U trunk/projects/bos/web/contract-rss.lisp U trunk/projects/bos/web/contract-tree.lisp U trunk/projects/bos/web/kml-handlers.lisp U trunk/projects/bos/web/languages-handler.lisp U trunk/projects/bos/web/map-browser-handler.lisp U trunk/projects/bos/web/map-handlers.lisp U trunk/projects/bos/web/news-handlers.lisp U trunk/projects/bos/web/news-tags.lisp U trunk/projects/bos/web/packages.lisp U trunk/projects/bos/web/poi-handlers.lisp U trunk/projects/bos/web/reports-xml-handler.lisp U trunk/projects/bos/web/spendenquittung.lisp U trunk/projects/bos/web/sponsor-handlers.lisp U trunk/projects/bos/web/startup.lisp U trunk/projects/bos/web/tags.lisp U trunk/projects/bos/web/utf-8.lisp U trunk/projects/bos/web/utils.lisp U trunk/projects/bos/web/web-utils.lisp U trunk/projects/bos/web/webserver.lisp U trunk/projects/bos/web/website-language.lisp Change set too large, please see URL above

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