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

[bknr-cvs] hans changed trunk/
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3713 Author: hans URL: http://bknr.net/trac/changeset/3713 News start working. U trunk/bknr/web/src/rss/rss.lisp U trunk/projects/quickhoney/src/handlers.lisp A trunk/projects/quickhoney/src/json.lisp U trunk/projects/quickhoney/src/quickhoney.asd U trunk/projects/quickhoney/src/webserver.lisp U trunk/projects/quickhoney/website/static/javascript.js U trunk/projects/quickhoney/website/static/styles.css U trunk/projects/quickhoney/website/templates/index.xml Modified: trunk/bknr/web/src/rss/rss.lisp =================================================================== --- trunk/bknr/web/src/rss/rss.lisp 2008-07-31 16:31:28 UTC (rev 3712) +++ trunk/bknr/web/src/rss/rss.lisp 2008-07-31 22:25:05 UTC (rev 3713) @@ -121,35 +121,37 @@ (when (boundp 'hunchentoot:*request*) (let ((month-string (bknr.web:query-param "month"))) (when month-string - (mapcar #'parse-integer (cl-ppcre:split "([-/]|(?<=..))" month-string :limit 2)))))) + (mapcar #'parse-integer (cl-ppcre:split "([-/]|(?<=....))" month-string :limit 2)))))) (defun rss-channel-archive (channel) "Return the channel archive consisting of lists of lists ((MONTH YEAR) ITEM...)" - (group-on (rss-channel-items channel) + (group-on (rss-channel-items channel :all t) :test #'equal :key (lambda (item) (multiple-value-bind (seconds minutes hours day month year) (decode-universal-time (rss-item-pub-date item)) (declare (ignore seconds minutes hours day)) - (list month year))))) + (list year month))))) (defgeneric rss-channel-items (channel &key) (:documentation "Return all non-expired items in channel.") - (:method ((channel rss-channel) &key days month count) + (:method ((channel rss-channel) &key days month count all) (unless month (setf month (month-from-query-parameter))) (unless days (setf days (or (days-from-query-parameter) (rss-channel-max-item-age channel)))) - (let ((items (if month - (cdr (find month (rss-channel-archive channel) :test #'equal)) - (let ((expiry-time (- (get-universal-time) (* 60 60 24 days)))) - (remove-if (lambda (item) (or (object-destroyed-p item) - (< (rss-item-pub-date item) expiry-time))) - (slot-value channel 'items)))))) - (if count - (subseq items 0 (min count (length items))) - items)))) + (if all + (remove-if #'object-destroyed-p (slot-value channel 'items)) + (let ((items (if month + (cdr (find month (rss-channel-archive channel) :test #'equal :key #'car)) + (let ((expiry-time (- (get-universal-time) (* 60 60 24 days)))) + (remove-if (lambda (item) (or (object-destroyed-p item) + (< (rss-item-pub-date item) expiry-time))) + (slot-value channel 'items)))))) + (if count + (subseq items 0 (min count (length items))) + items))))) (defgeneric rss-channel-archived-months (channel) (:documentation "Return a list of lists (MONTH YEAR) for which the Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-07-31 16:31:28 UTC (rev 3712) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-07-31 22:25:05 UTC (rev 3713) @@ -426,67 +426,46 @@ (:p (:princ-safe (apply #'format nil (simple-condition-format-control e) (simple-condition-format-arguments e)))) (:p ((:a :href "javascript:window.close()") "ok")))))))))))) -(defclass news-json-handler (object-handler) +(defclass rss-channel-handler (object-handler) () (:default-initargs :object-class 'rss-channel :query-function #'find-rss-channel)) -(defvar *json-output*) +(defclass json-news-handler (rss-channel-handler) + ()) -(defclass json-output-stream () - ((output-stream :reader output-stream - :initarg :output-stream) - (stack :accessor stack - :initform nil))) -(defun next-aggregate-element () - (if (car (stack *json-output*)) - (princ #\, (output-stream *json-output*)) - (setf (car (stack *json-output*)) t))) +(defgeneric json-encode-news-item (item) + (:method ((item t)) + ; do nothing + ) + (:method ((image quickhoney-image)) + (let ((vectorp (member :vector (store-image-keywords image)))) + (encode-object-element "uploader" (if vectorp "Peter" "Nana")) + (encode-object-element "category" (if vectorp "vector" "pixel")) + (encode-object-element "subcategory" "unknown") + (encode-object-element "date" (format-date-time (rss-item-pub-date image) :vms-style t :show-time nil)) + (encode-object-element "name" (store-image-name image))))) -(defmacro with-json-output ((stream) &body body) - `(let ((*json-output* (make-instance 'json-output-stream :output-stream ,stream))) - ,@body)) - -(defmacro with-json-output-to-string (() &body body) - `(with-output-to-string (s) - (with-json-output (s) - ,@body))) - -(defmacro with-json-aggregate ((begin-char end-char) &body body) - `(progn - (when (stack *json-output*) - (next-aggregate-element)) - (princ ,begin-char (output-stream *json-output*)) - (push nil (stack *json-output*)) - (prog1 - (progn ,@body) - (pop (stack *json-output*)) - (princ ,end-char (output-stream *json-output*))))) - -(defmacro with-json-array (() &body body) - `(with-json-aggregate (#\[ #\]) - ,@body)) - -(defmacro with-json-object (() &body body) - `(with-json-aggregate (#\{ #\}) - ,@body)) - -(defun encode-array-element (object) - (next-aggregate-element) - (json:encode-json object (output-stream *json-output*))) - -(defun encode-object-element (key value) - (next-aggregate-element) - (json:encode-json key (output-stream *json-output*)) - (princ #\: (output-stream *json-output*)) - (json:encode-json value (output-stream *json-output*))) - -(defmethod handle-object ((handler news-json-handler) (channel rss-channel)) - (with-http-response (:content-type "application/json") - (with-json-output-to-string () +(defmethod handle-object ((handler json-news-handler) (channel rss-channel)) + (with-json-response () + (with-object-element ("items") (with-json-array () (dolist (item (rss-channel-items channel)) (with-json-object () - (encode-object-element "pubDate" (format-date-time (rss-item-pub-date item) :vms-style t)) - (encode-object-element "title" (rss-item-title item)) - (encode-object-element "description" (rss-item-description item)))))))) + (json-encode-news-item item))))))) + +(defclass json-news-archive-handler (rss-channel-handler) + ()) + +(defmethod handle-object ((handler json-news-archive-handler) (channel rss-channel)) + (with-json-response () + (with-object-element ("months") + (with-json-array () + (dolist (month (sort (rss-channel-archived-months channel) + (lambda (a b) + (if (= (first a) (first b)) + (> (second a) (second b)) + (> (first a) (first b)))))) + (with-json-array () + (encode-array-element (first month)) + (encode-array-element (second month)))))))) \ No newline at end of file Added: trunk/projects/quickhoney/src/json.lisp =================================================================== --- trunk/projects/quickhoney/src/json.lisp (rev 0) +++ trunk/projects/quickhoney/src/json.lisp 2008-07-31 22:25:05 UTC (rev 3713) @@ -0,0 +1,67 @@ +(in-package :quickhoney) + +(defvar *json-output*) + +(defclass json-output-stream () + ((stream :reader stream + :initarg :stream) + (stack :accessor stack + :initform nil))) + +(defun next-aggregate-element () + (if (car (stack *json-output*)) + (princ (car (stack *json-output*)) (stream *json-output*)) + (setf (car (stack *json-output*)) #\,))) + +(defmacro with-json-output ((stream) &body body) + `(let ((*json-output* (make-instance 'json-output-stream :stream ,stream))) + ,@body)) + +(defmacro with-json-output-to-string (() &body body) + `(with-output-to-string (s) + (with-json-output (s) + ,@body))) + +(defmacro with-json-aggregate ((begin-char end-char) &body body) + `(progn + (when (stack *json-output*) + (next-aggregate-element)) + (princ ,begin-char (stream *json-output*)) + (push nil (stack *json-output*)) + (prog1 + (progn ,@body) + (pop (stack *json-output*)) + (princ ,end-char (stream *json-output*))))) + +(defmacro with-json-array (() &body body) + `(with-json-aggregate (#\[ #\]) + ,@body)) + +(defmacro with-json-object (() &body body) + `(with-json-aggregate (#\{ #\}) + ,@body)) + +(defun encode-array-element (object) + (next-aggregate-element) + (json:encode-json object (stream *json-output*))) + +(defun encode-object-element (key value) + (next-aggregate-element) + (json:encode-json key (stream *json-output*)) + (princ #\: (stream *json-output*)) + (json:encode-json value (stream *json-output*))) + +(defmacro with-object-element ((key) &body body) + `(progn + (next-aggregate-element) + (json:encode-json ,key (stream *json-output*)) + (setf (car (stack *json-output*)) #\:) + (unwind-protect + (progn ,@body) + (setf (car (stack *json-output*)) #\,)))) + +(defmacro with-json-response (() &body body) + `(with-http-response (:content-type "application/json") + (with-json-output-to-string () + (with-json-object () + ,@body)))) Modified: trunk/projects/quickhoney/src/quickhoney.asd =================================================================== --- trunk/projects/quickhoney/src/quickhoney.asd 2008-07-31 16:31:28 UTC (rev 3712) +++ trunk/projects/quickhoney/src/quickhoney.asd 2008-07-31 22:25:05 UTC (rev 3713) @@ -32,7 +32,8 @@ (:file "news" :depends-on ("image")) (:file "layout" :depends-on ("config")) (:file "imageproc" :depends-on ("config")) - (:file "handlers" :depends-on ("layout" "config" "image")) + (:file "json" :depends-on ("packages")) + (:file "handlers" :depends-on ("json" "layout" "config" "image")) (:file "tags" :depends-on ("image")) (:file "webserver" :depends-on ("handlers")) (:file "daily" :depends-on ("config")) Modified: trunk/projects/quickhoney/src/webserver.lisp =================================================================== --- trunk/projects/quickhoney/src/webserver.lisp 2008-07-31 16:31:28 UTC (rev 3712) +++ trunk/projects/quickhoney/src/webserver.lisp 2008-07-31 22:25:05 UTC (rev 3713) @@ -33,7 +33,8 @@ ("/admin" admin-handler) ("/upload-news" upload-news-handler) ("/digg-image" digg-image-handler) - ("/news-json" news-json-handler) + ("/json-news-archive" json-news-archive-handler) + ("/json-news" json-news-handler) ("/" template-handler :default-template "frontpage" :destination ,(namestring (merge-pathnames "templates/" *website-directory*)) Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2008-07-31 16:31:28 UTC (rev 3712) +++ trunk/projects/quickhoney/website/static/javascript.js 2008-07-31 22:25:05 UTC (rev 3713) @@ -215,11 +215,80 @@ /* news */ -function load_news() +var month_names = [ 'January', 'February', 'March', 'April', 'May', 'June', + 'July', 'August', 'September', 'October', 'November', 'December' ]; + +function select_archive_year() { - + var year = this.href.match(/#news\/(\d+)/)[1]; + map(function (element) { + if (element.href) { + ((element.href.match(/#news\/(\d+)/)[1] == year) ? addElementClass : removeElementClass)(element, 'active'); + } + }, this.parentNode.childNodes); + return true; } +function select_archive_month() +{ + var month = this.href.match(/#news\/(\d+\/\d+)/)[1]; + loadJSONDoc('/json-news/quickhoney?month=' + month).addCallbacks(load_news, alert); + return true; +} + +function load_news(data) +{ + log('load news: ' + data.items.length); + replaceChildNodes('newsentries', + map(function (item) { + var color = (item.category == 'pixel') ? 'ff00ff' : '00ccff'; + return [ DIV({ 'class': 'newsentry autonews news_' + item.category }, + IMG({ src: "/image/" + item.name + '/cutout-button,,' + color + ',98,4'}), + DIV(null, + H1(null, item.name), + item.date, ' by ', item.uploader, ' | ', + A({ href: '/index#' + item.category + '/' + item.subcategory + '/' + item.image_name }, 'permalink'), + BR(), + item.description)), + DIV({ 'class': 'news_sep' }) ]; + }, data.items)); +} + +function load_news_archive(data) +{ + try { + if (!data.months) { + alert('no archive data found'); + } + var currentYear; + var active = true; + replaceChildNodes('archive-navigation', + SPAN({ 'class': 'title' }, 'Archive'), BR(), + map(function (entry) { + var year = entry[0]; + var month = entry[1]; + var result = []; + if (year != currentYear) { + if (currentYear) { + active = false; + } + currentYear = year; + var link = A({ href: '#news/' + year, 'class': 'year' }, year, BR()); + link.onclick = select_archive_year; + result.push(link); + } + var link = A({ href: '#news/' + year + '/' + month, 'class': 'month ' + (active ? ' active' : '')}, + month_names[month - 1], BR()); + link.onclick = select_archive_month; + result.push(link); + return result; + }, data.months)); + } + catch (e) { + log('error while processing archive data: ' + e); + } +} + /* image database */ var current_directory; @@ -391,7 +460,8 @@ '30be01', function() { footer_hide(); - load_news(); + loadJSONDoc('/json-news-archive/quickhoney').addCallbacks(load_news_archive, alert); + // load_news(); }); pages['shop'] Modified: trunk/projects/quickhoney/website/static/styles.css =================================================================== --- trunk/projects/quickhoney/website/static/styles.css 2008-07-31 16:31:28 UTC (rev 3712) +++ trunk/projects/quickhoney/website/static/styles.css 2008-07-31 22:25:05 UTC (rev 3713) @@ -627,4 +627,9 @@ top: 0px; left: 585px; visibility: hidden; -} \ No newline at end of file +} + +.archive span.title, .archive a.year { font-size: 1.5em; } +.archive a.month.active { display: block; } +.archive a.month { display: none; } +.archive { padding-left: 1em; } \ No newline at end of file Modified: trunk/projects/quickhoney/website/templates/index.xml =================================================================== --- trunk/projects/quickhoney/website/templates/index.xml 2008-07-31 16:31:28 UTC (rev 3712) +++ trunk/projects/quickhoney/website/templates/index.xml 2008-07-31 22:25:05 UTC (rev 3713) @@ -130,25 +130,33 @@ </div> <div id="news_page"> - <p id="news_content"> - <div class="newsentry news_vector autonews"> - <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/> - <div> - <h1>Jan and Ella</h1> - March 8th, 2008 by Peter | <a href="foo">permalink</a><br/> - description - </div> - </div> - <div class="news_sep"> </div> - <br/> - <div class="newsentry news_pixel autonews"> - <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/> - <div> - March 8th, 2008 by Peter | <a href="foo">permalink</a><br/> - description - </div> - </div> - </p> + <table border="0"> + <tbody> + <tr> + <td valign="top" id="newsentries"> + <div class="newsentry news_vector autonews"> + <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/> + <div> + <h1>Jan and Ella</h1> + March 8th, 2008 by Peter | <a href="foo">permalink</a><br/> + description + </div> + </div> + <div class="news_sep"> </div> + <br/> + <div class="newsentry news_pixel autonews"> + <img src="/image/TSG_Platforms_web/cutout-button,,00ccff,98,4"/> + <div> + March 8th, 2008 by Peter | <a href="foo">permalink</a><br/> + description + </div> + </div> + </td> + <td class="archive" id="archive-navigation" valign="top"> + </td> + </tr> + </tbody> + </table> </div> <div id="cart_page">

