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

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

04 Sep '08

Revision: 3789 Author: ksprotte URL: http://bknr.net/trac/changeset/3789 fixed country-stats U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/web/kml-handlers.lisp Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-09-04 10:52:31 UTC (rev 3788) +++ trunk/projects/bos/m2/m2.lisp 2008-09-04 12:18:43 UTC (rev 3789) @@ -624,8 +624,7 @@ (defun add-to-contract-stats (contract) (let* ((area (contract-area contract)) (sponsor (contract-sponsor contract)) - (new-sponsor-p (alexandria:length= 1 (sponsor-contracts sponsor))) - (country (sponsor-country sponsor))) + (new-sponsor-p (alexandria:length= 1 (sponsor-contracts sponsor)))) (with-slots (sold-m2s paying-sponsors country-sponsors last-contracts) *contract-stats* ;; sold-m2s @@ -634,8 +633,9 @@ (when new-sponsor-p (incf paying-sponsors)) ;; country-sponsors - (when country - (let ((country-stat (gethash country country-sponsors))) + (when (sponsor-country sponsor) + (let* ((country (make-keyword-from-string (sponsor-country sponsor))) + (country-stat (gethash country country-sponsors))) (unless country-stat (setq country-stat (setf (gethash country country-sponsors) (make-country-stat)))) (when new-sponsor-p Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-09-04 10:52:31 UTC (rev 3788) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-09-04 12:18:43 UTC (rev 3789) @@ -286,9 +286,9 @@ (attribute "id" "countryStatsStyle") (with-element "IconStyle" (with-element "Icon" - ;; (with-element "href" (text "http://maps.google.com/mapfiles/kml/pal3/icon23.png")) (with-element "href" (text (format nil "http://~a/static/Orang_weiss.png" (website-host))))))) (do-sponsor-countries (country) + (assert (keywordp country)) (let ((coords (cdr (assoc country *country-coords*)))) (when coords (destructuring-bind (lon lat) @@ -296,7 +296,6 @@ (multiple-value-bind (number-of-paying-sponsors number-of-sold-m2s) (contract-stats-for-country country) (with-element "Placemark" - ;; (with-element "name" (text (format nil "~a ~a" (car country-contracts) (length (cdr country-contracts))))) (with-element "styleUrl" (text "#countryStatsStyle")) (with-element "description" (text (format nil "<p>~A</p><table><tbody><tr><td>~A:</td><td>~D ~A</td></tr>

1 0

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

04 Sep '08

Revision: 3788 Author: ksprotte URL: http://bknr.net/trac/changeset/3788 display the web link of all poi media 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-04 10:40:59 UTC (rev 3787) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-04 10:52:31 UTC (rev 3788) @@ -223,6 +223,9 @@ :br (submit-button "upload" "upload")))) (:tr ((:td :colspan "2" :height "10"))) + (:tr (:td "web link") + (:td (:princ-safe (medium-web-link medium)))) + (:tr ((:td :colspan "2" :height "10"))) ((:form :method "post") (:tr (:td "title") (:td (text-field "title" @@ -244,6 +247,13 @@ (:method ((medium poi-airal)) "Airal") (:method ((medium poi-movie)) "Movie")) +(defgeneric medium-web-link (medium) + (:method ((medium store-image)) + (format nil "http://~A/image/~A" + (website-host) (store-object-id medium))) + (:method ((medium poi-movie)) + (poi-movie-url medium))) + (defgeneric medium-handler-preview (medium &key small) (:method ((medium poi-medium) &key small) (declare (ignore small))

1 0

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

04 Sep '08

