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

[bknr-cvs] hans changed trunk/bknr/web/src/
by BKNR Commits 22 Aug '08

22 Aug '08

Revision: 3730 Author: hans URL: http://bknr.net/trac/changeset/3730 Minor tweaks for QuickHoney 2.0 U trunk/bknr/web/src/rss/rss.lisp U trunk/bknr/web/src/sysclasses/user.lisp Modified: trunk/bknr/web/src/rss/rss.lisp =================================================================== --- trunk/bknr/web/src/rss/rss.lisp 2008-08-19 11:49:23 UTC (rev 3729) +++ trunk/bknr/web/src/rss/rss.lisp 2008-08-22 23:09:48 UTC (rev 3730) @@ -63,7 +63,7 @@ (defmethod prepare-for-snapshot ((channel rss-channel)) "When snapshotting, remove items from CHANNEL that are destroyed." (setf (slot-value channel 'items) - (remove-if #'object-destroyed-p (rss-channel-items channel)))) + (remove-if #'object-destroyed-p (slot-value channel 'items)))) ;; Mixin for items Modified: trunk/bknr/web/src/sysclasses/user.lisp =================================================================== --- trunk/bknr/web/src/sysclasses/user.lisp 2008-08-19 11:49:23 UTC (rev 3729) +++ trunk/bknr/web/src/sysclasses/user.lisp 2008-08-22 23:09:48 UTC (rev 3730) @@ -83,7 +83,8 @@ (set-smb-password (user-login user) plaintext-password))) (defmethod admin-p ((user user)) - (user-has-flag user :admin)) + (when (user-has-flag user :admin) + t)) (defmethod user-mail-error-p ((user user)) (and (slot-boundp user 'mail-error)

1 0

[bknr-cvs] edi changed trunk/thirdparty/drakma/
by BKNR Commits 19 Aug '08

19 Aug '08

Revision: 3729 Author: edi URL: http://bknr.net/trac/changeset/3729 Fix generation of user-agent header U trunk/thirdparty/drakma/CHANGELOG.txt U trunk/thirdparty/drakma/request.lisp Modified: trunk/thirdparty/drakma/CHANGELOG.txt =================================================================== --- trunk/thirdparty/drakma/CHANGELOG.txt 2008-08-07 20:06:50 UTC (rev 3728) +++ trunk/thirdparty/drakma/CHANGELOG.txt 2008-08-19 11:49:23 UTC (rev 3729) @@ -1,4 +1,5 @@ Added *ALLOW-DOTLESS-COOKIE-DOMAINS-P* (thanks to Daniel Janus) +Fix generation of user agent header (bug caught by Chaitanya Gupta) Version 0.11.5 2008-03-21 Modified: trunk/thirdparty/drakma/request.lisp =================================================================== --- trunk/thirdparty/drakma/request.lisp 2008-08-07 20:06:50 UTC (rev 3728) +++ trunk/thirdparty/drakma/request.lisp 2008-08-19 11:49:23 UTC (rev 3729) @@ -514,7 +514,7 @@ (string-upcase protocol)) (write-header "Host" "~A~@[:~A~]" (uri-host uri) (non-default-port uri)) (when user-agent - (write-header "User-Agent" (user-agent-string user-agent))) + (write-header "User-Agent" "~A" (user-agent-string user-agent))) (when basic-authorization (write-header "Authorization" "Basic ~A" (base64:string-to-base64-string

1 0

[bknr-cvs] hans changed trunk/thirdparty/usocket/
by BKNR Commits 07 Aug '08

07 Aug '08

Revision: 3728 Author: hans URL: http://bknr.net/trac/changeset/3728 revert out usocket update again as it breaks buildbot tests on sbcl U trunk/thirdparty/usocket/Makefile U trunk/thirdparty/usocket/README U trunk/thirdparty/usocket/TODO U trunk/thirdparty/usocket/backend/allegro.lisp U trunk/thirdparty/usocket/backend/armedbear.lisp U trunk/thirdparty/usocket/backend/clisp.lisp U trunk/thirdparty/usocket/backend/cmucl.lisp U trunk/thirdparty/usocket/backend/lispworks.lisp U trunk/thirdparty/usocket/backend/openmcl.lisp U trunk/thirdparty/usocket/backend/sbcl.lisp U trunk/thirdparty/usocket/backend/scl.lisp U trunk/thirdparty/usocket/condition.lisp U trunk/thirdparty/usocket/package.lisp U trunk/thirdparty/usocket/test/package.lisp U trunk/thirdparty/usocket/test/test-usocket.lisp U trunk/thirdparty/usocket/test/usocket-test.asd U trunk/thirdparty/usocket/usocket.asd U trunk/thirdparty/usocket/usocket.lisp Change set too large, please see URL above