1 0

[bknr-cvs] ksprotte changed trunk/
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3712 Author: ksprotte URL: http://bknr.net/trac/changeset/3712 xhtmlgen: should have left :canonical nil untouched U trunk/projects/bos/web/cms-links.lisp U trunk/projects/bos/web/poi-handlers.lisp U trunk/projects/bos/web/webserver.lisp U trunk/xhtmlgen/xhtmlgen.lisp Modified: trunk/projects/bos/web/cms-links.lisp =================================================================== --- trunk/projects/bos/web/cms-links.lisp 2008-07-31 16:16:24 UTC (rev 3711) +++ trunk/projects/bos/web/cms-links.lisp 2008-07-31 16:31:28 UTC (rev 3712) @@ -29,12 +29,9 @@ (cmslink (edit-object-url poi) (:princ (format nil "edit ~a" (poi-name poi))))) -(defmethod object-url ((poi-image poi-image)) - (format nil "/poi-image/~A" (store-object-id poi-image))) +(defmethod edit-object-url ((medium poi-medium)) + (format nil "/edit-poi-medium/~a" (store-object-id medium))) -(defmethod edit-object-url ((poi-image poi-image)) - (format nil "/edit-poi-image/~a" (store-object-id poi-image))) - (defmethod html-link ((poi-image poi-image)) (cmslink (object-url poi-image) (:princ (store-object-id poi-image)))) Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 16:16:24 UTC (rev 3711) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 16:31:28 UTC (rev 3712) @@ -64,7 +64,7 @@ (content-language-chooser) (unless (poi-complete poi language) (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 one image " + "the location and all text fields are set and that at least 6 images " "has been uploaded."))) ((:form :method "POST" :enctype "multipart/form-data") ((:table :border "1") @@ -98,13 +98,13 @@ "[choose]"))))) (:tr (:td "icon") (:td (icon-chooser "icon" (poi-icon poi)))) - (:tr (:td "images") + (:tr (:td "sat images") (:td ((:table) (:tr (loop for image in (poi-sat-images poi) for index upfrom 0 - do (html (:td ((:a :href (format nil "/edit-poi-image/~a?poi=~A" (store-object-id image) (store-object-id poi))) + do (html (:td ((:a :href (format nil "/edit-poi-medium/~a?poi=~A" (store-object-id image) (store-object-id poi))) ((:img :border "0" :src (format nil "/image/~a/thumbnail,,55,55" (store-object-id image))))) :br (if (zerop index) @@ -119,57 +119,31 @@ (store-object-id poi) index (store-object-id image))) ((:img :border "0" :src "/images/pfeil-r.gif")))))))))) - (unless (eql 6 (length (poi-sat-images poi))) + (unless (= 6 (length (poi-sat-images poi))) (html :br - (cmslink (format nil "edit-poi-image/?poi=~A" (store-object-id poi)) "[new]"))))) - (:tr (:td "airal view" - ((:input :id "airal-id" :type "hidden" :name "airal-id"))) - (:td (:table (dolist (airal (poi-airals poi)) - (html (:tr (:td ((:a :href (format nil "/image/~D" (store-object-id airal)) - :target "_new") - ((:img :src (format nil "/image/~D" (store-object-id airal)) - :width "90" :height "90")))) - (:td (submit-button "delete-airal" "delete-airal" - :formcheck #?"javascript:confirm_delete('airal-id', $((store-object-id airal)), 'Really delete the airal?')"))))) - (:tr ((:td :colspan "2") - "Upload new airal view" - ((:input :type "file" :name "image-file")) - :br - (submit-button "upload-airal" "upload-airal")))))) - (:tr (:td "panorama view" - ((:input :id "panorama-id" :type "hidden" :name "panorama-id"))) - (:td (dolist (panorama (poi-panoramas poi)) - (html (:princ-safe (format-date-time (blob-timestamp panorama))) - ((:a :href (format nil "/image/~D" (store-object-id panorama)) :target "_new" :class "cmslink") - " view ") - (submit-button "delete-panorama" "delete-panorama" - :formcheck #?"javascript:confirm_delete('panorama-id', $((store-object-id panorama)), 'Really delete this panorama image?')") - :br)) - (html "Upload new panorama view" - ((:input :type "file" :name "image-file")) - :br - (submit-button "upload-panorama" "upload-panorama")))) - (:tr (:td "movies" - ((:input :id "movie-id" :type "hidden" :name "movie-id"))) - (:td (dolist (movie (poi-movies poi)) - (html (:princ-safe (format-date-time (store-object-last-change movie 0))) - ((:a :href (format nil "/poi-movie/~D" (store-object-id movie)) :target "_new" :class "cmslink") - " view ") - (submit-button "delete-movie" "delete-movie" - :formcheck #?"javascript:confirm_delete('movie-id', $((store-object-id movie)), 'Really delete this movie?')") - :br)) - (html "URL or 'embed' string: " - ((:input :type "text" - :size "50" - :name "movie-url" - :id "movie" - :value "" - :onchange "parse_youtube_link(this)")) - :br - (submit-button "add-movie" "add-movie")))) + (cmslink (format nil "edit-poi-medium/?poi=~A" (store-object-id poi)) "[new]"))))) (:tr (:td (submit-button "save" "save") - (submit-button "delete" "delete" :confirm "Really delete the POI?")))))))) + (submit-button "delete" "delete" :confirm "Really delete the POI?")))) + ;; ;;;;;;;;;;;;;;;; + (:h2 "Upload new medium") + ((:form :method "post" :action "/edit-poi-medium" :enctype "multipart/form-data") + (:table (:tr (:td "Type") + (:td (select-box "medium-type" (mapcar #'(lambda (class-name) (string-downcase (symbol-name class-name))) + (class-subclasses (find-class 'poi-medium))) + :default "poi-image"))) + (:tr + (:td "File") + (:td ((:input :type "file" :name "image-file"))) + (:tr ((:td :colspan "2") (submit-button "upload" "upload")))))) + (:h2 "Attached POI media") + ((: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"))))))))))))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :save)) (poi poi)) @@ -278,6 +252,114 @@ (html (:h2 "POI has been deleted") "The POI has been deleted"))) + +;;; edit-poi-medium-handler +(defclass edit-poi-medium-handler (editor-only-handler edit-object-handler) + () + (:default-initargs :object-class 'poi-medium)) + +(defmethod handle-object-form ((handler edit-poi-medium-handler) action (medium poi-medium)) + (with-query-params (language poi) + (unless language (setq language (request-language))) + (with-bos-cms-page (:title (format nil "Edit ~A" (medium-pretty-type-string medium))) + (html + (cmslink (edit-object-url (poi-medium-poi medium)) "Back to POI") + (content-language-chooser) + ((:form :method "post" :enctype "multipart/form-data") + ((:input :type "hidden" :name "poi" :value poi)) + (:table (medium-handler-preview medium) + (:tr ((:td :colspan "2" :height "10"))) + (:tr (:td "upload new image") + (:td ((:input :type "file" :name "image-file")) + :br + (submit-button "upload" "upload"))) + (:tr ((:td :colspan "2" :height "10"))) + (:tr (:td "title") + (:td (text-field "title" + :value (slot-string medium 'title language)))) + (:tr (:td "subtitle") + (:td (text-field "subtitle" + :value (slot-string medium 'subtitle language)))) + (:tr (:td "description") + (:td (textarea-field "description" + :value (slot-string medium 'description language) + :rows 5 + :cols 40))) + (:tr (:td (submit-button "save" "save") (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")) + +(defgeneric medium-handler-preview (medium &key small) + (:method ((medium t) &key small) + (declare (ignore small)) + (html ((:tr :colspan "2") "No preview"))) + (:method ((medium poi-image) &key small) + (html + (:tr (:td "thumbnail") + (:td ((:img :src (format nil "/image/~A/thumbnail,,55,55" (store-object-id medium)))))) + (unless small + (html + (: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 ((:img :src (format nil "/image/~A/thumbnail,,500,100" (store-object-id medium))))))))) + +(defmethod handle-object-form ((handler edit-poi-medium-handler) (action (eql :save)) (medium poi-medium)) + (with-query-params (title subtitle description language) + (unless language (setq language (request-language))) + (update-textual-attributes medium language + :title title + :subtitle subtitle + :description description) + (let ((type-string (medium-pretty-type-string medium))) + (with-bos-cms-page (:title (format nil "~A has been updated" type-string)) + (:h2 (format nil "The ~A information has been updated" type-string)) + "You may " (cmslink (format nil "~A?language=~A" (edit-object-url medium) language) + (: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")))) + +(defmethod handle-object-form ((handler edit-poi-medium-handler) (action (eql :upload)) medium) + (with-query-params (poi) + (setq poi (find-store-object (parse-integer poi) :class 'poi)) + (let ((upload (request-uploaded-file "image-file"))) + (unless upload + (error "no file uploaded in upload handler")) + (bknr.web:with-image-from-upload* (upload) + (unless (and (eql (cl-gd:image-width) *poi-image-width*) + (eql (cl-gd:image-height) *poi-image-height*)) + (with-bos-cms-page (:title "Invalid image size") + (:h2 "Invalid image size") + (:p "The image needs to be " + (:princ-safe *poi-image-width*) " pixels wide and " + (:princ-safe *poi-image-height*) " pixels high. Your uploaded image is " + (:princ-safe (cl-gd:image-width)) " pixels wide and " + (:princ-safe (cl-gd:image-height)) " pixels high. Please use an image editor " + "to resize the image and upload it again.") + (:p (cmslink (edit-object-url poi) "Back to POI"))) + (return-from handle-object-form t))) + (let ((new-medium (import-image upload + :class-name (type-of medium) + :initargs `(:poi ,poi)))) + (when medium + (delete-object medium)) + (redirect (format nil "/edit-poi-medium/~D?poi=~D" + (store-object-id new-medium) + (store-object-id poi))))))) + ;;; edit-poi-image-handler (defclass edit-poi-image-handler (editor-only-handler edit-object-handler) () Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-07-31 16:16:24 UTC (rev 3711) +++ trunk/projects/bos/web/webserver.lisp 2008-07-31 16:31:28 UTC (rev 3712) @@ -157,6 +157,7 @@ (make-instance 'bos-website :name "create-rainforest.org CMS" :handler-definitions `(("/edit-poi-image" edit-poi-image-handler) + ("/edit-poi-medium" edit-poi-medium-handler) ("/edit-poi" edit-poi-handler) ("/edit-sponsor" edit-sponsor-handler) ("/kml-upload" kml-upload-handler) Modified: trunk/xhtmlgen/xhtmlgen.lisp =================================================================== --- trunk/xhtmlgen/xhtmlgen.lisp 2008-07-31 16:16:24 UTC (rev 3711) +++ trunk/xhtmlgen/xhtmlgen.lisp 2008-07-31 16:31:28 UTC (rev 3712) @@ -51,12 +51,12 @@ ,(process-html-forms forms env))) (if (boundp '*html-sink*) (,body) - (let ((*html-sink* (cxml:make-character-stream-sink *standard-output* :canonical t))) + (let ((*html-sink* (cxml:make-character-stream-sink *standard-output* :canonical nil))) (,body) (sax:end-document *html-sink*)))))) (defmacro html-stream (stream &rest forms &environment env) - `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical t))) + `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil))) ,(process-html-forms forms env) (sax:end-document *html-sink*))) @@ -64,7 +64,7 @@ (declare (ignore indentation)) (when indentation-given (warn "WITH-XHTML: indentation argument is deprecated. It will be ignored")) - `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical t))) + `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil))) (sax:start-document *html-sink*) (sax:start-dtd *html-sink* "html"