Revision: 3787 Author: ksprotte URL: http://bknr.net/trac/changeset/3787 clearer interface for kml-upload-handler U trunk/projects/bos/web/kml-handlers.lisp Modified: trunk/projects/bos/web/kml-handlers.lisp =================================================================== --- trunk/projects/bos/web/kml-handlers.lisp 2008-09-04 09:49:18 UTC (rev 3786) +++ trunk/projects/bos/web/kml-handlers.lisp 2008-09-04 10:40:59 UTC (rev 3787) @@ -58,9 +58,22 @@ ;; we want this after the processing (:p (:format "last-change: ~A" (format-date-time (store-object-last-change kml-root-data 0))) + " " (cmslink (format nil "/kml-upload?lang=~A&action=download" language) "download current version"))))) - (submit-button "upload" "upload")))))) + (submit-button "upload" "upload")) + (:p "Please note that the " (:b "download current version") + " links above show you the kml files exactly like you + uploaded them. These are not the KML files as seen by the + users.") + (:p "For the actually served kml files some automatic + replacements are being done. You can inspect those by the + following links:") + (:p (dolist (kml-root-data (class-instances 'kml-root-data)) + (let ((language (language kml-root-data))) + (html (cmslink (format nil "/kml-root?lang=~A" language) + (:format "kml ~A" language)) + " ")))))))) (defmethod handle-form ((handler kml-upload-handler) (action (eql :download))) (with-query-params (lang)

1 0

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

04 Sep '08

Revision: 3786 Author: ksprotte URL: http://bknr.net/trac/changeset/3786 contract-tree image update daemon: avoid error in delete-file if (blob-pathname old-store-image) of old-store-image does not exist U trunk/projects/bos/web/contract-tree.lisp Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-09-04 09:24:47 UTC (rev 3785) +++ trunk/projects/bos/web/contract-tree.lisp 2008-09-04 09:49:18 UTC (rev 3786) @@ -270,7 +270,10 @@ (setf (image node) new-store-image) ;; delete the old one (when old-store-image - (delete-file (blob-pathname old-store-image)) + (if (probe-file (blob-pathname old-store-image)) + (delete-file (blob-pathname old-store-image)) + (warn "Intended to delete ~A of ~A.~%But it already does not exist." + (blob-pathname old-store-image) old-store-image)) (delete-object old-store-image))))))) (defun contract-node-update-image-needed-p (node)

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/util.lisp
by BKNR Commits 04 Sep '08

04 Sep '08

Revision: 3785 Author: hans URL: http://bknr.net/trac/changeset/3785 support non-standard %u notation in URL-DECODE U trunk/thirdparty/hunchentoot/util.lisp Modified: trunk/thirdparty/hunchentoot/util.lisp =================================================================== --- trunk/thirdparty/hunchentoot/util.lisp 2008-09-03 16:50:27 UTC (rev 3784) +++ trunk/thirdparty/hunchentoot/util.lisp 2008-09-04 09:24:47 UTC (rev 3785) @@ -229,32 +229,57 @@ ((#\") (write-string "\\\"" out)) (otherwise (write-char char out))))))) +(defmacro upgrade-vector (vector new-type &key converter (new-length `(array-total-size ,vector))) + `(setf ,vector (loop + with new-vector = (make-array ,new-length + :element-type ,new-type + :fill-pointer (length vector)) + for i from 0 below (length ,vector) + do (setf (aref new-vector i) ,(if converter + `(funcall ,converter (aref ,vector i)) + `(aref ,vector i))) + finally (return new-vector)))) + (defun url-decode (string &optional (external-format *hunchentoot-default-external-format*)) "Decodes a URL-encoded STRING which is assumed to be encoded using the external format EXTERNAL-FORMAT." - (let ((vector (make-array (length string) - :element-type 'octet - :fill-pointer 0))) - (loop with percent-p and buff - for char of-type character across string - for i from 0 - when buff do - (vector-push (parse-integer string - :start (1- i) - :end (1+ i) - :radix 16) - vector) - (setq buff nil) - else when percent-p - do (setq buff t - percent-p nil) - else when (char= char #\%) - do (setq percent-p t) - else do (vector-push (char-code (case char - ((#\+) #\Space) - (otherwise char))) - vector)) - (octets-to-string vector :external-format external-format))) + (loop + with vector = (make-array (length string) :element-type 'octet :fill-pointer 0) + with i = 0 + with unicode + for char = (aref string i) + do (labels ((decode-hex (length) + (prog1 + (parse-integer string :start i :end (+ i length) :radix 16) + (incf i length))) + (push-integer (integer) + (vector-push integer vector)) + (peek () + (aref string i)) + (advance () + (setf char (peek)) + (incf i))) + (cond + ((char= #\% char) + (advance) + (cond + ((char= #\u (peek)) + (unless unicode + (setf unicode t) + (upgrade-vector vector '(integer 0 65535))) + (advance) + (push-integer (decode-hex 4))) + (t + (push-integer (decode-hex 2))))) + (t + (push-integer (char-code (case char + ((#\+) #\Space) + (otherwise char)))) + (advance)))) + while (< i (length string)) + finally (return (if unicode + (upgrade-vector vector 'character :converter #'code-char) + (octets-to-string vector :external-format external-format))))) (defun form-url-encoded-list-to-alist (form-url-encoded-list &optional (external-format *hunchentoot-default-external-format*))