1 0

[bknr-cvs] hans changed trunk/thirdparty/usocket/
by BKNR Commits 07 Aug '08

07 Aug '08

Revision: 3727 Author: hans URL: http://bknr.net/trac/changeset/3727 retry with fixed usocket-0.4.x U trunk/thirdparty/usocket/Makefile U trunk/thirdparty/usocket/README U trunk/thirdparty/usocket/TODO U trunk/thirdparty/usocket/backend/allegro.lisp U trunk/thirdparty/usocket/backend/armedbear.lisp U trunk/thirdparty/usocket/backend/clisp.lisp U trunk/thirdparty/usocket/backend/cmucl.lisp U trunk/thirdparty/usocket/backend/lispworks.lisp U trunk/thirdparty/usocket/backend/openmcl.lisp U trunk/thirdparty/usocket/backend/sbcl.lisp U trunk/thirdparty/usocket/backend/scl.lisp U trunk/thirdparty/usocket/condition.lisp U trunk/thirdparty/usocket/package.lisp U trunk/thirdparty/usocket/test/package.lisp U trunk/thirdparty/usocket/test/test-usocket.lisp U trunk/thirdparty/usocket/test/usocket-test.asd U trunk/thirdparty/usocket/usocket.asd U trunk/thirdparty/usocket/usocket.lisp Change set too large, please see URL above

1 0

[bknr-cvs] hans changed trunk/thirdparty/usocket/
by BKNR Commits 07 Aug '08

07 Aug '08

Revision: 3726 Author: hans URL: http://bknr.net/trac/changeset/3726 back out usocket 0.4.x merge, openmcl backend is broken U trunk/thirdparty/usocket/Makefile U trunk/thirdparty/usocket/README U trunk/thirdparty/usocket/TODO U trunk/thirdparty/usocket/backend/allegro.lisp U trunk/thirdparty/usocket/backend/armedbear.lisp U trunk/thirdparty/usocket/backend/clisp.lisp U trunk/thirdparty/usocket/backend/cmucl.lisp U trunk/thirdparty/usocket/backend/lispworks.lisp U trunk/thirdparty/usocket/backend/openmcl.lisp U trunk/thirdparty/usocket/backend/sbcl.lisp U trunk/thirdparty/usocket/backend/scl.lisp U trunk/thirdparty/usocket/condition.lisp U trunk/thirdparty/usocket/package.lisp U trunk/thirdparty/usocket/test/package.lisp U trunk/thirdparty/usocket/test/test-usocket.lisp U trunk/thirdparty/usocket/test/usocket-test.asd U trunk/thirdparty/usocket/usocket.asd U trunk/thirdparty/usocket/usocket.lisp Change set too large, please see URL above

1 0

[bknr-cvs] hans changed trunk/thirdparty/usocket/
by BKNR Commits 07 Aug '08

07 Aug '08

Revision: 3725 Author: hans URL: http://bknr.net/trac/changeset/3725 Update to 0.4.x branch from usocket svn to let the buildbot try it out. U trunk/thirdparty/usocket/Makefile U trunk/thirdparty/usocket/README U trunk/thirdparty/usocket/TODO U trunk/thirdparty/usocket/backend/allegro.lisp U trunk/thirdparty/usocket/backend/armedbear.lisp U trunk/thirdparty/usocket/backend/clisp.lisp U trunk/thirdparty/usocket/backend/cmucl.lisp U trunk/thirdparty/usocket/backend/lispworks.lisp U trunk/thirdparty/usocket/backend/openmcl.lisp U trunk/thirdparty/usocket/backend/sbcl.lisp U trunk/thirdparty/usocket/backend/scl.lisp U trunk/thirdparty/usocket/condition.lisp U trunk/thirdparty/usocket/package.lisp U trunk/thirdparty/usocket/test/package.lisp U trunk/thirdparty/usocket/test/test-usocket.lisp U trunk/thirdparty/usocket/test/usocket-test.asd U trunk/thirdparty/usocket/usocket.asd U trunk/thirdparty/usocket/usocket.lisp Change set too large, please see URL above