1 0

[bknr-cvs] ksprotte changed trunk/xhtmlgen/xhtmlgen.lisp
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3711 Author: ksprotte URL: http://bknr.net/trac/changeset/3711 xhtmlgen does not indent anymore U trunk/xhtmlgen/xhtmlgen.lisp Modified: trunk/xhtmlgen/xhtmlgen.lisp =================================================================== --- trunk/xhtmlgen/xhtmlgen.lisp 2008-07-31 15:57:09 UTC (rev 3710) +++ trunk/xhtmlgen/xhtmlgen.lisp 2008-07-31 16:16:24 UTC (rev 3711) @@ -48,28 +48,31 @@ ;; just emit html to the current stream (let ((body (gensym))) `(labels ((,body () - ,(process-html-forms forms env))) - (if (boundp '*html-sink*) - (,body) - (let ((*html-sink* (cxml:make-character-stream-sink *standard-output* :canonical nil :indentation 3))) - (,body) - (sax:end-document *html-sink*)))))) + ,(process-html-forms forms env))) + (if (boundp '*html-sink*) + (,body) + (let ((*html-sink* (cxml:make-character-stream-sink *standard-output* :canonical t))) + (,body) + (sax:end-document *html-sink*)))))) (defmacro html-stream (stream &rest forms &environment env) - `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil :indentation 3))) - ,(process-html-forms forms env) - (sax:end-document *html-sink*))) + `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical t))) + ,(process-html-forms forms env) + (sax:end-document *html-sink*))) -(defmacro with-xhtml ((&optional stream &key (indentation 3)) &body body) - `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical nil :indentation ,indentation))) - (sax:start-document *html-sink*) - (sax:start-dtd *html-sink* - "html" - "-//W3C//DTD XHTML 1.0 Transitional//EN" - "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd") - (sax:end-dtd *html-sink*) - (multiple-value-prog1 - (html +(defmacro with-xhtml ((&optional stream &key (indentation 3 indentation-given)) &body body) + (declare (ignore indentation)) + (when indentation-given + (warn "WITH-XHTML: indentation argument is deprecated. It will be ignored")) + `(let ((*html-sink* (cxml:make-character-stream-sink ,stream :canonical t))) + (sax:start-document *html-sink*) + (sax:start-dtd *html-sink* + "html" + "-//W3C//DTD XHTML 1.0 Transitional//EN" + "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd") + (sax:end-dtd *html-sink*) + (multiple-value-prog1 + (html ,@body) (sax:end-document *html-sink*))))

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/session.lisp
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3710 Author: hans URL: http://bknr.net/trac/changeset/3710 Start session outside of lock scope in order to avoid recursive locking. U trunk/thirdparty/hunchentoot/session.lisp Modified: trunk/thirdparty/hunchentoot/session.lisp =================================================================== --- trunk/thirdparty/hunchentoot/session.lisp 2008-07-31 12:00:25 UTC (rev 3709) +++ trunk/thirdparty/hunchentoot/session.lisp 2008-07-31 15:57:09 UTC (rev 3710) @@ -148,16 +148,16 @@ there's no session for the current request." (with-rebinding (symbol) (with-unique-names (place %session) - `(with-lock-held (*session-data-lock*) - (let* ((,%session (or ,session (start-session))) - (,place (assoc ,symbol (session-data ,%session) :test #'eq))) - (cond - (,place - (setf (cdr ,place) ,new-value)) - (t - (push (cons ,symbol ,new-value) - (slot-value ,%session 'session-data)) - ,new-value))))))) + `(let ((,%session (or ,session (start-session)))) + (with-lock-held (*session-data-lock*) + (let* ((,place (assoc ,symbol (session-data ,%session) :test #'eq))) + (cond + (,place + (setf (cdr ,place) ,new-value)) + (t + (push (cons ,symbol ,new-value) + (slot-value ,%session 'session-data)) + ,new-value)))))))) (defun delete-session-value (symbol &optional (session *session*)) "Removes the value associated with SYMBOL from the current session