1 0

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

03 Sep '08

Revision: 3784 Author: ksprotte URL: http://bknr.net/trac/changeset/3784 "Keine Urkunde" Option f?\195?\188r manuell eingerichtete Sponsoren U trunk/projects/bos/web/sponsor-handlers.lisp Modified: trunk/projects/bos/web/sponsor-handlers.lisp =================================================================== --- trunk/projects/bos/web/sponsor-handlers.lisp 2008-09-03 16:19:44 UTC (rev 3783) +++ trunk/projects/bos/web/sponsor-handlers.lisp 2008-09-03 16:50:27 UTC (rev 3784) @@ -99,19 +99,22 @@ (:td (textarea-field "address" :rows 5 :cols 40))) (:tr (:td "Issue donation cert at the end of the year") (:td (checkbox-field "donationcert-yearly" "" :checked nil))) + (:tr (:td "Sponsor wants a printed certificate") + (:td (checkbox-field "want-print" "" :checked nil))) (:tr (:td (submit-button "create" "create" :formcheck "javascript:return check_complete_sale()")))))))))) (defun date-to-universal (date-string) (apply #'encode-universal-time 0 0 0 (mapcar #'parse-integer (split #?r"\." date-string)))) (defmethod handle-object-form ((handler edit-sponsor-handler) (action (eql :create)) (sponsor (eql nil))) - (with-query-params (numsqm country email name address date language) + (with-query-params (numsqm country email name address date language want-print) (let* ((sponsor (make-sponsor :email email :country country :language language)) (contract (make-contract sponsor (parse-integer numsqm) :paidp (format nil "~A: manually created by ~A" (format-date-time (get-universal-time)) (user-login (bknr.web:bknr-session-user))) - :date (date-to-universal date)))) + :date (date-to-universal date) + :download-only (not want-print)))) (contract-issue-cert contract name :address address :language language) (send-to-postmaster #'mail-backoffice-sponsor-data contract numsqm country email name address language (all-request-params)) (redirect (format nil "/edit-sponsor/~D" (store-object-id sponsor))))))

1 0

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

03 Sep '08

Revision: 3783 Author: ksprotte URL: http://bknr.net/trac/changeset/3783 fixed determination of DOWNLOAD-ONLY in MAIL-TRANSFER If the sponsor has paid less than *mail-certificate-threshold*, it is download-only without further choice. - But now DOWNLOAD-ONLY will still be T, if the sponsor did not want a print certificate. (or (< (contract-price contract) *mail-certificate-threshold*) (not want-print)) U trunk/projects/bos/web/tags.lisp Modified: trunk/projects/bos/web/tags.lisp =================================================================== --- trunk/projects/bos/web/tags.lisp 2008-09-03 15:14:41 UTC (rev 3782) +++ trunk/projects/bos/web/tags.lisp 2008-09-03 16:19:44 UTC (rev 3783) @@ -124,8 +124,9 @@ contract-id name vorname strasse plz ort telefon want-print email donationcert-yearly) - (let* ((contract (store-object-with-id (parse-integer contract-id))) - (download-only (< (contract-price contract) *mail-certificate-threshold*))) + (let* ((contract (store-object-with-id (parse-integer contract-id))) + (download-only (or (< (contract-price contract) *mail-certificate-threshold*) + (not want-print)))) (with-transaction (:prepare-before-mail) (setf (contract-download-only contract) download-only) (setf (sponsor-country (contract-sponsor contract)) country))

