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

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

04 Sep '08

Revision: 3790 Author: hans URL: http://bknr.net/trac/changeset/3790 Special case for zero-length string. U trunk/thirdparty/hunchentoot/util.lisp Modified: trunk/thirdparty/hunchentoot/util.lisp =================================================================== --- trunk/thirdparty/hunchentoot/util.lisp 2008-09-04 12:18:43 UTC (rev 3789) +++ trunk/thirdparty/hunchentoot/util.lisp 2008-09-04 13:09:36 UTC (rev 3790) @@ -243,43 +243,45 @@ (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." - (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))))) + (if (zerop (length string)) + "" + (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/
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