1 0

[bknr-cvs] ksprotte changed trunk/bknr/web/src/web/web-utils.lisp
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3709 Author: ksprotte URL: http://bknr.net/trac/changeset/3709 use (upload-content-type upload) als in method bknr.images:import-image upload U trunk/bknr/web/src/web/web-utils.lisp Modified: trunk/bknr/web/src/web/web-utils.lisp =================================================================== --- trunk/bknr/web/src/web/web-utils.lisp 2008-07-31 09:36:07 UTC (rev 3708) +++ trunk/bknr/web/src/web/web-utils.lisp 2008-07-31 12:00:25 UTC (rev 3709) @@ -46,7 +46,7 @@ (defmethod bknr.images:import-image ((upload upload) &rest args &key &allow-other-keys) (apply #'bknr.images:import-image (upload-pathname upload) :name (pathname-name (upload-original-filename upload)) - :type (make-keyword-from-string (pathname-type (upload-original-filename upload))) args)) + :type (image-type-symbol (upload-content-type upload)) args)) (defun all-request-params () "Return all non-empty request parameters - This includes all parameters encoded in the URL as

1 0

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

31 Jul '08

Revision: 3708 Author: ksprotte URL: http://bknr.net/trac/changeset/3708 poi image shifting works again U trunk/projects/bos/m2/poi.lisp U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-31 09:02:18 UTC (rev 3707) +++ trunk/projects/bos/m2/poi.lisp 2008-07-31 09:36:07 UTC (rev 3708) @@ -148,12 +148,12 @@ ;;; Exchanges (nth index (poi-sat-images poi)) with ;;; (nth (1+ index) (poi-sat-images poi)). (deftransaction poi-sat-images-exchange-neighbours (poi index) - (check-type index (integer 0 4)) + (check-type index (mod 6)) (multiple-value-bind (images positions) (poi-images poi) (declare (ignore images)) (let ((media-index-a (nth index positions)) - (media-index-b (nth (1+ index) positions))) + (media-index-b (nth (mod (1+ index) 6) positions))) (rotatef (nth media-index-a (poi-media poi)) (nth media-index-b (poi-media poi)))))) Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 09:02:18 UTC (rev 3707) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 09:36:07 UTC (rev 3708) @@ -52,21 +52,14 @@ (defmethod handle-object-form ((handler edit-poi-handler) action (poi poi)) - (with-query-params (language shift shift-by) + (with-query-params (language shift shift-id) (unless language (setq language (request-language))) (when shift - ;; change image order - (setq shift (find-store-object (parse-integer shift))) - (setq shift-by (parse-integer shift-by)) - (let* ((new-images (poi-sat-images poi)) - (old-position (position shift new-images)) - (tmp (nth old-position new-images))) - (assert (and (< -1 old-position (length new-images)) - (< -1 (+ shift-by old-position) (length new-images)))) - (setf (nth old-position new-images) (nth (+ shift-by old-position) new-images)) - (setf (nth (+ shift-by old-position) new-images) tmp) - (with-transaction ("setf poi-sat-images") - (setf (poi-sat-images poi) new-images)))) + (let ((shift (parse-integer shift)) + (shift-id (parse-integer shift-id))) + ;; only if this exchange has not already happened + (when (= shift-id (store-object-id (nth shift (poi-sat-images poi)))) + (poi-sat-images-exchange-neighbours poi shift)))) (with-bos-cms-page (:title "Edit POI") (content-language-chooser) (unless (poi-complete poi language) @@ -110,20 +103,20 @@ ((:table) (:tr (loop for image in (poi-sat-images poi) - for index from 1 by 1 + for index upfrom 0 do (html (:td ((:a :href (format nil "/edit-poi-image/~a?poi=~A" (store-object-id image) (store-object-id poi))) ((:img :border "0" :src (format nil "/image/~a/thumbnail,,55,55" (store-object-id image))))) :br - (if (eql index 1) + (if (zerop index) (html ((:img :src "/images/trans.gif" :width "16"))) - (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=-1" - (store-object-id poi) - (store-object-id image))) + (html ((:a :href (format nil "/edit-poi/~A?shift=~D&shift-id=~D" + (store-object-id poi) (1- index) + (store-object-id (nth (1- index) (poi-sat-images poi))))) ((:img :border "0" :src "/images/pfeil-l.gif"))))) ((:img :src "/images/trans.gif" :width "23")) (unless (eql index (length (poi-sat-images poi))) - (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=1" - (store-object-id poi) + (html ((:a :href (format nil "/edit-poi/~A?shift=~D&shift-id=~D" + (store-object-id poi) index (store-object-id image))) ((:img :border "0" :src "/images/pfeil-r.gif")))))))))) (unless (eql 6 (length (poi-sat-images poi)))

