September 2008 - bknr-cvs@common-lisp.net

[bknr-cvs] ksprotte changed trunk/projects/bos/m2/map.lisp
by BKNR Commits 02 Sep '08

02 Sep '08

Revision: 3774 Author: ksprotte URL: http://bknr.net/trac/changeset/3774 better to partly revert last commit U trunk/projects/bos/m2/map.lisp Modified: trunk/projects/bos/m2/map.lisp =================================================================== --- trunk/projects/bos/m2/map.lisp 2008-09-02 15:50:01 UTC (rev 3773) +++ trunk/projects/bos/m2/map.lisp 2008-09-02 15:59:30 UTC (rev 3774) @@ -232,11 +232,11 @@ (defun import-tiles (directory) (bknr.datastore::without-sync () - (dolist (px (directory directory #+nil :all #+nil nil)) ; was :ALL NIL used on cmucl? + (dolist (px (directory directory :all nil)) (print px) (let ((x (parse-integer (car (last (pathname-directory px))))) (i 0)) - (dolist (image-pathname (directory px #+nil :all #+nil nil)) + (dolist (image-pathname (directory px :all nil)) (handler-case (let* ((y (parse-integer (pathname-name image-pathname))) (tile (ensure-original-map-tile x y)))

1 0

[bknr-cvs] ksprotte changed trunk/
by BKNR Commits 02 Sep '08

02 Sep '08

Revision: 3773 Author: ksprotte URL: http://bknr.net/trac/changeset/3773 once again STYLE-WARNING fixes U trunk/projects/bos/m2/map.lisp U trunk/thirdparty/unit-test/unit-test.lisp Modified: trunk/projects/bos/m2/map.lisp =================================================================== --- trunk/projects/bos/m2/map.lisp 2008-09-02 15:05:46 UTC (rev 3772) +++ trunk/projects/bos/m2/map.lisp 2008-09-02 15:50:01 UTC (rev 3773) @@ -232,11 +232,11 @@ (defun import-tiles (directory) (bknr.datastore::without-sync () - (dolist (px (directory directory :all nil)) + (dolist (px (directory directory #+nil :all #+nil nil)) ; was :ALL NIL used on cmucl? (print px) (let ((x (parse-integer (car (last (pathname-directory px))))) (i 0)) - (dolist (image-pathname (directory px #+nil :all #+nil nil)) ; was :ALL NIL used on cmucl? + (dolist (image-pathname (directory px #+nil :all #+nil nil)) (handler-case (let* ((y (parse-integer (pathname-name image-pathname))) (tile (ensure-original-map-tile x y))) Modified: trunk/thirdparty/unit-test/unit-test.lisp =================================================================== --- trunk/thirdparty/unit-test/unit-test.lisp 2008-09-02 15:05:46 UTC (rev 3772) +++ trunk/thirdparty/unit-test/unit-test.lisp 2008-09-02 15:50:01 UTC (rev 3773) @@ -134,10 +134,11 @@ (eq (test-result-status test) :crash)) (defmethod print-object ((result test-result) stream) - (format stream "#<TEST-RESULT FORM: ~A STATUS: ~A>" - (test-result-form result) - (test-result-status result) - (test-result-reason result))) + (print-unreadable-object (result stream :type t) + (format stream "FORM: ~A STATUS: ~A REASON: ~A" + (test-result-form result) + (test-result-status result) + (test-result-reason result)))) (defclass test-assert-result (test-result) ())

1 0

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

02 Sep '08