1 0

[bknr-cvs] hans changed trunk/projects/bos/web/webserver.lisp
by BKNR Commits 03 Sep '08

03 Sep '08

Revision: 3782 Author: hans URL: http://bknr.net/trac/changeset/3782 Publish ge resources directory. U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-09-03 15:12:47 UTC (rev 3781) +++ trunk/projects/bos/web/webserver.lisp 2008-09-03 15:14:41 UTC (rev 3782) @@ -226,6 +226,8 @@ (publish-directory :prefix "/static/" :destination (merge-pathnames "static/" website-directory)) + (publish-directory :prefix "/ge/" + :destination (merge-pathnames "ge/" website-directory)) (publish-directory :prefix "/images/" :destination (merge-pathnames "images/" website-directory)) (publish-directory :prefix "/infosystem/"

1 0

[bknr-cvs] hans changed trunk/projects/bos/payment-website/ge/
by BKNR Commits 03 Sep '08

03 Sep '08

Revision: 3781 Author: hans URL: http://bknr.net/trac/changeset/3781 Add empty directory for Google Earth resources. A trunk/projects/bos/payment-website/ge/

1 0

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

03 Sep '08

Revision: 3780 Author: ksprotte URL: http://bknr.net/trac/changeset/3780 more defensive coding in MAKE-POI-JAVASCRIPT to avoid generating invalid javascript (which is hard to debug) U trunk/projects/bos/m2/poi.lisp Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-09-03 12:56:00 UTC (rev 3779) +++ trunk/projects/bos/m2/poi.lisp 2008-09-03 14:51:57 UTC (rev 3780) @@ -110,7 +110,8 @@ :documentation "liste aller poi-medien, wie poi-image, poi-airal ..."))) -(defmethod convert-slot-value-while-restoring ((object poi) (slot-name (eql 'published)) published) +(defmethod convert-slot-value-while-restoring ((object poi) (slot-name (eql 'published)) + published) (setf (slot-value object 'published-web) published)) (deftransaction make-poi (name &rest rest &key area language title subtitle description) @@ -229,7 +230,13 @@ (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~^, ~} ];~%" (mapcar #'poi-movie-url (poi-movies poi)))) + (format t "poi.movies = [ ~{~S~^, ~} ];~%" + (mapcar #'(lambda (movie) + (assert (stringp (poi-movie-url movie)) nil + "POI-MOVIE-URL of ~S is ~S, but should be a string" + movie (poi-movie-url movie)) + (poi-movie-url movie)) + (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] ksprotte changed trunk/projects/bos/
by BKNR Commits 03 Sep '08

03 Sep '08