1 0

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

31 Jul '08

Revision: 3707 Author: ksprotte URL: http://bknr.net/trac/changeset/3707 refactored web/poi-handlers.lisp U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 08:54:27 UTC (rev 3706) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 09:02:18 UTC (rev 3707) @@ -2,6 +2,7 @@ (enable-interpol-syntax) +;;; make-poi-handler (defclass make-poi-handler (page-handler) ()) @@ -19,6 +20,7 @@ (t (redirect (edit-object-url (make-poi name))))))) +;;; edit-poi-handler (defclass edit-poi-handler (editor-only-handler edit-object-handler) () (:default-initargs :object-class 'poi :query-function #'find-poi)) @@ -283,8 +285,7 @@ (html (:h2 "POI has been deleted") "The POI has been deleted"))) -;; edit-poi-image - +;;; edit-poi-image-handler (defclass edit-poi-image-handler (editor-only-handler edit-object-handler) () (:default-initargs :object-class 'poi-image)) @@ -375,6 +376,7 @@ (:h2 "The POI image has been deleted") "You may " (cmslink (edit-object-url poi) "continue editing the POI")))) +;;; poi-javascript-handler (defclass poi-javascript-handler (page-handler) ()) @@ -403,6 +405,7 @@ (:princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") (:princ (format nil "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js last-paid-contracts))))))))) +;;; poi-image-handler (defclass poi-image-handler (object-handler) () (:default-initargs :object-class 'poi :query-function #'find-poi)) @@ -422,6 +425,7 @@ imageproc-arguments)) (error "image index ~a out of bounds for poi ~a" image-index poi))))) +;;; poi-movie-handler (defclass poi-movie-handler (admin-only-handler object-handler) () (:default-initargs :object-class 'poi-movie)) @@ -439,6 +443,7 @@ :allowFullScreen "true" :width "425" :height "344"))))) +;;; poi-xml-handler (defun write-poi-xml (poi language) "Writes the poi xml format for one specific language. This is used to generate the POI microsite using XSLT (client side)." @@ -492,6 +497,21 @@ (with-media ("movie" "Video") (with-element "url" (text (poi-movie-url movie)))))))))) +(defclass poi-xml-handler (object-handler) + () + (:default-initargs :object-class 'poi :query-function #'find-poi)) + + +(defmethod handle-object ((handler poi-xml-handler) poi) + (let ((timestamp (store-object-last-change poi 1))) + (hunchentoot:handle-if-modified-since timestamp) + (setf (hunchentoot:header-out :last-modified) + (hunchentoot:rfc-1123-date timestamp)) + (with-query-params ((lang "en")) + (with-xml-response (:xsl-stylesheet-name "/static/poi.xsl") + (write-poi-xml poi lang))))) + +;;; poi-kml-handler (defun poi-description-google-earth (poi language &key (image-width 120)) (labels ((website-path (path &rest args) (format nil "http://~a~a" (website-host) @@ -590,8 +610,6 @@ (text " | copyright"))))))))) (error (c) (error "while generating poi-description-google-earth for ~s:~%~a" poi c))))) - - (defun write-poi-kml (poi language) (with-element "Placemark" (with-element "name" (text (or (slot-string poi 'title language nil) @@ -603,20 +621,6 @@ (with-element "coordinates" (text (format nil "~{~,20F,~}0" (poi-center-lon-lat poi))))))) -(defclass poi-xml-handler (object-handler) - () - (:default-initargs :object-class 'poi :query-function #'find-poi)) - - -(defmethod handle-object ((handler poi-xml-handler) poi) - (let ((timestamp (store-object-last-change poi 1))) - (hunchentoot:handle-if-modified-since timestamp) - (setf (hunchentoot:header-out :last-modified) - (hunchentoot:rfc-1123-date timestamp)) - (with-query-params ((lang "en")) - (with-xml-response (:xsl-stylesheet-name "/static/poi.xsl") - (write-poi-xml poi lang))))) - (defclass poi-kml-handler (object-handler) () (:default-initargs :object-class 'poi :query-function #'find-poi)) @@ -629,6 +633,7 @@ (with-element "kml" (write-poi-kml poi lang)))))) +;;; poi-kml-all-handler (defclass poi-kml-all-handler (page-handler) ())