Revision: 3772 Author: ksprotte URL: http://bknr.net/trac/changeset/3772 fixed some style-warnings in bos U trunk/projects/bos/m2/map.lisp U trunk/projects/bos/m2/news.lisp U trunk/projects/bos/web/kml-utils.lisp Modified: trunk/projects/bos/m2/map.lisp =================================================================== --- trunk/projects/bos/m2/map.lisp 2008-09-02 14:36:21 UTC (rev 3771) +++ trunk/projects/bos/m2/map.lisp 2008-09-02 15:05:46 UTC (rev 3772) @@ -236,7 +236,7 @@ (print px) (let ((x (parse-integer (car (last (pathname-directory px))))) (i 0)) - (dolist (image-pathname (directory px :all nil)) + (dolist (image-pathname (directory px #+nil :all #+nil nil)) ; was :ALL NIL used on cmucl? (handler-case (let* ((y (parse-integer (pathname-name image-pathname))) (tile (ensure-original-map-tile x y))) Modified: trunk/projects/bos/m2/news.lisp =================================================================== --- trunk/projects/bos/m2/news.lisp 2008-09-02 14:36:21 UTC (rev 3771) +++ trunk/projects/bos/m2/news.lisp 2008-09-02 15:05:46 UTC (rev 3772) @@ -9,7 +9,7 @@ (title :none :initform (make-string-hash-table)) (text :none :initform (make-string-hash-table)))) -(deftransaction make-news-item (&optional language &key title text) +(deftransaction make-news-item (&key language title text) (let ((news-item (make-object 'news-item))) (setf (slot-string news-item 'title language) title) (setf (slot-string news-item 'text language) text) Modified: trunk/projects/bos/web/kml-utils.lisp =================================================================== --- trunk/projects/bos/web/kml-utils.lisp 2008-09-02 14:36:21 UTC (rev 3771) +++ trunk/projects/bos/web/kml-utils.lisp 2008-09-02 15:05:46 UTC (rev 3772) @@ -274,8 +274,9 @@ (with-element "listItemType" (text "checkHideChildren")) (with-element "bgColor" (text "00ffffff"))))) -(defun kml-network-link (href &key rect lod name http-query +(defun kml-network-link (href &key rect lod name fly-to-view hide-children) + ;; http-query could be added to &key args (with-element "NetworkLink" (when name (with-element "name" (text name))) (when rect (kml-region rect lod))

1 0

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

02 Sep '08