Revision: 3779 Author: ksprotte URL: http://bknr.net/trac/changeset/3779 :published-web und :published-earth f?\195?\188r POIs 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-03 11:43:11 UTC (rev 3778) +++ trunk/projects/bos/m2/packages.lisp 2008-09-03 12:56:00 UTC (rev 3779) @@ -221,7 +221,8 @@ #:poi-name #:find-poi #:all-pois - #:poi-published + #:poi-published-web + #:poi-published-earth #:poi-area #:poi-icon #:poi-media Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-09-03 11:43:11 UTC (rev 3778) +++ trunk/projects/bos/m2/poi.lisp 2008-09-03 12:56:00 UTC (rev 3779) @@ -93,9 +93,12 @@ :index-type string-unique-index :index-reader find-poi :index-values all-pois :documentation "symbolischer name") - (published - :accessor poi-published :initarg :published :initform nil - :documentation "wenn dieses flag nil ist, wird der poi in den uis nicht angezeigt") + (published-web + :accessor poi-published-web :initarg :published-web :initform nil + :documentation "wenn dieses flag nil ist, wird der poi auf der Website nicht angezeigt") + (published-earth + :accessor poi-published-earth :initarg :published-earth :initform nil + :documentation "wenn dieses flag nil ist, wird der poi in Google Earth nicht angezeigt") (area :accessor poi-area :initarg :area :initform nil :documentation "polygon mit den poi-koordinaten") @@ -106,6 +109,10 @@ :accessor poi-media :initarg :media :initform nil :documentation "liste aller poi-medien, wie poi-image, poi-airal ..."))) + +(defmethod convert-slot-value-while-restoring ((object poi) (slot-name (eql 'published)) published) + (setf (slot-value object 'published-web) published)) + (deftransaction make-poi (name &rest rest &key area language title subtitle description) (declare (ignore area)) (assert (if (or title subtitle description) language t) nil @@ -116,10 +123,12 @@ (defmethod destroy-object :before ((poi poi)) (mapc #'delete-object (poi-media poi))) -(deftransaction update-poi (poi &key published icon area) - (check-type published boolean) +(deftransaction update-poi (poi &key published-web published-earth icon area) + (check-type published-web boolean) + (check-type published-earth boolean) (check-type area list) - (setf (poi-published poi) published) + (setf (poi-published-web poi) published-web + (poi-published-earth poi) published-earth) (when icon (setf (poi-icon poi) icon)) (when area @@ -191,7 +200,7 @@ (format t "var anzahlVerkauft = ~D;~%" (number-of-sold-sqm)) (format t "var pois = new Array;~%") (dolist (poi (sort (remove-if #'(lambda (poi) (or (not (poi-complete poi language)) - (not (poi-published poi)))) + (not (poi-published-web poi)))) (store-objects-with-class 'poi)) #'(lambda (poi-1 poi-2) (string-lessp (slot-string poi-1 'title language) (slot-string poi-2 'title language))))) (format t " Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-09-03 11:43:11 UTC (rev 3778) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-03 12:56:00 UTC (rev 3779) @@ -73,7 +73,8 @@ (:tr (:td "name") (:td (:princ-safe (poi-name poi)))) (:tr (:td "published") - (:td (checkbox-field "published" "published" :checked (poi-published poi)))) + (:td (checkbox-field "published-web" "published-web" :checked (poi-published-web poi)) " " + (checkbox-field "published-earth" "published-earth" :checked (poi-published-earth poi)))) (:tr (:td "title") (:td (text-field "title" :value (slot-string poi 'title language)))) @@ -88,10 +89,11 @@ (:tr (:td "location") (:td (flet ((format-chosen-url () (encode-urlencoded - (format nil "~A?action=save&language=~A&~:[~;published=on~]" + (format nil "~A?action=save&language=~A&~:[~;published-web=on~]&~:[~;published-earth=on~]" (hunchentoot:script-name*) language - (poi-published poi))))) + (poi-published-web poi) + (poi-published-earth poi))))) (cond ((poi-area poi) (html (:princ-safe (format nil "~D/~D " (first (poi-area poi)) (second (poi-area poi))))) @@ -170,7 +172,8 @@ (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :save)) (poi poi)) - (with-query-params ((published nil boolean) + (with-query-params ((published-web nil boolean) + (published-earth nil boolean) title subtitle description language (x nil integer) (y nil integer) @@ -181,7 +184,8 @@ :subtitle subtitle :description description) (update-poi poi - :published published + :published-web published-web + :published-earth published-earth :area (when (and x y) (list x y)) :icon icon) (with-bos-cms-page (:title "POI has been updated") @@ -592,7 +596,7 @@ ()) (defmethod handle ((handler poi-kml-all-handler)) - (let* ((relevant-pois (remove-if-not #'(lambda (poi) (and (poi-area poi) (poi-published poi))) + (let* ((relevant-pois (remove-if-not #'(lambda (poi) (and (poi-area poi) (poi-published-earth poi))) (class-instances 'poi))) (pois-last-change (reduce #'max relevant-pois :key (lambda (poi) (store-object-last-change poi 1))))) (hunchentoot:handle-if-modified-since pois-last-change)