1 0

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

31 Jul '08

Revision: 3706 Author: ksprotte URL: http://bknr.net/trac/changeset/3706 added reader poi-sat-images and transaction poi-sat-images-exchange-neighbours for edit-poi handler 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-07-31 08:21:43 UTC (rev 3705) +++ trunk/projects/bos/m2/packages.lisp 2008-07-31 08:54:27 UTC (rev 3706) @@ -229,6 +229,8 @@ #:poi-center-y #:poi-center-lon-lat #:poi-images + #:poi-sat-images + #:poi-sat-images-exchange-neighbours #:poi-airals #:poi-panoramas #:poi-movies Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-07-31 08:21:43 UTC (rev 3705) +++ trunk/projects/bos/m2/poi.lisp 2008-07-31 08:54:27 UTC (rev 3706) @@ -117,16 +117,46 @@ (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)) +;;; 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 +;;; second value is a list of corresponding positions in that list. (macrolet ((define-poi-medium-reader (name) (let ((type (find-symbol (subseq (symbol-name name) 0 (1- (length (symbol-name name))))))) (assert type) `(defun ,name (poi) - (remove-if-not (lambda (medium) (typep medium ',type)) (poi-media poi)))))) + ;; this surely could be optimized + (let ((media-of-type (remove-if-not (lambda (medium) (typep medium ',type)) (poi-media poi)))) + (values media-of-type + (mapcar (lambda (medium) (position medium (poi-media poi))) media-of-type))))))) (define-poi-medium-reader poi-images) (define-poi-medium-reader poi-airals) (define-poi-medium-reader poi-panoramas) (define-poi-medium-reader poi-movies)) +(defun poi-sat-images (poi) + "We use the 6 last (oldest) images of POI as images for the + satellite application." + (multiple-value-bind (images positions) + (poi-images poi) + (let* ((length (length images)) + (start (max 0 (- length 6)))) + (values (subseq images start length) + (subseq positions start length))))) + +;;; Provides for the shifting of images in the edit-poi handler. +;;; Exchanges (nth index (poi-sat-images poi)) with +;;; (nth (1+ index) (poi-sat-images poi)). +(deftransaction poi-sat-images-exchange-neighbours (poi index) + (check-type index (integer 0 4)) + (multiple-value-bind (images positions) + (poi-images poi) + (declare (ignore images)) + (let ((media-index-a (nth index positions)) + (media-index-b (nth (1+ index) positions))) + (rotatef (nth media-index-a (poi-media poi)) + (nth media-index-b (poi-media poi)))))) + (defun make-poi-javascript (language) "Erzeugt das POI-Javascript für das Infosystem" (with-output-to-string (*standard-output*) @@ -155,8 +185,8 @@ (escape-nl (slot-string poi 'description language)) (poi-center-x poi) (poi-center-y poi) - (length (poi-images poi))) - (format t "poi.thumbnail = ~D;~%" (length (poi-images poi))) + (length (poi-sat-images poi))) + (format t "poi.thumbnail = ~D;~%" (length (poi-sat-images poi))) (when (poi-airals poi) (format t "poi.luftbild = ~D;~%" (store-object-id (first (poi-airals poi))))) @@ -168,7 +198,7 @@ for javascript-name in '("imageueberschrift" "imageuntertitel" "imagetext") for slot-values = (mapcar (lambda (image) (escape-nl (slot-string image slot-name language))) - (poi-images poi)) + (poi-sat-images poi)) when slot-values do (format t "poi.~A = [ ~{~S~^, ~} ];~%" javascript-name slot-values)) (format t "pois.push(poi);~%")) Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 08:21:43 UTC (rev 3705) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 08:54:27 UTC (rev 3706) @@ -56,15 +56,15 @@ ;; change image order (setq shift (find-store-object (parse-integer shift))) (setq shift-by (parse-integer shift-by)) - (let* ((new-images (poi-images poi)) + (let* ((new-images (poi-sat-images poi)) (old-position (position shift new-images)) (tmp (nth old-position new-images))) (assert (and (< -1 old-position (length new-images)) (< -1 (+ shift-by old-position) (length new-images)))) (setf (nth old-position new-images) (nth (+ shift-by old-position) new-images)) (setf (nth (+ shift-by old-position) new-images) tmp) - (with-transaction ("setf poi-images") - (setf (poi-images poi) new-images)))) + (with-transaction ("setf poi-sat-images") + (setf (poi-sat-images poi) new-images)))) (with-bos-cms-page (:title "Edit POI") (content-language-chooser) (unless (poi-complete poi language) @@ -107,24 +107,24 @@ (:td ((:table) (:tr - (loop for image in (poi-images poi) + (loop for image in (poi-sat-images poi) for index from 1 by 1 do (html (:td ((:a :href (format nil "/edit-poi-image/~a?poi=~A" (store-object-id image) (store-object-id poi))) ((:img :border "0" :src (format nil "/image/~a/thumbnail,,55,55" (store-object-id image))))) - :br - (if (eql index 1) - (html ((:img :src "/images/trans.gif" :width "16"))) - (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=-1" - (store-object-id poi) - (store-object-id image))) - ((:img :border "0" :src "/images/pfeil-l.gif"))))) - ((:img :src "/images/trans.gif" :width "23")) - (unless (eql index (length (poi-images poi))) - (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=1" - (store-object-id poi) - (store-object-id image))) - ((:img :border "0" :src "/images/pfeil-r.gif")))))))))) - (unless (eql 6 (length (poi-images poi))) + :br + (if (eql index 1) + (html ((:img :src "/images/trans.gif" :width "16"))) + (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=-1" + (store-object-id poi) + (store-object-id image))) + ((:img :border "0" :src "/images/pfeil-l.gif"))))) + ((:img :src "/images/trans.gif" :width "23")) + (unless (eql index (length (poi-sat-images poi))) + (html ((:a :href (format nil "/edit-poi/~A?shift=~A&shift-by=1" + (store-object-id poi) + (store-object-id image))) + ((:img :border "0" :src "/images/pfeil-r.gif")))))))))) + (unless (eql 6 (length (poi-sat-images poi))) (html :br (cmslink (format nil "edit-poi-image/?poi=~A" (store-object-id poi)) "[new]"))))) @@ -342,8 +342,8 @@ (:td ((:img :src (format nil "/image/~A" (store-object-id poi-image)))))) (:tr (:td "upload new image") (:td ((:input :type "file" :name "image-file")) - :br - (submit-button "upload" "upload"))) + :br + (submit-button "upload" "upload"))) (:tr (:td "title") (:td (text-field "title" :value (slot-string poi-image 'title language)))) @@ -416,9 +416,9 @@ (declare (ignore poi-name)) (let ((image-index (1- (parse-integer image-index-string)))) (if (and (not (minusp image-index)) - (< image-index (length (poi-images poi)))) + (< image-index (length (poi-sat-images poi)))) (redirect (format nil "/image/~D~@[~{/~a~}~]" - (store-object-id (nth image-index (poi-images poi))) + (store-object-id (nth image-index (poi-sat-images poi))) imageproc-arguments)) (error "image index ~a out of bounds for poi ~a" image-index poi))))) @@ -436,8 +436,8 @@ ((:param :name "movie" :value (poi-movie-url poi-movie))) ((:param :name "allowFullScreen" :value "true")) ((:embed :src (poi-movie-url poi-movie) :type "application/x-shockwave-flash" - :allowFullScreen "true" - :width "425" :height "344"))))) + :allowFullScreen "true" + :width "425" :height "344"))))) (defun write-poi-xml (poi language) "Writes the poi xml format for one specific language. This is used @@ -467,7 +467,7 @@ (subtitle poi-subtitle) (description poi-description) (airals poi-airals) - (images poi-images) + (images poi-sat-images) (panoramas poi-panoramas) (movies poi-movies)) poi (with-element "poi" @@ -564,7 +564,7 @@ (with-element "br"))) (with-element "table" (with-element "tbody" - (let ((images (poi-images poi))) + (let ((images (poi-sat-images poi))) (images-2trs (subseq images 0 (min 3 (length images)))) (when (> (length images) 3) (images-2trs (subseq images 3 (min 6 (length images))))))))))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/web-utils.lisp
by BKNR Commits 31 Jul '08