1 0

[bknr-cvs] hans changed trunk/bknr/web/src/bknr.web.asd
by BKNR Commits 04 Aug '08

04 Aug '08

Revision: 3724 Author: hans URL: http://bknr.net/trac/changeset/3724 Fix dependency for frontend module. U trunk/bknr/web/src/bknr.web.asd Modified: trunk/bknr/web/src/bknr.web.asd =================================================================== --- trunk/bknr/web/src/bknr.web.asd 2008-08-02 22:32:42 UTC (rev 3723) +++ trunk/bknr/web/src/bknr.web.asd 2008-08-04 00:12:51 UTC (rev 3724) @@ -98,7 +98,7 @@ :depends-on ("sysclasses" "packages")) (:module "frontend" - :depends-on ("packages") + :depends-on ("packages" "web") :serial t :components ((:file "frontend-config") (:file "frontend")))

1 0

[bknr-cvs] hans changed trunk/
by BKNR Commits 02 Aug '08

02 Aug '08

Revision: 3723 Author: hans URL: http://bknr.net/trac/changeset/3723 Make news work better. Add news article display (not yet finished). Fix action box show/hide animation. U trunk/bknr/web/src/web/handlers.lisp U trunk/projects/quickhoney/src/handlers.lisp U trunk/projects/quickhoney/src/imageproc.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/web/handlers.lisp =================================================================== --- trunk/bknr/web/src/web/handlers.lisp 2008-08-01 15:43:33 UTC (rev 3722) +++ trunk/bknr/web/src/web/handlers.lisp 2008-08-02 22:32:42 UTC (rev 3723) @@ -3,7 +3,6 @@ (enable-interpol-syntax) (defvar *bknr-debug* nil) -(defvar *website* nil) (defvar *website-modules* (make-hash-table :test #'equal)) Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-08-01 15:43:33 UTC (rev 3722) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-08-02 22:32:42 UTC (rev 3723) @@ -444,10 +444,13 @@ (encode-object-element "date" (format-date-time (blob-timestamp image) :vms-style t :show-time nil)) (encode-object-element "name" (store-image-name image))) (:method ((image quickhoney-image)) - (let ((vectorp (member :vector (store-image-keywords image)))) - (encode-object-element "category" (if vectorp "vector" "pixel")) - (encode-object-element "subcategory" "unknown"))) + (encode-object-element "type" "upload") + (with-object-element ("keywords") + (with-json-array () + (dolist (keyword (store-image-keywords image)) + (encode-array-element (string-downcase (symbol-name keyword))))))) (:method ((item quickhoney-news-item)) + (encode-object-element "type" "news") (encode-object-element "title" (quickhoney-news-item-title item)) (encode-object-element "text" (quickhoney-news-item-text item)))) Modified: trunk/projects/quickhoney/src/imageproc.lisp =================================================================== --- trunk/projects/quickhoney/src/imageproc.lisp 2008-08-01 15:43:33 UTC (rev 3722) +++ trunk/projects/quickhoney/src/imageproc.lisp 2008-08-02 22:32:42 UTC (rev 3723) @@ -30,25 +30,27 @@ (nreverse coords))) (defun corner-image (&key (image *default-image*) - (radius (/ (max (image-width image) (image-height image)) 40))) + (radius (/ (max (image-width image) (image-height image)) 40)) + corner-color) (with-default-image (image) - (setf (save-alpha-p) t) - (let ((transparent-color (if (true-color-p) #x7f000000 + (unless corner-color + (setf (save-alpha-p) t + corner-color (if (true-color-p) #x7f000000 (or (transparent-color) (allocate-color 255 255 255 :alpha 127) - (error "can't allocate transparent color for button"))))) - (setf (transparent-color) transparent-color) - (let ((coords (corner-cutout-coords (image-width) (image-height) radius))) - (destructuring-bind (x-tx y-tx) (car coords) - (do-rows (y) - (do-pixels-in-row (x) - (when (and (eql x x-tx) - (eql y y-tx)) - (setf (raw-pixel) transparent-color) - (when (cdr coords) - (setf coords (cdr coords) - x-tx (caar coords) - y-tx (cadar coords))))))))))) + (error "can't allocate transparent color for button"))) + (transparent-color) corner-color)) + (let ((coords (corner-cutout-coords (image-width) (image-height) radius))) + (destructuring-bind (x-tx y-tx) (car coords) + (do-rows (y) + (do-pixels-in-row (x) + (when (and (eql x x-tx) + (eql y y-tx)) + (setf (raw-pixel) corner-color) + (when (cdr coords) + (setf coords (cdr coords) + x-tx (caar coords) + y-tx (cadar coords)))))))))) (define-imageproc-handler cutout-button (input-image &optional keyword (background-color "ffffff") (button-size "208") (radius "8")) (declare (ignore background-color)) @@ -87,4 +89,24 @@ (round (/ (- (image-height input-image) height) 2)) 0 0 width height) - thumbnail-image))) \ No newline at end of file + thumbnail-image))) + +(defparameter +news-image-width+ 428 + "Width of news images") +(defparameter +news-image-corner-radius+ 8 + "Corner radius for news images") + +(define-imageproc-handler news-article-cutout (input-image) + (let* ((image-height (floor (* +news-image-width+ + (/ (image-height input-image) (image-width input-image))))) + (output-image (create-image +news-image-width+ image-height t))) + (copy-image input-image output-image + 0 0 + 0 0 + +news-image-width+ image-height + :resize t :resample t + :dest-width +news-image-width+ :dest-height image-height) + (corner-image :image output-image + :radius +news-image-corner-radius+ + :corner-color (allocate-color 255 255 255 :image output-image)) + output-image)) \ No newline at end of file Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2008-08-01 15:43:33 UTC (rev 3722) +++ trunk/projects/quickhoney/website/static/javascript.js 2008-08-02 22:32:42 UTC (rev 3723) @@ -1,5 +1,9 @@ // -*- Java -*- +/* configuration */ + +var max_news_items = 50; /* maximum number of news items to display */ + /* directory definitions */ var directory_button = []; @@ -223,7 +227,8 @@ 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'); + ((element.href.match(/#news\/(\d+)/)[1] == year) ? addElementClass : removeElementClass) + (element, 'active'); } }, this.parentNode.childNodes); return true; @@ -236,22 +241,62 @@ return true; } +function intersection(a, b) +{ + var result = []; + map(function (value) { + if (findValue(b, value) != -1) { + result.push(value); + } + }, a); + return result; +} + +function make_upload_item(item) +{ + item.category = (findValue(item.keywords, 'pixel') == -1) ? 'vector' : 'pixel'; + item.subcategory = intersection(item.keywords, directory_button[item.category])[0]; + var color = (item.category == 'pixel') ? 'ff00ff' : '00ccff'; + var image_link = '/index#' + item.category + '/' + item.subcategory + '/' + item.name; + return DIV({ 'class': 'newsentry autonews news_' + item.category }, + A({ href: image_link }, + IMG({ src: "/image/" + item.name + '/cutout-button,,' + color + ',98,4'})), + DIV(null, + H1(null, item.name), + item.date, ' by ', item.owner, ' | ', + A({ href: image_link }, 'permalink'), + BR(), + item.description)); +} + +function make_news_item(item) +{ + return DIV({ 'class': 'newsentry' }, + IMG({ src: "/image/" + item.name + '/news-article-cutout'}), + DIV(null, + H1(null, item.title), + item.date, ' by ', item.owner, ' | ', + A({ href: '#' }, 'permalink'), + BR(), + item.text)); +} + 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.owner, ' | ', - A({ href: '/index#' + item.category + '/' + item.subcategory + '/' + item.image_name }, 'permalink'), - BR(), - item.description)), - DIV({ 'class': 'news_sep' }) ]; - }, data.items)); + try { + if (data.items.length > max_news_items) { + data.items.length = max_news_items; + } + replaceChildNodes('newsentries', + map(function (item) { + return [ ((item.type == 'upload') ? make_upload_item : make_news_item)(item), + DIV({ 'class': 'news_sep' }) ]; + }, data.items)); + $('archive-navigation').style.visibility = 'inherit'; + } + catch (e) { + log('error displaying news: ' + e); + } } function load_news_archive(data) @@ -261,7 +306,6 @@ alert('no archive data found'); } var currentYear; - var active = true; replaceChildNodes('archive-navigation', SPAN({ 'class': 'title' }, 'Archive'), BR(), map(function (entry) { @@ -269,15 +313,12 @@ 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' : '')}, + var link = A({ href: '#news/' + year + '/' + month, 'class': 'month '}, month_names[month - 1], BR()); link.onclick = select_archive_month; result.push(link); @@ -460,6 +501,8 @@ '30be01', function() { footer_hide(); + replaceChildNodes('newsentries'); + $('archive-navigation').style.visibility = 'hidden'; loadJSONDoc('/json-news-archive/quickhoney').addCallbacks(load_news_archive, alert); loadJSONDoc('/json-news/quickhoney').addCallbacks(load_news, alert); }); @@ -529,6 +572,8 @@ $('menu').className = pagename; document.body.className = pagename; + overlay_remove(); + // Update globals current_directory = pagename; current_subdirectory = null; @@ -826,6 +871,7 @@ var current_page_index = position_to_page(query_position); make_pages_navbar(); + overlay_remove(); var page = query_result_pages[current_page_index]; var thumbnail_html = ''; @@ -885,6 +931,7 @@ debug('display_image index ' + index); footer_hide(); + overlay_remove(); display_path(); make_images_navbar(); make_image_action_buttons(); @@ -998,7 +1045,7 @@ { method: 'POST', headers: {"Content-Type":"application/x-www-form-urlencoded"}, sendContent: queryString({ from: $('hey_from').value, text: $('hey_text').value }) }) - .addCallback(hide_overlay); + .addCallback(overlay_remove); make_overlay('send-comment', 'Sending your comment', 300); return false; } @@ -1146,8 +1193,9 @@ document.location.href = document.location.href.replace(/\/image-browse.*/, "index#"); } -function hide_overlay() +function overlay_remove() { + replaceChildNodes('overlay'); $('overlay').style.visibility = 'hidden'; return false; } @@ -1168,7 +1216,7 @@ id: 'close', width: 13, height: 13})); overlay.style.width = width + 'px'; $('close').style.left = (width - 23) + 'px'; - $('close').onclick = hide_overlay; + $('close').onclick = overlay_remove; var elements = []; for (var i = 3; i < arguments.length; i++) { elements.push(arguments[i]); @@ -1368,13 +1416,15 @@ appendChildNodes('image_action_buttons', IMG({ id: 'buy-top', src: recolored_image_path('buy-top'), width: 90, height: 1})); } appendChildNodes('image_action_buttons', IMG({ id: 'buy-right-line', src: recolored_image_path('buy-right-line'), width: 1, height: height})); - var animator = new YAHOO.util.Anim('image_action_buttons', {}, .3, + var animator = new YAHOO.util.Anim('image_action_buttons', {}, 0.3, YAHOO.util.Easing.easeBoth); $('image_action_buttons').onmouseover = function () { + animator.stop(); animator.attributes = { width: { to: 127 }, left: { to: 518 } }; animator.animate(); } $('image_action_buttons').onmouseout = function () { + animator.stop(); animator.attributes = { width: { to: 60 }, left: { to: 584 } }; animator.animate(); } Modified: trunk/projects/quickhoney/website/static/styles.css =================================================================== --- trunk/projects/quickhoney/website/static/styles.css 2008-08-01 15:43:33 UTC (rev 3722) +++ trunk/projects/quickhoney/website/static/styles.css 2008-08-02 22:32:42 UTC (rev 3723) @@ -431,10 +431,17 @@ .newsentry { width: 428px; - height: 108px; position: relative; } +.autonews { + height: 108px; +} + +.autonews img { + padding: 0px; +} + .newsentry img { position: absolute; top: 5px; left: 5px; @@ -632,4 +639,4 @@ .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 +.archive { padding-left: 1em; } Modified: trunk/projects/quickhoney/website/templates/index.xml =================================================================== --- trunk/projects/quickhoney/website/templates/index.xml 2008-08-01 15:43:33 UTC (rev 3722) +++ trunk/projects/quickhoney/website/templates/index.xml 2008-08-02 22:32:42 UTC (rev 3723) @@ -134,23 +134,6 @@ <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>