Revision: 3771 Author: ksprotte URL: http://bknr.net/trac/changeset/3771 POI edit handler is done. Added new generic function: poi-medium-creation-time (and a slot for poi-movie) U trunk/projects/bos/m2/packages.lisp U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/m2/packages.lisp =================================================================== --- trunk/projects/bos/m2/packages.lisp 2008-09-02 14:00:46 UTC (rev 3770) +++ trunk/projects/bos/m2/packages.lisp 2008-09-02 14:36:21 UTC (rev 3771) @@ -210,6 +210,7 @@ #:very-shallow-copy-textual-attributes #:poi-medium #:poi-medium-poi + #:poi-medium-creation-time #:make-poi-medium #:poi-image #:poi-airal Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-09-02 14:00:46 UTC (rev 3770) +++ trunk/projects/bos/m2/poi.lisp 2008-09-02 14:36:21 UTC (rev 3771) @@ -60,6 +60,10 @@ (print-unreadable-object (object stream :type t :identity nil) (format stream "~D" (store-object-id object)))) +(defgeneric poi-medium-creation-time (medium) + (:method ((medium blob)) + (blob-timestamp medium))) + (defmethod destroy-object :before ((poi-medium poi-medium)) (with-slots (poi) poi-medium (when poi @@ -79,7 +83,8 @@ ;;; poi-movie (defpersistent-class poi-movie (poi-medium) - ((url :accessor poi-movie-url :initarg :url :initform nil))) + ((url :accessor poi-movie-url :initarg :url :initform nil) + (created :initform (get-universal-time) :reader poi-medium-creation-time))) ;;; poi (defpersistent-class poi (textual-attributes-mixin) @@ -136,6 +141,9 @@ (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)) +(defmethod (setf poi-media) :after (value (poi poi)) + (setf (slot-value poi 'media) (sort (slot-value poi 'media) #'> :key #'poi-medium-creation-time))) + ;;; POI media are stored in one list - for convenience we provide ;;; accessors by type. POI-IMAGES e.g. returns a list of all ;;; POI-IMAGES in the same order as they appear in the media list. The Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-09-02 14:00:46 UTC (rev 3770) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-02 14:36:21 UTC (rev 3771) @@ -104,7 +104,7 @@ "[choose]")))))) (:tr (:td "icon") (:td (icon-chooser "icon" (poi-icon poi)))) - (:tr (:td "sat images") + (:tr (:td "images for sat-app") (:td ((:table) (:tr @@ -153,11 +153,20 @@ ((:table :border "1") (dolist (medium (poi-media poi)) (html (:tr (:td (:princ-safe (medium-pretty-type-string medium))) - (:td (:table (medium-handler-preview medium :small t) - (:tr (:td) - (:td (cmslink (format nil "/edit-poi-medium/~D?poi=~D" - (store-object-id medium) (store-object-id poi)) - "edit")))))))))))) + (:td (:table + (:colgroup ((:col :width "80")) ((:col :width "400"))) + (:tr (:td) + (:td (:b (:princ-safe (slot-string medium 'title language "[no title]")))) + (:td (:princ-safe (format-date-time (poi-medium-creation-time medium))))) + (:tr (:td ((:p :style "text-align:center;") + (cmslink (format nil "/edit-poi-medium/~D?poi=~D" + (store-object-id medium) (store-object-id poi)) + "edit")) + ((:p :style "text-align:center;") + (cmslink (format nil "/edit-poi-medium/~D?action=delete&ask-for-confirmation=on&poi=~D" + (store-object-id medium) (store-object-id poi)) + "delete"))) + ((:td :colspan "2") (medium-handler-preview medium :small t)))))))))))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :save)) (poi poi)) @@ -201,7 +210,7 @@ (html (cmslink (edit-object-url (poi-medium-poi medium)) "Back to POI") (content-language-chooser) - (:table (medium-handler-preview medium) + (:table (:tr (:td) (:td (medium-handler-preview medium))) (:tr ((:td :colspan "2" :height "10"))) ((:form :method "post" :enctype "multipart/form-data") ((:input :type "hidden" :name "poi" :value poi)) @@ -226,51 +235,48 @@ (submit-button "delete" "delete" :confirm "Really delete?"))))))))) (defgeneric medium-pretty-type-string (medium) - (:method ((medium poi-image)) "POI Image") - (:method ((medium poi-panorama)) "POI Panorama") - (:method ((medium poi-airal)) "POI Airal") - (:method ((medium poi-movie)) "POI Movie")) + (:method ((medium poi-image)) "Image") + (:method ((medium poi-panorama)) "Panorama") + (:method ((medium poi-airal)) "Airal") + (:method ((medium poi-movie)) "Movie")) (defgeneric medium-handler-preview (medium &key small) - (:method ((medium t) &key small) + (:method ((medium poi-medium) &key small) (declare (ignore small)) - (html ((:tr :colspan "2") "No preview"))) + (html "No preview")) (:method ((medium store-image) &key small) "The default method for store-images." (html - (:tr (:td "thumbnail") - (:td ((:a :href (format nil "/image/~A" (store-object-id medium)) - :target "_blank") - ((:img :src (format nil "/image/~A/thumbnail,,55,55" (store-object-id medium))))))) + ((:a :href (format nil "/edit-poi-medium/~A?poi=~A" + (store-object-id medium) (store-object-id (poi-medium-poi medium)))) + ((:img :src (format nil "/image/~A/thumbnail,,70,70" (store-object-id medium))))) (unless small (html - (:tr (:td "full image") - (:td ((:img :src (format nil "/image/~A" (store-object-id medium)))))))))) + (:p "Full size:" + (:br) + ((:img :src (format nil "/image/~A" (store-object-id medium))))))))) (:method ((medium poi-panorama) &key small) - (html - (:tr (:td "thumbnail") - (:td (if small - (html - ((:a :href (format nil "/image/~A" (store-object-id medium)) - :target "_blank") - ((:img :src (format nil "/image/~A/thumbnail,,500,100" (store-object-id medium)))))) - (html - ((:applet :archive "/static/ptviewer.jar" - :code "ptviewer.class" - :width "300" - :height "150") - ((:param :name "file" - :value (format nil "/image/~A" (store-object-id medium)))) - ((:param :name "quality" :value "3"))))))))) + (if small + (html + ((:a :href (format nil "/edit-poi-medium/~A?poi=~A" + (store-object-id medium) (store-object-id (poi-medium-poi medium)))) + ((:img :src (format nil "/image/~A/thumbnail,,500,100" (store-object-id medium)))))) + (html + ((:applet :archive "/static/ptviewer.jar" + :code "ptviewer.class" + :width "300" + :height "150") + ((:param :name "file" + :value (format nil "/image/~A" (store-object-id medium)))) + ((:param :name "quality" :value "3")))))) (:method ((medium poi-movie) &key small) (if small (call-next-method) (html - (:tr (:td "movie") - (:td ((:embed :src (poi-movie-url medium) - :type "application/x-shockwave-flash" - :allowFullScreen "true" - :width "425" :height "344")))))))) + ((:embed :src (poi-movie-url medium) + :type "application/x-shockwave-flash" + :allowFullScreen "true" + :width "425" :height "344")))))) (defgeneric medium-handler-validate-image-size (medium-or-type width height) (:method (medium-or-type width height) @@ -300,12 +306,22 @@ (:princ-safe (format nil "continue editing the ~A" type-string))))))) (defmethod handle-object-form ((handler edit-poi-medium-handler) (action (eql :delete)) (medium poi-medium)) - (let ((poi (poi-medium-poi medium)) - (type-string (medium-pretty-type-string medium))) - (delete-object medium) - (with-bos-cms-page (:title (format nil "~A has been deleted" type-string)) - (:h2 (format nil "The ~A has been deleted" type-string)) - "You may " (cmslink (edit-object-url poi) "continue editing the POI")))) + (with-query-params ((ask-for-confirmation nil boolean)) + (let ((poi (poi-medium-poi medium)) + (type-string (medium-pretty-type-string medium))) + (cond + (ask-for-confirmation + (with-bos-cms-page (:title (format nil "Really delete ~A?" type-string)) + (:h2 (format nil "Really delete ~A?" type-string)) + (:p "Yes, " (cmslink (format nil "/edit-poi-medium/~D?action=delete&poi=~D" + (store-object-id medium) (store-object-id poi)) + "delete it.")) + (:p "No, take me " (cmslink (edit-object-url poi) "back to the POI")))) + (t + (delete-object medium) + (with-bos-cms-page (:title (format nil "~A has been deleted" type-string)) + (:h2 (format nil "The ~A has been deleted" type-string)) + "You may " (cmslink (edit-object-url poi) "continue editing the POI"))))))) (defmethod handle-object-form ((handler edit-poi-medium-handler) (action (eql :upload)) medium) (flet ((make-new-medium (new-medium-type poi)

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/src/image.lisp
by BKNR Commits 02 Sep '08