31 Jul '08

Revision: 3705 Author: ksprotte URL: http://bknr.net/trac/changeset/3705 fixed content-language-chooser to keep other GET parameters U trunk/projects/bos/web/web-utils.lisp Modified: trunk/projects/bos/web/web-utils.lisp =================================================================== --- trunk/projects/bos/web/web-utils.lisp 2008-07-31 08:02:37 UTC (rev 3704) +++ trunk/projects/bos/web/web-utils.lisp 2008-07-31 08:21:43 UTC (rev 3705) @@ -37,15 +37,23 @@ (defun language-name (language-short-name) (cadr (assoc language-short-name (website-languages) :test #'equal))) -(defun content-language-chooser () - "Note that in the current implementation other GET parameters than - language will be lost (not appended to script-name)." +(defun content-language-chooser () (html ((:p :class "languages") "Content languages: " (loop for (language-symbol language-name) in (website-languages) - do (labels ((show-language-link () - (html (cmslink (format nil "~A?language=~A" (hunchentoot:script-name*) language-symbol) + do (labels ((show-language-link () + (html (cmslink (with-output-to-string (out) + (write-string (hunchentoot:script-name*) out) + ;; write language param and remaining get params + (write-string "?language=" out) + (write-string language-symbol out) + (dolist (get-param (remove "language" (hunchentoot:get-parameters*) :key #'first :test #'equal)) + (destructuring-bind (key . value) get-param + (write-string "&" out) + (write-string key out) + (write-string "=" out) + (write-string value out)))) (:princ-safe language-name))))) (if (equal (request-language) language-symbol) (html "[" (show-language-link) "]")

1 0

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

31 Jul '08

Revision: 3704 Author: ksprotte URL: http://bknr.net/trac/changeset/3704 replaced fixed host createrainforest.org by (website-host) for poi xml U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 07:44:11 UTC (rev 3703) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-07-31 08:02:37 UTC (rev 3704) @@ -457,8 +457,8 @@ (attribute "title" (slot-string image 'title language)) (attribute "subtitle" (slot-string image 'subtitle language)) (with-element "description" (text (slot-string image 'description language)))) - (with-element "url" (text (format nil "http://createrainforest.org/image/~D" - (store-object-id image)))) + (with-element "url" (text (format nil "http://~A/image/~D" + (website-host) (store-object-id image)))) (with-element "width" (text (princ-to-string (store-image-width image)))) (with-element "height" (text (princ-to-string (store-image-height image))))))) (with-accessors ((id store-object-id)

1 0