1 0

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

01 Aug '08

Revision: 3722 Author: ksprotte URL: http://bknr.net/trac/changeset/3722 checkpoint 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-08-01 15:02:03 UTC (rev 3721) +++ trunk/projects/bos/m2/packages.lisp 2008-08-01 15:43:33 UTC (rev 3722) @@ -224,6 +224,7 @@ #:poi-icon #:poi-media #:make-poi + #:update-poi #:poi-complete #:poi-center-x #:poi-center-y Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-08-01 15:02:03 UTC (rev 3721) +++ trunk/projects/bos/m2/poi.lisp 2008-08-01 15:43:33 UTC (rev 3722) @@ -102,6 +102,16 @@ (defmethod destroy-object :before ((poi poi)) (mapc #'delete-object (poi-media poi))) +(deftransaction update-poi (poi &key published icon area) + (check-type published boolean) + (check-type area list) + (setf (poi-published poi) published) + (when icon + (setf (poi-icon poi) icon)) + (when area + (setf (poi-area poi) area)) + poi) + (defmethod poi-complete ((poi poi) language) (and (every #'(lambda (slot-name) (slot-string poi slot-name language nil)) '(title subtitle description)) (poi-area poi) Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-08-01 15:02:03 UTC (rev 3721) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-08-01 15:43:33 UTC (rev 3722) @@ -70,7 +70,8 @@ ((:table :border "1") (:tr (:td "name") (:td (:princ-safe (poi-name poi)) - (cmslink (format nil "/poi-xml/~D?lang=~A" (store-object-id poi) language) "view"))) + " " + (cmslink (format nil "/poi-xml/~D?lang=~A" (store-object-id poi) language) "[view]"))) (:tr (:td "published") (:td (checkbox-field "published" "published" :checked (poi-published poi)))) (:tr (:td "title") @@ -90,11 +91,15 @@ (html (:princ-safe (format nil "~D/~D " (first (poi-area poi)) (second (poi-area poi))))) (cmslink (format nil "map-browser/~A/~A?chosen-url=~A" (first (poi-area poi)) (second (poi-area poi)) - (encode-urlencoded (format nil "~A?action=save&" (hunchentoot:request-uri*)))) + (encode-urlencoded (format nil "~A?action=save&~:[~;published=on~]" + (hunchentoot:request-uri*) + (poi-published poi)))) "[relocate]")) (t (cmslink (format nil "map-browser/?chosen-url=~A" - (encode-urlencoded (format nil "~A?action=save&" (hunchentoot:request-uri*)))) + (encode-urlencoded (format nil "~A?action=save&~:[~;published=on~]" + (hunchentoot:request-uri*) + (poi-published poi)))) "[choose]"))))) (:tr (:td "icon") (:td (icon-chooser "icon" (poi-icon poi)))) @@ -104,8 +109,10 @@ (:tr (loop for image in (poi-sat-images poi) for index upfrom 0 - 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))))) + 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) (html ((:img :src "/images/trans.gif" :width "16"))) @@ -124,41 +131,46 @@ :br (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?")))) - ;; ;;;;;;;;;;;;;;;; - (: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"))))))))))))) + (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 + ((:input :type "hidden" :name "poi" :value (store-object-id poi))) + (:tr (:td "Type") + (:td (select-box "new-medium-type" (mapcar #'(lambda (class-name) (string-downcase 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)) - (with-query-params (published title subtitle description language x y icon movie) + (with-query-params ((published nil boolean) + title subtitle description language + (x nil integer) + (y nil integer) + icon) + (prin1 (list :published published :title title :subtitle subtitle :x x :y y :icon icon)) (unless language (setq language (request-language))) - (let ((args (list :title title - :published published - :subtitle subtitle - :description description - :icon icon))) - (when (and x y) - (setq args (append args (list :area (list (parse-integer x) (parse-integer y)))))) - (when movie - (setq args (append args (list :movies (list movie))))) - (apply #'update-poi poi language args)) + (update-textual-attributes poi language + :title title + :subtitle subtitle + :description description) + (update-poi poi + :published published + :area (when (and x y) (list x y)) + :icon icon) (with-bos-cms-page (:title "POI has been updated") (html (:h2 "Your changes have been saved") "You may " (cmslink (edit-object-url poi) "continue editing the POI") ".")))) @@ -333,26 +345,24 @@ "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)) + (with-query-params ((poi nil integer) + new-medium-type) + (setq poi (find-store-object 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))) + (eql (cl-gd:image-height) *poi-image-height*)) + (error "Invalid image size. The image needs to be ~D pixels wide and ~D pixels high. Your uploaded ~ + image is ~D pixels wide and ~D pixels high. Please use an image editor to resize the image ~ + and upload it again." + *poi-image-width* *poi-image-height* + (cl-gd:image-width) (cl-gd:image-height)))) (let ((new-medium (import-image upload - :class-name (type-of medium) + :class-name (if medium + (type-of medium) + (intern (string-upcase new-medium-type))) :initargs `(:poi ,poi)))) (when medium (delete-object medium))

