July 2008 - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

[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

[bknr-cvs] hans changed trunk/thirdparty/cl-unicode/build/read.lisp
by BKNR Commits 29 Jul '08

29 Jul '08

Revision: 3670 Author: hans URL: http://bknr.net/trac/changeset/3670 correct typo in special variable name U trunk/thirdparty/cl-unicode/build/read.lisp Modified: trunk/thirdparty/cl-unicode/build/read.lisp =================================================================== --- trunk/thirdparty/cl-unicode/build/read.lisp 2008-07-29 07:32:15 UTC (rev 3669) +++ trunk/thirdparty/cl-unicode/build/read.lisp 2008-07-29 07:35:26 UTC (rev 3670) @@ -275,7 +275,7 @@ data files and building the corresponding Lisp datastructures in memory." (fill-database) - (when *compile-verbose + (when *compile-verbose* (format t "~&;;; Building hash tables") (force-output)) (build-name-mappings)

1 0

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

29 Jul '08

Revision: 3669 Author: hans URL: http://bknr.net/trac/changeset/3669 Print progress diagnostics only when *compile-verbose* is set. U trunk/thirdparty/cl-unicode/build/dump.lisp U trunk/thirdparty/cl-unicode/build/read.lisp U trunk/thirdparty/cl-unicode/util.lisp Modified: trunk/thirdparty/cl-unicode/build/dump.lisp =================================================================== --- trunk/thirdparty/cl-unicode/build/dump.lisp 2008-07-28 19:11:30 UTC (rev 3668) +++ trunk/thirdparty/cl-unicode/build/dump.lisp 2008-07-29 07:32:15 UTC (rev 3669) @@ -106,8 +106,9 @@ location of this source file. Writes a Lisp header to the files unless NO-HEADER-P is true." `(let ((pathname (merge-pathnames ,relative-path *this-file*))) - (format t "~&;;; Writing source file ~A" (file-namestring pathname)) - (force-output) + (when *compile-verbose* + (format t "~&;;; Writing source file ~A" (file-namestring pathname)) + (force-output)) (with-open-file (,stream pathname :direction :output :if-exists :supersede) Modified: trunk/thirdparty/cl-unicode/build/read.lisp =================================================================== --- trunk/thirdparty/cl-unicode/build/read.lisp 2008-07-28 19:11:30 UTC (rev 3668) +++ trunk/thirdparty/cl-unicode/build/read.lisp 2008-07-29 07:32:15 UTC (rev 3669) @@ -43,8 +43,9 @@ (let ((variables (extract-variables bindings)) (types (extract-types bindings))) `(let ((pathname (merge-pathnames ,file-name (merge-pathnames "data/" *this-file*)))) - (format t "~&;;; Parsing Unicode file ~A" (file-namestring pathname)) - (force-output) + (when *compile-verbose* + (format t "~&;;; Parsing Unicode file ~A" (file-namestring pathname)) + (force-output)) (with-open-file (binary-in pathname :element-type 'flex:octet) ;; Unicode data files must be read as UTF-8 (let ((in (flex:make-flexi-stream binary-in :external-format '(:utf-8 :eol-style :lf)))) @@ -274,7 +275,8 @@ data files and building the corresponding Lisp datastructures in memory." (fill-database) - (format t "~&;;; Building hash tables") - (force-output) + (when *compile-verbose + (format t "~&;;; Building hash tables") + (force-output)) (build-name-mappings) (build-case-mapping)) Modified: trunk/thirdparty/cl-unicode/util.lisp =================================================================== --- trunk/thirdparty/cl-unicode/util.lisp 2008-07-28 19:11:30 UTC (rev 3668) +++ trunk/thirdparty/cl-unicode/util.lisp 2008-07-29 07:32:15 UTC (rev 3669) @@ -215,7 +215,9 @@ the *HANGUL-SYLLABLES-TO-CODE-POINTS* hash table. Used for CHARACTER-NAMED." (declare #.*standard-optimize-settings*) - (format t "~&;;; Computing Hangul syllable names") + (when *compile-verbose* + (format t "~&;;; Computing Hangul syllable names") + (force-output)) (loop for code-point from +first-hangul-syllable+ to +last-hangul-syllable+ for name = (compute-hangul-name code-point) do (setf (gethash name *hangul-syllables-to-code-points*) code-point)))

1 0

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

28 Jul '08

Revision: 3668 Author: ksprotte URL: http://bknr.net/trac/changeset/3668 project bos does not cause a single compilation warning U trunk/projects/bos/m2/bos.m2.asd U trunk/projects/bos/web/bos.web.asd Modified: trunk/projects/bos/m2/bos.m2.asd =================================================================== --- trunk/projects/bos/m2/bos.m2.asd 2008-07-28 19:09:03 UTC (rev 3667) +++ trunk/projects/bos/m2/bos.m2.asd 2008-07-28 19:11:30 UTC (rev 3668) @@ -8,28 +8,24 @@ :cl-pdf :screamer :cl-fad) :components ((:file "packages") (:file "geo-utm" :depends-on ("packages")) - (:file "geometry" :depends-on ("packages" "m2-store")) + (:file "geometry" :depends-on ("packages")) (:file "config" :depends-on ("packages")) - (:file "utils" :depends-on ("config")) - (:file "news" :depends-on ("poi")) - (:file "tiled-index" :depends-on ("config")) - (:file "mail-generator" :depends-on ("config")) - (:file "make-certificate" :depends-on ("config")) + (:file "utils" :depends-on ("packages")) + (:file "news" :depends-on ("packages" "poi")) + (:file "tiled-index" :depends-on ("packages")) + (:file "mail-generator" :depends-on ("packages")) + (:file "make-certificate" :depends-on ("packages")) (:file "initialization-subsystem" :depends-on ("packages")) - (:file "m2-store" :depends-on ("packages" "utils")) - (:file "m2" :depends-on ("initialization-subsystem" - "tiled-index" - "utils" - "make-certificate" - "mail-generator" - "geo-utm" - "geometry")) - (:file "m2-pdf" :depends-on ("m2")) - (:file "contract-expiry" :depends-on ("m2")) - (:file "allocation" :depends-on ("m2")) - (:file "allocation-cache" :depends-on ("packages" "geometry")) - (:file "poi" :depends-on ("utils" "allocation")) - (:file "import" :depends-on ("m2")) - (:file "map" :depends-on ("m2" "allocation" "geometry")) - (:file "export" :depends-on ("m2")) - (:file "cert-daemon" :depends-on ("config")))) + (:file "m2-store" :depends-on ("packages")) + (:file "m2" :depends-on ("config" "geometry" "initialization-subsystem" + "packages" "tiled-index" "utils")) + (:file "m2-pdf" :depends-on ("packages")) + (:file "contract-expiry" :depends-on ("packages")) + (:file "allocation" :depends-on ("geometry" "packages")) + (:file "allocation-cache" :depends-on ("allocation" "initialization-subsystem" + "packages" "utils")) + (:file "poi" :depends-on ("packages")) + (:file "import" :depends-on ("packages")) + (:file "map" :depends-on ("config" "packages" "tiled-index")) + (:file "export" :depends-on ("packages")) + (:file "cert-daemon" :depends-on ("packages")))) Modified: trunk/projects/bos/web/bos.web.asd =================================================================== --- trunk/projects/bos/web/bos.web.asd 2008-07-28 19:09:03 UTC (rev 3667) +++ trunk/projects/bos/web/bos.web.asd 2008-07-28 19:11:30 UTC (rev 3668) @@ -19,49 +19,36 @@ :depends-on (:bknr.web :bknr.modules :bos.m2 :cxml) :components ((:file "packages") - (:file "utf-8" :depends-on ("packages")) - (:file "config" :depends-on ("packages")) - (:file "dictionary" :depends-on ("packages" #+nil "startup")) - (:file "web-macros" :depends-on ("config")) - (:file "web-utils" :depends-on ("web-macros")) - (:file "cms-links" :depends-on ("web-utils")) - (:file "map-handlers" :depends-on ("web-utils")) - (:file "map-browser-handler" :depends-on ("web-utils")) - (:file "poi-handlers" :depends-on ("web-utils" "dictionary")) - (:file "boi-handlers" :depends-on ("web-utils")) - (:file "contract-handlers" :depends-on ("web-utils")) - (:file "contract-image-handler" :depends-on ("web-utils")) - (:file "reports-xml-handler" :depends-on ("boi-handlers")) - (:file "kml-utils" :depends-on ("packages")) + (:file "utf-8" :depends-on ("packages")) + (:file "config" :depends-on ("packages")) + (:file "dictionary" :depends-on ("packages" "startup")) + (:file "web-macros" :depends-on ("packages")) + (:file "web-utils" :depends-on ("packages")) + (:file "cms-links" :depends-on ("packages")) + (:file "map-handlers" :depends-on ("packages" "web-macros")) + (:file "map-browser-handler" :depends-on ("packages" "web-macros")) + (:file "poi-handlers" :depends-on ("dictionary" "packages" "web-macros")) + (:file "boi-handlers" :depends-on ("packages" "web-macros")) + (:file "contract-handlers" :depends-on ("packages" "web-macros")) + (:file "contract-image-handler" :depends-on ("packages")) + (:file "reports-xml-handler" :depends-on ("packages")) + (:file "kml-utils" :depends-on ("packages")) (:file "quad-tree" :depends-on ("packages")) - (:file "contract-tree" :depends-on ("quad-tree")) - (:file "sat-tree" :depends-on ("quad-tree" "contract-tree")) + (:file "contract-tree" :depends-on ("packages" "quad-tree")) + (:file "sat-tree" :depends-on ("packages" "quad-tree")) (:file "countries" :depends-on ("packages")) (:file "website-language" :depends-on ("packages")) - (:file "kml-handlers" :depends-on ("packages" - "website-language" - "web-macros" - "countries" - "dictionary")) - (:file "sponsor-handlers" :depends-on ("web-utils")) - (:file "news-handlers" :depends-on ("web-utils")) - (:file "allocation-area-handlers" :depends-on ("web-utils")) - (:file "allocation-cache-handlers" :depends-on ("web-utils")) - (:file "languages-handler" :depends-on ("web-utils")) - (:file "tags" :depends-on ("web-utils")) - (:file "news-tags" :depends-on ("web-utils")) - (:file "news-rss" :depends-on ("web-utils")) - (:file "contract-rss" :depends-on ("web-utils")) - (:file "webserver" :depends-on ("news-tags" - "tags" - "website-language" - "map-handlers" - "map-browser-handler" - "poi-handlers" - "boi-handlers" - "contract-handlers" - "sponsor-handlers" - "news-handlers" - "allocation-area-handlers")) - (:file "daily" :depends-on ("config" "webserver")) - (:file "startup" :depends-on ("config" "webserver")))) + (:file "kml-handlers" :depends-on ("dictionary" "kml-utils" "packages" + "web-macros" "countries")) + (:file "sponsor-handlers" :depends-on ("packages" "web-macros")) + (:file "news-handlers" :depends-on ("packages" "web-macros")) + (:file "allocation-area-handlers" :depends-on ("packages" "web-macros")) + (:file "allocation-cache-handlers" :depends-on ("packages" "web-macros")) + (:file "languages-handler" :depends-on ("packages" "web-macros")) + (:file "tags" :depends-on ("packages")) + (:file "news-tags" :depends-on ("packages")) + (:file "news-rss" :depends-on ("packages")) + (:file "contract-rss" :depends-on ("packages")) + (:file "webserver" :depends-on ("packages" "web-macros")) + (:file "daily" :depends-on ("packages")) + (:file "startup" :depends-on ("packages"))))

1 0

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

28 Jul '08

Revision: 3667 Author: ksprotte URL: http://bknr.net/trac/changeset/3667 removed allocation-area-gfx-handler (not needed anymore and causing a warning due to undefined function make-vga-colors) U trunk/projects/bos/web/allocation-area-handlers.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/web/allocation-area-handlers.lisp =================================================================== --- trunk/projects/bos/web/allocation-area-handlers.lisp 2008-07-28 18:33:35 UTC (rev 3666) +++ trunk/projects/bos/web/allocation-area-handlers.lisp 2008-07-28 19:09:03 UTC (rev 3667) @@ -95,51 +95,6 @@ (with-bos-cms-page (:title "Allocation area has been deactivated") (:h2 "The allocation area has been deactivated"))) -(defclass allocation-area-gfx-handler (editor-only-handler object-handler) - ()) - -(defmethod handle-object ((handler allocation-area-gfx-handler) allocation-area) - (cl-gd:with-image* ((allocation-area-width allocation-area) - (allocation-area-height allocation-area) t) - (with-slots (left top width height) allocation-area - (let ((colors (make-vga-colors)) - (vertices (mapcan #'(lambda (point) (list (- (car point) left) - (- (cdr point) top))) - (coerce (allocation-area-vertices allocation-area) 'list)))) - (loop with dest-y = 0 - for y = (+ top dest-y) - for tile-y = (* 90 (floor y 90)) - until (> tile-y (+ top height)) - for copy-height = (cond - ((< tile-y top) - (+ 90 (- tile-y top))) - ((> (+ tile-y 90) (+ top height)) - (- (+ tile-y 90) (+ top height))) - (t - 90)) - for source-y = (if (< tile-y top) (- 90 copy-height) 0) - do (loop with dest-x = 0 - for x = (+ left dest-x) - for tile-x = (* 90 (floor x 90)) - until (> tile-x (+ left width)) - for copy-width = (cond - ((< tile-x left) - (+ 90 (- tile-x left))) - ((> (+ tile-x 90) (+ left width)) - (- (+ tile-x 90) (+ left width))) - (t - 90)) - for source-x = (if (< tile-x left) (- 90 copy-width) 0) - do (cl-gd:copy-image (image-tile-image (get-map-tile x y)) - cl-gd:*default-image* - source-x source-y - dest-x dest-y - copy-width copy-height) - do (incf dest-x copy-width)) - do (incf dest-y copy-height)) - (cl-gd:draw-polygon vertices :color (elt colors 1)) - (emit-image-to-browser cl-gd:*default-image* :png))))) - (defclass create-allocation-area-handler (admin-only-handler form-handler) ()) Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-28 18:33:35 UTC (rev 3666) +++ trunk/projects/bos/web/webserver.lisp 2008-07-28 19:09:03 UTC (rev 3667) @@ -184,7 +184,6 @@ ("/m2-javascript" m2-javascript-handler) ("/sponsor-login" sponsor-login-handler) ("/create-allocation-area" create-allocation-area-handler) - ("/allocation-area-gfx" allocation-area-gfx-handler) ("/allocation-area" allocation-area-handler) ("/allocation-cache" allocation-cache-handler) ("/certificate" certificate-handler)

1 0

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

28 Jul '08

Revision: 3666 Author: ksprotte URL: http://bknr.net/trac/changeset/3666 some fixes to bos to avoid compilation warnings U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/web/bos.web.asd U trunk/projects/bos/web/quad-tree.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-28 15:14:31 UTC (rev 3665) +++ trunk/projects/bos/m2/m2.lisp 2008-07-28 18:33:35 UTC (rev 3666) @@ -377,7 +377,7 @@ (dolist (m2 (contract-m2s contract)) (collect (list (m2-x m2) (m2-y m2)))))) -(defun contracts-bounding-box (&optional (contracts (all-contracts))) +(defun contracts-bounding-box (&optional (contracts (class-instances 'contract))) (geometry:with-bounding-box-collect (collect) (dolist (contract contracts) (dolist (m2 (contract-m2s contract)) Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-07-28 15:14:31 UTC (rev 3665) +++ trunk/projects/bos/m2/packages.lisp 2008-07-28 18:33:35 UTC (rev 3666) @@ -140,8 +140,7 @@ #:contract #:make-contract #:contract-p - #:get-contract - #:all-contracts + #:get-contract #:contract-sponsor #:contract-paidp #:contract-download-only Modified: trunk/projects/bos/web/bos.web.asd =================================================================== --- trunk/projects/bos/web/bos.web.asd 2008-07-28 15:14:31 UTC (rev 3665) +++ trunk/projects/bos/web/bos.web.asd 2008-07-28 18:33:35 UTC (rev 3666) @@ -21,7 +21,7 @@ :components ((:file "packages") (:file "utf-8" :depends-on ("packages")) (:file "config" :depends-on ("packages")) - (:file "dictionary" :depends-on ("packages")) + (:file "dictionary" :depends-on ("packages" #+nil "startup")) (:file "web-macros" :depends-on ("config")) (:file "web-utils" :depends-on ("web-macros")) (:file "cms-links" :depends-on ("web-utils")) Modified: trunk/projects/bos/web/quad-tree.lisp =================================================================== --- trunk/projects/bos/web/quad-tree.lisp 2008-07-28 15:14:31 UTC (rev 3665) +++ trunk/projects/bos/web/quad-tree.lisp 2008-07-28 18:33:35 UTC (rev 3666) @@ -359,6 +359,15 @@ :order order) (nreverse nodes))) +(defmethod node-path ((node node-extension)) + (node-path (base-node node))) + +;;; *quad-tree* +(defvar *quad-tree*) + +(defun make-quad-tree () + (setq *quad-tree* (make-instance 'quad-node :geo-box *m2-geo-box*))) + (defmethod node-path ((node quad-node)) (let (prev-n path) (map-nodes (lambda (n) @@ -372,15 +381,6 @@ (geo-box node)))) :order :depth-first))) -(defmethod node-path ((node node-extension)) - (node-path (base-node node))) - -;;; *quad-tree* -(defvar *quad-tree*) - -(defun make-quad-tree () - (setq *quad-tree* (make-instance 'quad-node :geo-box *m2-geo-box*))) - (defun node-lod (node) (if (zerop (depth node)) '(:min 16 :max -1)

1 0

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

28 Jul '08

Revision: 3665 Author: ksprotte URL: http://bknr.net/trac/changeset/3665 fixed poi-javascript generation for changed poi-movie format U trunk/projects/bos/m2/poi.lisp Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-28 14:44:00 UTC (rev 3664) +++ trunk/projects/bos/m2/poi.lisp 2008-07-28 15:14:31 UTC (rev 3665) @@ -176,7 +176,7 @@ (when (poi-panoramas poi) (format t "poi.panoramas = [ ~{~D~^, ~} ];~%" (mapcar #'store-object-id (poi-panoramas poi)))) (when (poi-movies poi) - (format t "poi.movies = [ ~{~S~^, ~} ];~%" (poi-movies poi))) + (format t "poi.movies = [ ~{~S~^, ~} ];~%" (mapcar #'poi-movie-url (poi-movies poi)))) (loop for slot-name in '(title subtitle description) for javascript-name in '("imageueberschrift" "imageuntertitel" "imagetext") for slot-values = (mapcar (lambda (image)

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/pa
by BKNR Commits 28 Jul '08

28 Jul '08

Revision: 3664 Author: hans URL: http://bknr.net/trac/changeset/3664 Further testing with PayPal EC API U trunk/projects/quickhoney/src/packages.lisp U trunk/projects/quickhoney/src/paypal-test.lisp U trunk/projects/quickhoney/src/paypal.lisp Modified: trunk/projects/quickhoney/src/packages.lisp =================================================================== --- trunk/projects/quickhoney/src/packages.lisp 2008-07-28 14:39:46 UTC (rev 3663) +++ trunk/projects/quickhoney/src/packages.lisp 2008-07-28 14:44:00 UTC (rev 3664) @@ -56,7 +56,11 @@ (defpackage :paypal (:use :cl) (:export #:request - #:make-express-checkout-url)) + #:make-express-checkout-url + #:paypal-error + #:request-error + #:http-request-error + #:response-error)) (defpackage :paypal-test (:use :cl)) \ No newline at end of file Modified: trunk/projects/quickhoney/src/paypal-test.lisp =================================================================== --- trunk/projects/quickhoney/src/paypal-test.lisp 2008-07-28 14:39:46 UTC (rev 3663) +++ trunk/projects/quickhoney/src/paypal-test.lisp 2008-07-28 14:44:00 UTC (rev 3664) @@ -1,5 +1,4 @@ (in-package :paypal-test) - (defgeneric dispatch-request (request-type request) (:documentation "dispatch incoming http request")) @@ -18,14 +17,25 @@ (define-handler :checkout (request) (tbnl:redirect (paypal:make-express-checkout-url 10 :eur - :returnurl (format nil "http://~A:~A/return-paypal" response-host response-port) - :cancelurl (format nil "http://~A:~A/cancel-paypal" response-host response-port)))) + (format nil "http://~A:~A/return-paypal" *response-host* *response-port*) + (format nil "http://~A:~A/cancel-paypal" *response-host* *response-port*)))) (define-handler :stop (request) (throw 'stop-server nil)) (define-handler :return-paypal (request) - "Returned from paypal") + (with-output-to-string (*standard-output*) + (let* ((token (tbnl:get-parameter "token")) + (response (paypal:request "GetExpressCheckoutDetails" :token token)) + (payerid (getf response :payerid)) + (amt (getf response :amt)) + (currencycode (getf response :currencycode))) + (print (paypal:request "DoExpressCheckoutPayment" + :token token + :payerid payerid + :amt amt + :currencycode currencycode + :paymentaction "Sale"))))) (define-handler :cancel-paypal (request) "Cancelled") Modified: trunk/projects/quickhoney/src/paypal.lisp =================================================================== --- trunk/projects/quickhoney/src/paypal.lisp 2008-07-28 14:39:46 UTC (rev 3663) +++ trunk/projects/quickhoney/src/paypal.lisp 2008-07-28 14:44:00 UTC (rev 3664) @@ -2,20 +2,27 @@ (defparameter *paypal-url* "https://api-3t.sandbox.paypal.com/nvp" "NVP URL of the Paypal server") -(defparameter *paypal-user* "sdk-three_api1.sdk.com" +(defparameter *paypal-user* "hans.huebner_api1.gmail.com" "Username to use to authenticate at the Paypal server") -(defparameter *paypal-password* "QFZCWN5HZM8VBG7Q" +(defparameter *paypal-password* "62QFQPLEMM6P3M25" "Password to use to authenticate at the Paypal server") -(defparameter *paypal-signature* "A-IzJhZZjhg29XQ2qnhapuwxIDzyAZQ92FRP5dqBzVesOkzbdUONzmOU" +(defparameter *paypal-signature* "AFcWxV21C7fd0v3bYYYRCpSSRl31Ac-RAs1SuG20a1IoPMJ0WKbx0fdG" "Signature to use to authenticate at the Paypal server") -(define-condition request-error (error) +(define-condition paypal-error (error) + ()) + +(define-condition request-error (paypal-error) ((response :initarg :response))) -(define-condition http-request-error (error) +(define-condition http-request-error (paypal-error) ((http-status :initarg :http-status) (response-string :initarg :response-string))) +(define-condition response-error (paypal-error) + ((response :initarg :response) + (invalid-parameter :initarg :invalid-parameter))) + (defun decode-response (response) "Decode a paypal response string, which is URL encoded and follow list encoding rules. Returns the parameters as a plist." @@ -28,9 +35,9 @@ (index (parse-integer (aref registers 1))) (previous-value (gethash parameter hash))) (unless (= (length previous-value) index) - (error "unexpected list value ~A in Paypal response ~S" parameter-string response)) - (setf (gethash parameter hash) (append previous-value (list (hunchentoot:url-decode value))))) - (setf (gethash (intern parameter-string :keyword) hash) (hunchentoot:url-decode value)))))) + (error 'response-error :invalid-parameter parameter-string :response response)) + (setf (gethash parameter hash) (append previous-value (list (hunchentoot:url-decode value :utf-8))))) + (setf (gethash (intern parameter-string :keyword) hash) (hunchentoot:url-decode value :utf-8)))))) (loop for key being the hash-keys of hash collect key collect (gethash key hash)))) @@ -49,7 +56,9 @@ (cons "SIGNATURE" *paypal-signature*)) (loop for (param value) on args by #'cddr collect (cons (symbol-name param) - (if (stringp value) value (princ-to-string value)))))) + (if (stringp value) + value + (princ-to-string value)))))) (unless (= 200 http-status) (error 'http-request-error :http-status http-status :response-string response-string)) (let ((response (decode-response response-string)))

1 0