02 Sep '08

Revision: 3770 Author: hans URL: http://bknr.net/trac/changeset/3770 reindent U trunk/projects/quickhoney/src/image.lisp Modified: trunk/projects/quickhoney/src/image.lisp =================================================================== --- trunk/projects/quickhoney/src/image.lisp 2008-09-02 10:57:55 UTC (rev 3769) +++ trunk/projects/quickhoney/src/image.lisp 2008-09-02 14:00:46 UTC (rev 3770) @@ -2,9 +2,9 @@ (define-persistent-class quickhoney-image (store-image rss-item) ((client :update :initform nil - :index-type hash-index :index-initargs (:test #'equal) - :index-reader images-for-client - :index-keys all-clients) + :index-type hash-index :index-initargs (:test #'equal) + :index-reader images-for-client + :index-keys all-clients) (spider-keywords :update :initform nil) (products :update :initform nil))) @@ -20,7 +20,7 @@ (mapc (lambda (image) (persistent-change-class image 'quickhoney-image) (store-object-remove-keywords image 'bknr.web::keywords '(:import))) - (get-keywords-intersection-store-images '(:import)))) + (get-keywords-intersection-store-images '(:import)))) (defmethod quickhoney-image-category ((image quickhoney-image)) (first (intersection (store-image-keywords image) '(:pixel :vector :news :contact)))) @@ -32,7 +32,7 @@ (format nil "~@[~A~]/index#~(~A~@[/~A~]~)/~A" (unless internal (format nil "http://~A" (website-host))) - (quickhoney-image-category image) (quickhoney-image-subcategory image) (store-image-name image))) + (quickhoney-image-category image) (quickhoney-image-subcategory image) (store-image-name image))) (define-persistent-class quickhoney-animation-image (quickhoney-image) ((animation :update)))

1 0

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

02 Sep '08

Revision: 3769 Author: ksprotte URL: http://bknr.net/trac/changeset/3769 updated ptviewer to latest; its now used in the CMS U trunk/projects/bos/payment-website/static/ptviewer.jar U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/payment-website/static/ptviewer.jar =================================================================== (Binary files differ) Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-09-02 10:22:51 UTC (rev 3768) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-02 10:57:55 UTC (rev 3769) @@ -247,12 +247,21 @@ (:tr (:td "full image") (:td ((:img :src (format nil "/image/~A" (store-object-id medium)))))))))) (:method ((medium poi-panorama) &key small) - (declare (ignore small)) (html (:tr (:td "thumbnail") - (:td ((:a :href (format nil "/image/~A" (store-object-id medium)) - :target "_blank") - ((:img :src (format nil "/image/~A/thumbnail,,500,100" (store-object-id medium))))))))) + (:td (if small + (html + ((:a :href (format nil "/image/~A" (store-object-id medium)) + :target "_blank") + ((:img :src (format nil "/image/~A/thumbnail,,500,100" (store-object-id medium)))))) + (html + ((:applet :archive "/static/ptviewer.jar" + :code "ptviewer.class" + :width "300" + :height "150") + ((:param :name "file" + :value (format nil "/image/~A" (store-object-id medium)))) + ((:param :name "quality" :value "3"))))))))) (:method ((medium poi-movie) &key small) (if small (call-next-method)

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/startup.lisp
by BKNR Commits 02 Sep '08

02 Sep '08