1 0

[bknr-cvs] hans changed trunk/projects/quickhoney/upgrade-stuff/import.lisp
by BKNR Commits 01 Aug '08

01 Aug '08

Revision: 3721 Author: hans URL: http://bknr.net/trac/changeset/3721 Import more pictures U trunk/projects/quickhoney/upgrade-stuff/import.lisp Modified: trunk/projects/quickhoney/upgrade-stuff/import.lisp =================================================================== --- trunk/projects/quickhoney/upgrade-stuff/import.lisp 2008-08-01 12:50:18 UTC (rev 3720) +++ trunk/projects/quickhoney/upgrade-stuff/import.lisp 2008-08-01 15:02:03 UTC (rev 3721) @@ -1,19 +1,32 @@ (in-package :quickhoney) +(defun replace-image (pathname) + (handler-case + (let ((old (store-image-with-name (pathname-name pathname)))) + (when old + (format t "deleting ~A~%" old) + (delete-object old)) + (import-image pathname)) + (error (e) + (format t "~&; error importing ~S: ~A~%" pathname e)))) + (dolist (name '(#p"type-news.png" #p"type-pixel.png" #p"type-shop.png" #p"type-vector.png")) (import-image name :keywords '(:type))) -(dolist (name '(#P"overlay-close.gif" - #P"hey.gif" - #P"buy.gif" #P"buy-top.gif" #P"buy-print.gif" #P"buy-file.gif" #P"buy-t-shirt.gif" - #P"buy-right-line.gif" - #P"t-shirt-sample-background.gif" - #P"print-sample.jpg" - #P"button-bottom.gif" - #P"add-to-cart.gif" #P"checkout.gif")) - (handler-case - (import-image name) - (error (e) - (format t "~&; error importing ~S: ~A~%" name e)))) +(dolist (pathname '(#P"overlay-close.gif" + #P"hey.gif" + #P"buy.gif" #P"buy-top.gif" #P"buy-print.gif" #P"buy-file.gif" #P"buy-t-shirt.gif" + #P"buy-right-line.gif" + #P"t-shirt-sample-background.gif" + #P"print-sample.jpg" + #P"button-bottom.gif" + #P"add-to-cart.gif" #P"checkout.gif" + #P"pixel.png" #P"pixel-selected.png" #P"pixel-unselected.png" #P"pixel-hover.png" + #P"vector.png" #P"vector-selected.png" #P"vector-unselected.png" #P"vector-hover.png" + #P"news.png" #P"news-selected.png" #P"news-unselected.png" #P"news-hover.png" + #P"shop.png" #P"shop-selected.png" #P"shop-unselected.png" #P"shop-hover.png" + #P"contact.png" #P"contact-selected.png" #P"contact-unselected.png" #P"contact-hover.png" + #P"quickhoney.png")) + (replace-image pathname)) (import-image #p"news-sep.gif") \ No newline at end of file

1 0