[bknr-cvs] ksprotte changed trunk/projects/bos/
BKNR Commits
bknr at bknr.net
Tue Jul 29 15:07:40 UTC 2008
Revision: 3681
Author: ksprotte
URL: http://bknr.net/trac/changeset/3681
checkpoint
U trunk/projects/bos/m2/contract-expiry.lisp
U trunk/projects/bos/m2/m2.lisp
U trunk/projects/bos/m2/packages.lisp
U trunk/projects/bos/m2/poi.lisp
U trunk/projects/bos/test/allocation.lisp
U trunk/projects/bos/web/contract-tree.lisp
U trunk/projects/bos/web/kml-handlers.lisp
U trunk/projects/bos/web/reports-xml-handler.lisp
Modified: trunk/projects/bos/m2/contract-expiry.lisp
===================================================================
--- trunk/projects/bos/m2/contract-expiry.lisp 2008-07-29 12:56:24 UTC (rev 3680)
+++ trunk/projects/bos/m2/contract-expiry.lisp 2008-07-29 15:07:40 UTC (rev 3681)
@@ -1,7 +1,7 @@
(in-package :bos.m2)
(defun delete-expired-contracts ()
- (let ((unpaid-contracts (remove-if #'contract-paidp (class-instances 'contract)))
+ (let ((unpaid-contracts (remove-if #'contract-paidp (all-contracts)))
deleting)
(dolist (contract unpaid-contracts)
(when (contract-is-expired contract)
Modified: trunk/projects/bos/m2/m2.lisp
===================================================================
--- trunk/projects/bos/m2/m2.lisp 2008-07-29 12:56:24 UTC (rev 3680)
+++ trunk/projects/bos/m2/m2.lisp 2008-07-29 15:07:40 UTC (rev 3681)
@@ -257,7 +257,9 @@
(download-only :update)
(cert-issued :read)
(worldpay-trans-id :update :initform nil)
- (expires :read :documentation "universal time which specifies the time the contract expires (is deleted) when it has not been paid for" :initform nil)
+ (expires :read :documentation "universal time which specifies the
+ time the contract expires (is deleted) when it has not been paid for"
+ :initform nil)
(largest-rectangle :update))
(:default-initargs
:m2s nil
@@ -379,7 +381,7 @@
(defun all-contracts ()
"Return list of all contracts in the system."
- (class-instances 'all-contracts))
+ (class-instances 'contract))
(defun contracts-bounding-box (&optional (contracts (all-contracts)))
(geometry:with-bounding-box-collect (collect)
Modified: trunk/projects/bos/m2/packages.lisp
===================================================================
--- trunk/projects/bos/m2/packages.lisp 2008-07-29 12:56:24 UTC (rev 3680)
+++ trunk/projects/bos/m2/packages.lisp 2008-07-29 15:07:40 UTC (rev 3681)
@@ -139,6 +139,7 @@
#:contract
#:make-contract
+ #:all-contracts
#:contract-p
#:get-contract
#:contract-sponsor
Modified: trunk/projects/bos/m2/poi.lisp
===================================================================
--- trunk/projects/bos/m2/poi.lisp 2008-07-29 12:56:24 UTC (rev 3680)
+++ trunk/projects/bos/m2/poi.lisp 2008-07-29 15:07:40 UTC (rev 3681)
@@ -28,20 +28,20 @@
(define-persistent-class poi-medium (textual-attributes-mixin)
((poi :read)))
-(deftransaction make-poi-medium (class-name &key language title subtitle description poi initargs)
+(deftransaction make-poi-medium (class-name &rest rest &key language title subtitle description poi initargs)
+ (declare (ignore 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))
+ (apply #'make-object class-name rest))
(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)))))
+ (when poi
+ (push poi-medium (poi-media poi)))
+ (update-textual-attributes poi-medium language
+ :title title
+ :subtitle subtitle
+ :description description))
(defmethod print-object ((object poi-medium) stream)
(print-unreadable-object (object stream :type t :identity nil)
@@ -56,6 +56,14 @@
(define-persistent-class poi-image (store-image poi-medium)
())
+;;; poi-airal
+(define-persistent-class poi-airal (store-image poi-medium)
+ ())
+
+;;; poi-panorama
+(define-persistent-class poi-panorama (store-image poi-medium)
+ ())
+
;;; poi-movie
(define-persistent-class poi-movie (poi-medium)
((url :update :initform nil)))
@@ -65,10 +73,10 @@
((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")
+ (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)))
+ (icon :update :initform "palme" :documentation "Name des Icons")
+ (media :update :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)))
@@ -76,12 +84,18 @@
(setf (slot-string poi 'description language) description)
poi))
+(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)))
(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-area poi)
(<= 6 (count-if (lambda (medium) (typep medium 'poi-image)) (poi-media poi)))
t))
@@ -94,6 +108,16 @@
(defun poi-center-lon-lat (poi)
(geo-utm:utm-x-y-to-lon-lat (+ +nw-utm-x+ (poi-center-x poi)) (- +nw-utm-y+ (poi-center-y poi)) +utm-zone+ t))
+(macrolet ((define-poi-medium-reader (name)
+ (let ((type (find-symbol (subseq (symbol-name name) 0 (1- (length (symbol-name name)))))))
+ (assert type)
+ `(defun ,name (poi)
+ (remove-if-not (lambda (medium) (typep medium ',type)) (poi-media poi))))))
+ (define-poi-medium-reader poi-images)
+ (define-poi-medium-reader poi-airals)
+ (define-poi-medium-reader poi-panoramas)
+ (define-poi-medium-reader poi-movies))
+
(defun make-poi-javascript (language)
"Erzeugt das POI-Javascript für das Infosystem"
(with-output-to-string (*standard-output*)
@@ -148,3 +172,19 @@
(format t "poi['y'] = ~D;~%" y)
(format t "poi['thumbnail'] = 0;~%")
(format t "pois.push(poi);~%")))))
+
+;;; poi schema evolution aids
+
+(define-modify-macro appendf (&rest args) append)
+
+(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'airals)) value)
+ (appendf (poi-media poi) (mapcar (lambda (obj) (change-class obj 'poi-airal :poi poi)) value)))
+
+(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'images)) value)
+ (appendf (poi-media poi) (mapcar (lambda (obj) (change-class obj 'poi-image :poi poi)) value)))
+
+(defmethod convert-slot-value-while-restoring ((poi poi) (slot-name (eql 'movies)) value)
+ (appendf (poi-media poi) (mapcar (lambda (url) (make-instance 'poi-movie :url url :poi poi)) value)))
+
+(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)))
Modified: trunk/projects/bos/test/allocation.lisp
===================================================================
--- trunk/projects/bos/test/allocation.lisp 2008-07-29 12:56:24 UTC (rev 3680)
+++ trunk/projects/bos/test/allocation.lisp 2008-07-29 15:07:40 UTC (rev 3681)
@@ -83,7 +83,7 @@
(with-transaction ()
(iter
(while (> size total-free))
- (for contract = (first (class-instances 'contract)))
+ (for contract = (first (all-contracts)))
(incf total-free (length (contract-m2s contract)))
(destroy-object contract)))
(finishes (make-contract sponsor size))
Modified: trunk/projects/bos/web/contract-tree.lisp
===================================================================
--- trunk/projects/bos/web/contract-tree.lisp 2008-07-29 12:56:24 UTC (rev 3680)
+++ trunk/projects/bos/web/contract-tree.lisp 2008-07-29 15:07:40 UTC (rev 3681)
@@ -355,7 +355,7 @@
;; has already been called
:base-node *quad-tree*
:name '*contract-tree*))
- (dolist (contract (class-instances 'contract))
+ (dolist (contract (all-contracts))
(when (contract-published-p contract)
(insert-contract *contract-tree* contract)))
(geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree*
Modified: trunk/projects/bos/web/kml-handlers.lisp
===================================================================
--- trunk/projects/bos/web/kml-handlers.lisp 2008-07-29 12:56:24 UTC (rev 3680)
+++ trunk/projects/bos/web/kml-handlers.lisp 2008-07-29 15:07:40 UTC (rev 3681)
@@ -249,7 +249,7 @@
())
(defmethod handle ((handler country-stats-handler))
- (let* ((contracts (class-instances 'contract))
+ (let* ((contracts (all-contracts))
(timestamp (reduce #'max contracts :key (lambda (contract)
(if (contract-paidp contract)
(store-object-last-change contract 0)
Modified: trunk/projects/bos/web/reports-xml-handler.lisp
===================================================================
--- trunk/projects/bos/web/reports-xml-handler.lisp 2008-07-29 12:56:24 UTC (rev 3680)
+++ trunk/projects/bos/web/reports-xml-handler.lisp 2008-07-29 15:07:40 UTC (rev 3681)
@@ -32,7 +32,7 @@
(or (not (contract-paidp contract))
(and *year*
(not (eql *year* (contract-year contract))))))
- (class-instances 'contract))
+ (all-contracts))
#'< :key #'contract-date)))
(setf name (intern (string-upcase name) :bos.web))
(apply (or (gethash name *report-generators*)
More information about the Bknr-cvs
mailing list