1 0

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

03 Sep '08

Revision: 3778 Author: ksprotte URL: http://bknr.net/trac/changeset/3778 link to show POI in microsite more prominent 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-03 11:33:06 UTC (rev 3777) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-03 11:43:11 UTC (rev 3778) @@ -66,12 +66,12 @@ (html (:h2 "This POI is not complete in the current language - Please check that " "the location and all text fields are set and that at least 6 images " "have been uploaded."))) + (:p (cmslink (format nil "/poi-xml/~D?lang=~A" (store-object-id poi) language) + (:format "show this POI in ~A microsite" (string-upcase language)))) ((:form :method "POST" :enctype "multipart/form-data") ((:table :border "1") (:tr (:td "name") - (:td (:princ-safe (poi-name poi)) - " " - (cmslink (format nil "/poi-xml/~D?lang=~A" (store-object-id poi) language) "[view]"))) + (:td (:princ-safe (poi-name poi)))) (:tr (:td "published") (:td (checkbox-field "published" "published" :checked (poi-published poi)))) (:tr (:td "title")

1 0

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

03 Sep '08

Revision: 3777 Author: ksprotte URL: http://bknr.net/trac/changeset/3777 poi-xml-handler is now ready for ptviewer's /poi-xml/PTDefault.html requests by using :query-function #'find-poi-or-ptdefault 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-03 11:04:05 UTC (rev 3776) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-03 11:33:06 UTC (rev 3777) @@ -441,9 +441,14 @@ (with-media ("movie" "Video") (with-element "url" (text (poi-movie-url movie)))))))))) +(defun find-poi-or-ptdefault (string) + (if (string= string "PTDefault.html") + :ptdefault + (find-poi string))) + (defclass poi-xml-handler (object-handler) () - (:default-initargs :object-class 'poi :query-function #'find-poi)) + (:default-initargs :query-function #'find-poi-or-ptdefault)) (defmethod handle-object ((handler poi-xml-handler) poi) @@ -455,6 +460,10 @@ (with-xml-response (:xsl-stylesheet-name "/static/poi.xsl") (write-poi-xml poi lang))))) +(defmethod handle-object ((handler poi-xml-handler) (poi (eql :ptdefault))) + "ptviewer will request /poi-xml/PTDefault.html" + ) + ;;; poi-kml-handler (defun poi-description-google-earth (poi language &key (image-width 120)) (labels ((website-path (path &rest args)

1 0

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

03 Sep '08

Revision: 3776 Author: ksprotte URL: http://bknr.net/trac/changeset/3776 replaced js Pano by ptviewer in microsite U trunk/projects/bos/payment-website/static/poi.xsl Modified: trunk/projects/bos/payment-website/static/poi.xsl =================================================================== --- trunk/projects/bos/payment-website/static/poi.xsl 2008-09-03 08:23:07 UTC (rev 3775) +++ trunk/projects/bos/payment-website/static/poi.xsl 2008-09-03 11:04:05 UTC (rev 3776) @@ -74,15 +74,15 @@ <xsl:variable name="height"><xsl:value-of select="image/height"/></xsl:variable> <div class="accordion_toggle"><xsl:value-of select="@title"/>:<xsl:value-of select="@subtitle"/></div> <div class="accordion_content"> - <div class="scrollpane" style="border: 1px solid black; width: 600px; - height:{$height}px; background-image: url({$url}); - background-position: -690px 0px; background-repeat:repeat-x;" - id="pano-{$id}"></div> - <script type="text/javascript"> - var myPano = new Pano(); - myPano.scrollPano('<xsl:value-of select="image/url"/>', 690, - <xsl:value-of select="image/height"/>, 'pano-<xsl:value-of select="image/@id"/>'); - </script> + <div class="scrollpane" style="border: 1px solid black; width: 600px; height: {$height div 2}px"> + <applet archive="/static/ptviewer.jar" + code="ptviewer.class" + width="600" + height="{$height div 2}"> + <param name="file" value="/image/{$id}"/> + <param name="quality" value="3"/> + </applet> + </div> </div> </xsl:if> <xsl:if test="@type='movie'">