Revision: 3768 Author: ksprotte URL: http://bknr.net/trac/changeset/3768 we need hunchentoot:*use-user-agent-for-sessions* nil (see comment in source) U trunk/projects/bos/web/startup.lisp Modified: trunk/projects/bos/web/startup.lisp =================================================================== --- trunk/projects/bos/web/startup.lisp 2008-09-02 09:14:28 UTC (rev 3767) +++ trunk/projects/bos/web/startup.lisp 2008-09-02 10:22:51 UTC (rev 3768) @@ -44,7 +44,10 @@ (when *webserver* (hunchentoot:stop-server *webserver*)) (setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf) - hunchentoot:*rewrite-for-session-urls* nil) + hunchentoot:*rewrite-for-session-urls* nil + ;; the reason for the following setting is that ptviewer sends + ;; a different User-Agent -- (when requesting PTDefault.html) + hunchentoot:*use-user-agent-for-sessions* nil) (setq *webserver* (hunchentoot:start-server :port *port* :threaded (not debug) :persistent-connections-p (not debug))) (if start-frontend

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/poi-handlers.lisp
by BKNR Commits 02 Sep '08

02 Sep '08

Revision: 3767 Author: ksprotte URL: http://bknr.net/trac/changeset/3767 avoiding a Java-script error when loading the sat-app, by defaulting sponsor-country to "de" instead of NIL U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-09-02 08:37:24 UTC (rev 3766) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-02 09:14:28 UTC (rev 3767) @@ -341,7 +341,7 @@ (store-object-id contract) (format-date-time (contract-date contract) :js-style t) (or (user-full-name (contract-sponsor contract)) "anonymous") - (sponsor-country (contract-sponsor contract)) + (or (sponsor-country (contract-sponsor contract)) "de") (length (contract-m2s contract)))) (defmethod handle ((handler poi-javascript-handler))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/payment-website/static/bos.js
by BKNR Commits 02 Sep '08

02 Sep '08

Revision: 3766 Author: ksprotte URL: http://bknr.net/trac/changeset/3766 window_infosys detects the language from a document body attribute. fixed the namespace: bos:lang U trunk/projects/bos/payment-website/static/bos.js Modified: trunk/projects/bos/payment-website/static/bos.js =================================================================== --- trunk/projects/bos/payment-website/static/bos.js 2008-09-01 19:40:08 UTC (rev 3765) +++ trunk/projects/bos/payment-website/static/bos.js 2008-09-02 08:37:24 UTC (rev 3766) @@ -22,7 +22,7 @@ // *** extrafenster fuer satellitenkarte *** // function window_infosys() { - var url = "/infosystem/" + document.body.lang + "/satellitenkarte.htm"; + var url = "/infosystem/" + document.body.getAttribute("bos:lang") + "/satellitenkarte.htm"; var sponsorid_input = document.getElementById('sponsorid-input'); var password_input = document.getElementById('password-input');

1 0

[bknr-cvs] hans changed trunk/bknr/web/src/web/t
by BKNR Commits 01 Sep '08

01 Sep '08

Revision: 3765 Author: hans URL: http://bknr.net/trac/changeset/3765 Fix templater. U trunk/bknr/web/src/web/tags.lisp U trunk/bknr/web/src/web/template-handler.lisp Modified: trunk/bknr/web/src/web/tags.lisp =================================================================== --- trunk/bknr/web/src/web/tags.lisp 2008-09-01 16:17:30 UTC (rev 3764) +++ trunk/bknr/web/src/web/tags.lisp 2008-09-01 19:40:08 UTC (rev 3765) @@ -13,7 +13,7 @@ template))) (let* ((expander *template-expander*) (pathname (find-template-pathname expander template)) - (toplevel (get-cached-template pathname expander)) + (toplevel (parsed-template-dom (get-cached-template pathname expander))) (*toplevel-children* *tag-children*)) (emit-template-node *template-expander* toplevel))) Modified: trunk/bknr/web/src/web/template-handler.lisp =================================================================== --- trunk/bknr/web/src/web/template-handler.lisp 2008-09-01 16:17:30 UTC (rev 3764) +++ trunk/bknr/web/src/web/template-handler.lisp 2008-09-01 19:40:08 UTC (rev 3765) @@ -51,7 +51,7 @@ (function-name (string-upcase name))) (or (gethash function-name (or (gethash (symbol-name package-name) *template-functions*) (error "can't find package ~A in tag function registry" package-name))) - (error "can't find tag function ~A:~A in command package ~A" ns name package-name)))) + (error "can't find tag function ~A in command package ~A" name package-name)))) (defclass local-template-expander () ((parent :initarg :parent :reader local-template-expander-parent)

1 0