mailman3.common-lisp.net
Sign In
Sign Up
Sign In
Sign Up
Manage this list
×
Keyboard Shortcuts
Thread View
j
: Next unread message
k
: Previous unread message
j a
: Jump to all threads
j l
: Jump to MailingList overview
2024
November
October
September
August
July
June
May
April
March
February
January
2023
December
November
October
September
August
July
June
May
April
March
February
January
2022
December
November
October
September
August
July
June
May
April
March
February
January
2021
December
November
October
September
August
July
June
May
April
March
February
January
2020
December
November
October
September
August
July
June
May
April
March
February
January
2019
December
November
October
September
August
July
June
May
April
March
February
January
2018
December
November
October
September
August
July
June
May
April
March
February
January
2017
December
November
October
September
August
July
June
May
April
March
February
January
2016
December
November
October
September
August
July
June
May
April
March
February
January
2015
December
November
October
September
August
July
June
May
April
March
February
January
2014
December
November
October
September
August
July
June
May
April
March
February
January
2013
December
November
October
September
August
July
June
May
April
March
February
January
2012
December
November
October
September
August
July
June
May
April
March
February
January
2011
December
November
October
September
August
July
June
May
April
March
February
January
2010
December
November
October
September
August
July
June
May
April
March
February
January
2009
December
November
October
September
August
July
June
May
April
March
February
January
2008
December
November
October
September
August
July
June
May
April
March
February
January
2007
December
November
October
September
August
July
June
May
April
March
February
January
2006
December
November
October
September
August
July
June
May
April
March
February
January
List overview
Download
bknr-cvs
July 2008
----- 2024 -----
November 2024
October 2024
September 2024
August 2024
July 2024
June 2024
May 2024
April 2024
March 2024
February 2024
January 2024
----- 2023 -----
December 2023
November 2023
October 2023
September 2023
August 2023
July 2023
June 2023
May 2023
April 2023
March 2023
February 2023
January 2023
----- 2022 -----
December 2022
November 2022
October 2022
September 2022
August 2022
July 2022
June 2022
May 2022
April 2022
March 2022
February 2022
January 2022
----- 2021 -----
December 2021
November 2021
October 2021
September 2021
August 2021
July 2021
June 2021
May 2021
April 2021
March 2021
February 2021
January 2021
----- 2020 -----
December 2020
November 2020
October 2020
September 2020
August 2020
July 2020
June 2020
May 2020
April 2020
March 2020
February 2020
January 2020
----- 2019 -----
December 2019
November 2019
October 2019
September 2019
August 2019
July 2019
June 2019
May 2019
April 2019
March 2019
February 2019
January 2019
----- 2018 -----
December 2018
November 2018
October 2018
September 2018
August 2018
July 2018
June 2018
May 2018
April 2018
March 2018
February 2018
January 2018
----- 2017 -----
December 2017
November 2017
October 2017
September 2017
August 2017
July 2017
June 2017
May 2017
April 2017
March 2017
February 2017
January 2017
----- 2016 -----
December 2016
November 2016
October 2016
September 2016
August 2016
July 2016
June 2016
May 2016
April 2016
March 2016
February 2016
January 2016
----- 2015 -----
December 2015
November 2015
October 2015
September 2015
August 2015
July 2015
June 2015
May 2015
April 2015
March 2015
February 2015
January 2015
----- 2014 -----
December 2014
November 2014
October 2014
September 2014
August 2014
July 2014
June 2014
May 2014
April 2014
March 2014
February 2014
January 2014
----- 2013 -----
December 2013
November 2013
October 2013
September 2013
August 2013
July 2013
June 2013
May 2013
April 2013
March 2013
February 2013
January 2013
----- 2012 -----
December 2012
November 2012
October 2012
September 2012
August 2012
July 2012
June 2012
May 2012
April 2012
March 2012
February 2012
January 2012
----- 2011 -----
December 2011
November 2011
October 2011
September 2011
August 2011
July 2011
June 2011
May 2011
April 2011
March 2011
February 2011
January 2011
----- 2010 -----
December 2010
November 2010
October 2010
September 2010
August 2010
July 2010
June 2010
May 2010
April 2010
March 2010
February 2010
January 2010
----- 2009 -----
December 2009
November 2009
October 2009
September 2009
August 2009
July 2009
June 2009
May 2009
April 2009
March 2009
February 2009
January 2009
----- 2008 -----
December 2008
November 2008
October 2008
September 2008
August 2008
July 2008
June 2008
May 2008
April 2008
March 2008
February 2008
January 2008
----- 2007 -----
December 2007
November 2007
October 2007
September 2007
August 2007
July 2007
June 2007
May 2007
April 2007
March 2007
February 2007
January 2007
----- 2006 -----
December 2006
November 2006
October 2006
September 2006
August 2006
July 2006
June 2006
May 2006
April 2006
March 2006
February 2006
January 2006
bknr-cvs@common-lisp.net
1 participants
321 discussions
Start a n
N
ew thread
[bknr-cvs] hans changed trunk/
by BKNR Commits
01 Aug '08
01 Aug '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
0
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
0
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
0
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
0
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
0
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
0
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
0
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
0
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
0
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
0
0
← Newer
1
2
3
4
...
33
Older →
Jump to page:
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
Results per page:
10
25
50
100
200