1 0

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

03 Sep '08

Revision: 3775 Author: ksprotte URL: http://bknr.net/trac/changeset/3775 poi.xsl indentation cleanup U trunk/projects/bos/payment-website/static/poi.xsl Modified: trunk/projects/bos/payment-website/static/poi.xsl =================================================================== --- trunk/projects/bos/payment-website/static/poi.xsl 2008-09-02 15:59:30 UTC (rev 3774) +++ trunk/projects/bos/payment-website/static/poi.xsl 2008-09-03 08:23:07 UTC (rev 3775) @@ -1,47 +1,48 @@ <?xml version="1.0" encoding="UTF-8"?> <xsl:stylesheet version="2.0" -xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> - <xsl:output method="html" doctype-system="http://www.w3.org/TR/html4/strict.dtd" doctype-public="-//W3C//DTD HTML 4.01//EN" indent="yes" /> + xmlns:xsl="http://www.w3.org/1999/XSL/Transform"> + <xsl:output method="html" doctype-system="http://www.w3.org/TR/html4/strict.dtd" + doctype-public="-//W3C//DTD HTML 4.01//EN" indent="yes" /> <xsl:template match="/"> <html> - <head> - <meta http-equiv="Content-Type" content="text/html; charset=UTF-8"/> - <link href="/static/poi/bos_style.css" rel="stylesheet"> - </link> - <link href="/static/poi/highslide.css" rel="stylesheet"> - </link> - <link href="http://createrainforest.org/rss/news" rel="alternate" title="RSS Feed" type="application/rss+xml"> - </link> - <script type="text/javascript" src="/static/poi/prototype.js"></script> - <script type="text/javascript" src="/static/poi/effects.js"></script> - <script type="text/javascript" src="/static/poi/accordion.js"></script> - <script type="text/javascript" src="/static/poi/highslide.js"></script> - <script type="text/javascript" src="/static/poi/panorama.js"></script> - <script type="text/javascript" src="/static/poi/functions.js"></script> - <title><xsl:value-of select="poi/@title"/></title> - </head> - <body> - <div id="content"> - <div id="header"> - <div id="menue_banner"> - <div id="menue_header_main"> - <div class="menue">|</div> - <xsl:apply-templates select="poi/menu/entry" /> - + <head> + <meta http-equiv="Content-Type" content="text/html; charset=UTF-8"/> + <link href="/static/poi/bos_style.css" rel="stylesheet"> + </link> + <link href="/static/poi/highslide.css" rel="stylesheet"> + </link> + <link href="http://createrainforest.org/rss/news" rel="alternate" title="RSS Feed" + type="application/rss+xml"> + </link> + <script type="text/javascript" src="/static/poi/prototype.js"></script> + <script type="text/javascript" src="/static/poi/effects.js"></script> + <script type="text/javascript" src="/static/poi/accordion.js"></script> + <script type="text/javascript" src="/static/poi/highslide.js"></script> + <script type="text/javascript" src="/static/poi/panorama.js"></script> + <script type="text/javascript" src="/static/poi/functions.js"></script> + <title><xsl:value-of select="poi/@title"/></title> + </head> + <body> + <div id="content"> + <div id="header"> + <div id="menue_banner"> + <div id="menue_header_main"> + <div class="menue">|</div> + <xsl:apply-templates select="poi/menu/entry" /> + + </div> + </div> </div> + <div id="content_main"> + <div class="description_content"> + <div class="description_header"><xsl:value-of select="poi/@title"/></div> + <div class="description_subheader"><xsl:value-of select="poi/@subtitle"/></div> + <xsl:value-of select="poi/description"/> </div> + <xsl:apply-templates select="poi/media" /> + </div> + <div class="clearer"></div> </div> - </div> - <div id="content_main"> - <div class="description_content"> - <div class="description_header"><xsl:value-of select="poi/@title"/></div> - <div class="description_subheader"><xsl:value-of select="poi/@subtitle"/></div> - <xsl:value-of select="poi/description"/> </div> - <xsl:apply-templates select="poi/media" /> - - </div> - <div class="clearer"></div> - </div> - </body> + </body> </html> </xsl:template>  @@ -63,7 +64,8 @@ <xsl:variable name="width"><xsl:value-of select="image/width"/></xsl:variable> <xsl:variable name="height"><xsl:value-of select="image/height"/></xsl:variable> <div class="accordion_toggle"><xsl:value-of select="@title"/>:<xsl:value-of select="@subtitle"/></div> - <div class="accordion_content"><img class="airal" src="{$url}" alt="{$title}" title="{$title}" height="{$height}" width="{$width}"></img></div> + <div class="accordion_content"><img class="airal" src="{$url}" alt="{$title}" title="{$title}" + height="{$height}" width="{$width}"></img></div> </xsl:if> <xsl:if test="@type='panorama'"> <xsl:variable name="id"><xsl:value-of select="image/@id"/></xsl:variable> @@ -72,10 +74,14 @@ <xsl:variable name="height"><xsl:value-of select="image/height"/></xsl:variable> <div class="accordion_toggle"><xsl:value-of select="@title"/>:<xsl:value-of select="@subtitle"/></div> <div class="accordion_content"> - <div class="scrollpane" style="border: 1px solid black; width: 600px; height:{$height}px; background-image: url({$url}); background-position: -690px 0px; background-repeat:repeat-x;" id="pano-{$id}"></div> + <div class="scrollpane" style="border: 1px solid black; width: 600px; + height:{$height}px; background-image: url({$url}); + background-position: -690px 0px; background-repeat:repeat-x;" + id="pano-{$id}"></div> <script type="text/javascript"> - var myPano = new Pano(); - myPano.scrollPano('<xsl:value-of select="image/url"/>', 690, <xsl:value-of select="image/height"/>, 'pano-<xsl:value-of select="image/@id"/>'); + var myPano = new Pano(); + myPano.scrollPano('<xsl:value-of select="image/url"/>', 690, + <xsl:value-of select="image/height"/>, 'pano-<xsl:value-of select="image/@id"/>'); </script> </div> </xsl:if> @@ -95,14 +101,16 @@ <xsl:template match="entry"> <xsl:variable name="title"><xsl:value-of select="@title"/></xsl:variable> <xsl:variable name="href"><xsl:value-of select="@href"/></xsl:variable> - <div class="menue"><a class="menuelink" href="{$href}" shape="rect" target="_blank" ><xsl:value-of select="$title"/></a></div> + <div class="menue"><a class="menuelink" href="{$href}" shape="rect" target="_blank" > + <xsl:value-of select="$title"/></a></div> <div class="menue">|</div> </xsl:template> <xsl:template match="image"> <xsl:variable name="id"><xsl:value-of select="@id"/></xsl:variable> <xsl:variable name="url"><xsl:value-of select="url"/></xsl:variable> <xsl:variable name="title"><xsl:value-of select="@title"/></xsl:variable> - <a id="thumb{$id}" href="{$url}" class="highslide" onClick="return hs.expand(this)"><img src="{$url}" alt="{$title}" title="{$title}" height="75" width="75"></img></a> + <a id="thumb{$id}" href="{$url}" class="highslide" onClick="return hs.expand(this)"> + <img src="{$url}" alt="{$title}" title="{$title}" height="75" width="75"></img></a> <div class='highslide-caption'> <div class="img-title"><xsl:value-of select="@title"/></div> <div class="img-subtitle"><xsl:value-of select="@subtitle"/></div>

1 0

[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