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

[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

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

01 Aug '08

Revision: 3720 Author: ksprotte URL: http://bknr.net/trac/changeset/3720 BKNR web: QUERY-PARAM and WITH-QUERY-PARAMS now support conversion from the value string to an optionally specified type. U trunk/bknr/web/src/web/web-macros.lisp U trunk/bknr/web/src/web/web-utils.lisp Modified: trunk/bknr/web/src/web/web-macros.lisp =================================================================== --- trunk/bknr/web/src/web/web-macros.lisp 2008-08-01 12:08:44 UTC (rev 3719) +++ trunk/bknr/web/src/web/web-macros.lisp 2008-08-01 12:50:18 UTC (rev 3720) @@ -19,20 +19,31 @@ names) ,@body)) -(defmacro with-query-params ((&rest params) &body body) - (let ((vars (loop for param in params - when (and (symbolp param) - (not (null param))) - collect (list param `(query-param ,(string-downcase (symbol-name param)))) - when (consp param) - collect (list (car param) - `(or (parameter ,(string-downcase (symbol-name (car param)))) - ,(second param)))))) - (if vars - `(let ,vars - ,@body) - (first body)))) +(defmacro with-query-params ((&rest parameters) &body body) + "PARAMETERS is a list of parameter-specifiers. A parameter-specifier +has the form (VARIABLE &OPTIONAL DEFAULT-VALUE TYPE) or can be a +single VARIABLE. +If the TYPE is specified, the value is converted like in +HUNCHENTOOT:DEFINE-EASY-HANDLER when PARAMETER-TYPE is given. + +With respect to the conversion of an empty string, there is a subtle +difference between the TYPE specified as STRING and the TYPE left +unspecified. In the former case, the converted value will still be an +empty string, while in the latter VARIABLE will be bound to NIL." + (flet ((parameter-binding (parameter-specifier) + (destructuring-bind (variable &optional default-value type) + (ensure-list parameter-specifier) + (let ((query-param-form (if type + `(query-param ,(string-downcase variable) :type ',type) + `(query-param ,(string-downcase variable))))) + `(,variable + ,(if default-value + `(or ,query-param-form ,default-value) + query-param-form)))))) + `(let ,(mapcar #'parameter-binding parameters) + ,@body))) + (defmacro form-case (&rest cases) `(cond ,@(mapcar #'(lambda (c) Modified: trunk/bknr/web/src/web/web-utils.lisp =================================================================== --- trunk/bknr/web/src/web/web-utils.lisp 2008-08-01 12:08:44 UTC (rev 3719) +++ trunk/bknr/web/src/web/web-utils.lisp 2008-08-01 12:50:18 UTC (rev 3720) @@ -70,10 +70,12 @@ (append (when get (get-parameters*)) (when post (post-parameters*)))) -(defun query-param (param-name &key (get t) (post t)) +(defun query-param (param-name &key (get t) (post t) type) (let ((value (cdr (assoc param-name (query-params :get get :post post) :test #'string-equal)))) - (unless (equal value "") - value))) + (if type + (hunchentoot::convert-parameter value type) + (unless (equal value "") + value)))) (defun query-param-list (param-name &key (get t) (post t)) (assoc-values param-name (query-params :get get :post post)

1 0

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

01 Aug '08

Revision: 3719 Author: ksprotte URL: http://bknr.net/trac/changeset/3719 whitespace cleanup and a tiny bit of refactoring in bknr web U trunk/bknr/web/src/web/web-macros.lisp U trunk/bknr/web/src/web/web-utils.lisp Modified: trunk/bknr/web/src/web/web-macros.lisp =================================================================== --- trunk/bknr/web/src/web/web-macros.lisp 2008-08-01 10:14:42 UTC (rev 3718) +++ trunk/bknr/web/src/web/web-macros.lisp 2008-08-01 12:08:44 UTC (rev 3719) @@ -13,81 +13,83 @@ (defmacro with-bknr-page ((&rest args) &body body) `(show-page-with-error-handlers (lambda () (html ,@body)) ,@args)) -(defmacro with-cookies ((&rest names) &rest body) +(defmacro with-cookies ((&rest names) &body body) `(let ,(mapcar #'(lambda (name) - `(,name (cookie-in ,(symbol-name name)))) - names) - ,@body)) + `(,name (cookie-in ,(symbol-name name)))) + names) + ,@body)) -(defmacro with-query-params ((&rest params) &rest body) +(defmacro with-query-params ((&rest params) &body body) (let ((vars (loop for param in params - when (and (symbolp param) - (not (null param))) - collect (list param `(query-param ,(string-downcase (symbol-name param)))) - when (consp param) - collect (list (car param) - `(or (parameter ,(string-downcase (symbol-name (car param)))) - ,(second param)))))) + when (and (symbolp param) + (not (null param))) + collect (list param `(query-param ,(string-downcase (symbol-name param)))) + when (consp param) + collect (list (car param) + `(or (parameter ,(string-downcase (symbol-name (car param)))) + ,(second param)))))) (if vars - `(let ,vars - ,@body) - (first body)))) + `(let ,vars + ,@body) + (first body)))) (defmacro form-case (&rest cases) `(cond - ,@(mapcar #'(lambda (c) - (if (eql (car c) t) - `(t ,@(cdr c)) - `((parameter ,(symbol-name (car c))) - (with-query-params (,@(cadr c)) - ,@(cddr c))))) - cases))) + ,@(mapcar #'(lambda (c) + (if (eql (car c) t) + `(t ,@(cdr c)) + `((parameter ,(symbol-name (car c))) + (with-query-params (,@(cadr c)) + ,@(cddr c))))) + cases))) -(defmacro with-http-response ((&key (content-type "text/html") (response +http-ok+)) &rest body) +(defmacro with-http-response ((&key (content-type "text/html") (response +http-ok+)) &body body) `(progn - (setf (content-type) ,content-type) - (setf (return-code) ,response) - ,@body)) + (setf (content-type) ,content-type) + (setf (return-code) ,response) + ,@body)) (defmacro with-http-body ((&key external-format) &body body) + (when external-format + (warn "EXTERNAL-FORMAT is ignored in WITH-HTTP-BODY")) `(with-output-to-string (stream) - (with-xhtml (stream) - ,@body))) + (with-xhtml (stream) + ,@body))) -(defmacro with-image-from-uri ((image-variable prefix) &rest body) +(defmacro with-image-from-uri ((image-variable prefix) &body body) `(multiple-value-bind - (match strings) - (scan-to-strings (format nil "/~a/([0-9]+)(|/.*)$" ,prefix) (script-name*)) - (unless match - (http-error +http-bad-request+ "bad request - missing image path or loid")) - (let ((,image-variable (store-object-with-id (parse-integer (elt strings 0))))) - (unless ,image-variable - (http-error +http-not-found+ "image not found")) - ,@body))) + (match strings) + (scan-to-strings (format nil "/~a/([0-9]+)(|/.*)$" ,prefix) (script-name*)) + (unless match + (http-error +http-bad-request+ "bad request - missing image path or loid")) + (let ((,image-variable (store-object-with-id (parse-integer (elt strings 0))))) + (unless ,image-variable + (http-error +http-not-found+ "image not found")) + ,@body))) -(defmacro define-bknr-tag (name (&rest args) &rest body) +(defmacro define-bknr-tag (name (&rest args) &body body) `(prog1 - (defun ,name (,@args) - ,@body) - (register-tag-function ,(package-name *package*) ,(symbol-name name) (fdefinition ',name)))) + (defun ,name (,@args) + ,@body) + (register-tag-function ,(package-name *package*) ,(symbol-name name) (fdefinition ',name)))) (defmacro html-text-input (variable size &optional maxsize) - `((:input :type "text" - :size ,(format nil "~a" size) - :maxsize ,(format nil "~a" (or maxsize size)) - :name ,(symbol-name variable) - :value ,(or variable "")))) + `((:input :type "text" + :size ,(format nil "~a" size) + :maxsize ,(format nil "~a" (or maxsize size)) + :name ,(symbol-name variable) + :value ,(or variable "")))) (defmacro html-warn (&rest warning) "Generate a warning on the console and write the warning into the currently generated XHTML output as a comment." `(progn - (html (:princ-safe (format nil "~%" (format nil ,@warning)))) - (warn ,@warning))) + (html (:princ-safe (format nil "~%" (format nil ,@warning)))) + (warn ,@warning))) (defmacro cmslink (url &body body) `(html ((:a :class "cmslink" :href (website-make-path *website* ,url)) - ,@body))) + ,@body))) (defvar *xml-sink*) @@ -96,7 +98,7 @@ `(with-http-response (:content-type ,content-type) (with-query-params (download) (when download - (setf (hunchentoot:header-out :content-disposition) + (setf (hunchentoot:header-out :content-disposition) (format nil "attachment; filename=~A" download)))) (with-output-to-string (s) (let ((*xml-sink* (cxml:make-character-stream-sink s :canonical nil))) Modified: trunk/bknr/web/src/web/web-utils.lisp =================================================================== --- trunk/bknr/web/src/web/web-utils.lisp 2008-08-01 10:14:42 UTC (rev 3718) +++ trunk/bknr/web/src/web/web-utils.lisp 2008-08-01 12:08:44 UTC (rev 3719) @@ -18,7 +18,7 @@ (defun redirect-uri (uri) (make-instance 'uri :path (uri-path uri) - :query (uri-query uri))) + :query (uri-query uri))) (defun request-uploaded-files () "Return a list of UPLOAD structures describing the file uploads in the request." @@ -27,7 +27,8 @@ (let ((uploads (remove-if-not #'listp (post-parameters*) :key #'cdr)) retval) (dolist (upload-info uploads) (destructuring-bind (name pathname original-filename content-type) upload-info - (push (make-upload :name name :pathname pathname :original-filename original-filename :content-type content-type) retval))) + (push (make-upload :name name :pathname pathname :original-filename original-filename + :content-type content-type) retval))) (nreverse retval)))) (aux-request-value 'uploaded-files)) @@ -36,12 +37,13 @@ (defmacro with-image-from-upload ((image upload &rest args) &body body) `(with-image-from-file (,image (upload-pathname ,upload) - (make-keyword-from-string (pathname-type (upload-original-filename ,upload))) ,@args) - ,@body)) + (make-keyword-from-string (pathname-type (upload-original-filename ,upload))) + ,@args) + ,@body)) (defmacro with-image-from-upload* ((upload &rest args) &body body) `(with-image-from-upload (cl-gd:*default-image* ,upload ,@args) - ,@body)) + ,@body)) (defmethod bknr.images:import-image ((upload upload) &rest args &key &allow-other-keys) (apply #'bknr.images:import-image (upload-pathname upload) @@ -56,12 +58,12 @@ macro after the request body has been executed." (unless (aux-request-value 'bknr-parsed-parameters) (setf (aux-request-value 'bknr-parsed-parameters) - (remove-if (lambda (value) - "Remove empty strings (reported as NIL) and uploaded files" - (or (equal value "") - (listp value))) - (query-params) - :key #'cdr))) + (remove-if (lambda (value) + "Remove empty strings (reported as NIL) and uploaded files" + (or (equal value "") + (listp value))) + (query-params) + :key #'cdr))) (aux-request-value 'bknr-parsed-parameters)) (defun query-params (&key (get t) (post t)) @@ -85,8 +87,8 @@ (defun request-variables () (loop for key being the hash-keys of *req-var-hash* - collect key - collect (request-variable key))) + collect key + collect (request-variable key))) (defun http-error (response message) (with-bknr-page (:title #?"error: $(message)" :response response) @@ -95,19 +97,19 @@ (defun keywords-from-query-param-list (param &key (remove-empty t)) (let ((keywords (mapcar #'(lambda (s) - (make-keyword-from-string (string-trim '(#\Space #\Tab #\Newline) s))) - param))) + (make-keyword-from-string (string-trim '(#\Space #\Tab #\Newline) s))) + param))) (if remove-empty - (remove-if #'(lambda (x) (eq x :||)) keywords) - keywords))) + (remove-if #'(lambda (x) (eq x :||)) keywords) + keywords))) (defun html-quote (string) (regex-replace-all "([&<>])" string #'(lambda (target-string start end match-start &rest args) - (declare (ignore start end args)) - (ecase (elt target-string match-start) - (#\& "&") - (#\< "<") - (#\> ">"))))) + (declare (ignore start end args)) + (ecase (elt target-string match-start) + (#\& "&") + (#\< "<") + (#\> ">"))))) (defun parse-url () (values-list (cddr (mapcar #'url-decode (split "/" (script-name*)))))) @@ -119,16 +121,16 @@ (defun parse-date-field (name) (let ((timespec (mapcar #'(lambda (var) (parse-integer - (query-param (concatenate 'string name "-" var)) - :junk-allowed t)) - '("minute" "hour" "day" "month" "year")))) + (query-param (concatenate 'string name "-" var)) + :junk-allowed t)) + '("minute" "hour" "day" "month" "year")))) (unless (car timespec) (rplaca timespec 0)) (unless (cadr timespec) (rplaca (cdr timespec) 0)) (if (every #'identity timespec) - (apply #'encode-universal-time 0 timespec) - nil))) + (apply #'encode-universal-time 0 timespec) + nil))) (defun bknr-url-path (handler) "Returns the Path of the request under the handler prefix" @@ -137,7 +139,7 @@ (defun self-url (&key command prefix) (destructuring-bind - (empty old-prefix object-id &rest old-command) + (empty old-prefix object-id &rest old-command) (split "/" (script-name*)) (declare (ignore empty)) #?"/$((or prefix old-prefix))/$(object-id)/$((or command old-command))")) @@ -149,53 +151,53 @@ "Perform simple text to HTML conversion. http urls are replaced by links, internal links to images become image tags." (setf string (regex-replace-all - #?r"bknr:([0-9A-Za-z$-_.+!*'()]+)" string - #'(lambda (target-string start end match-start match-end reg-starts reg-ends) - (declare (ignore start end match-start match-end)) - (let ((url (subseq target-string (aref reg-starts 0) (aref reg-ends 0)))) - (regex-replace-all "URL" (if (all-matches "^/image" url) - "<img src=\"URL\" />" - "<a href=\"URL\">URL</a>") - url))))) + #?r"bknr:([0-9A-Za-z$-_.+!*'()]+)" string + #'(lambda (target-string start end match-start match-end reg-starts reg-ends) + (declare (ignore start end match-start match-end)) + (let ((url (subseq target-string (aref reg-starts 0) (aref reg-ends 0)))) + (regex-replace-all "URL" (if (all-matches "^/image" url) + "<img src=\"URL\" />" + "<a href=\"URL\">URL</a>") + url))))) (setf string (regex-replace-all - #?r"(http://[0-9A-Za-z$-_.+!*'()]+)" string - #'(lambda (target-string start end match-start match-end &rest args) - (declare (ignore start end args)) - (let ((url (subseq target-string match-start match-end))) - (regex-replace-all "URL" (if (all-matches "(?i)\\.(gif|jpe?g|png)$" url) - "<img src=\"URL\" />" - "<a href=\"URL\" target=\"_blank\">URL</a>") - url))))) + #?r"(http://[0-9A-Za-z$-_.+!*'()]+)" string + #'(lambda (target-string start end match-start match-end &rest args) + (declare (ignore start end args)) + (let ((url (subseq target-string match-start match-end))) + (regex-replace-all "URL" (if (all-matches "(?i)\\.(gif|jpe?g|png)$" url) + "<img src=\"URL\" />" + "<a href=\"URL\" target=\"_blank\">URL</a>") + url))))) (setf string (regex-replace-all "[\\r\\n]" string "<br>")) string) (defun make-wiki-hrefs (string) (regex-replace-all #?r"\[(.+?)\]" string - #'(lambda (target-string start end match-start match-end - reg-starts reg-ends) - (declare (ignore start end match-start match-end)) - (let ((keyword (subseq target-string - (svref reg-starts 0) - (svref reg-ends 0)))) - (format nil "<a class=\"wikilink\" href=\"/wiki/~a\">~a</a>" - keyword - keyword))))) + #'(lambda (target-string start end match-start match-end + reg-starts reg-ends) + (declare (ignore start end match-start match-end)) + (let ((keyword (subseq target-string + (svref reg-starts 0) + (svref reg-ends 0)))) + (format nil "<a class=\"wikilink\" href=\"/wiki/~a\">~a</a>" + keyword + keyword))))) (defmacro bknr-handler-case (body &rest handler-forms) `(if *bknr-debug* - ,body - (handler-case - ,body - ,@handler-forms))) + ,body + (handler-case + ,body + ,@handler-forms))) (defun emit-element-attributes (attributes) (loop for (key value) on attributes by #'cddr - do (progn - (princ " ") - (princ (string-downcase (symbol-name key))) - (princ "=\"") - (princ value) - (princ "\"")))) + do (progn + (princ " ") + (princ (string-downcase (symbol-name key))) + (princ "=\"") + (princ value) + (princ "\"")))) (defun emit-html (&rest forms) (let ((element (car forms))) @@ -205,7 +207,7 @@ ;; (:foo ...) or ((:foo ...) ...) (cons (if (consp (car element)) (handle-tag (caar element) (cdar element) (cdr element)) ; ((:foo ...) ...) - (handle-tag (car element) nil (cdr element)))) ; (:foo ...) + (handle-tag (car element) nil (cdr element)))) ; (:foo ...) ;; "foo" (string (princ element)))) (when (cdr forms) @@ -221,15 +223,15 @@ (when attributes (emit-element-attributes attributes)) (if body - ;; emit tag body - (progn - (princ ">") - (apply #'emit-html body) - (princ "</") - (princ tag-name) - (princ ">")) - ;; empty body, close tag immediately - (princ " />")))) + ;; emit tag body + (progn + (princ ">") + (apply #'emit-html body) + (princ "</") + (princ tag-name) + (princ ">")) + ;; empty body, close tag immediately + (princ " />")))) (defun encode-urlencoded (string) -(regex-replace-all #?r"\+" (url-encode string) "%20")) + (regex-replace-all #?r"\+" (url-encode string) "%20"))

1 0

[bknr-cvs] edi changed tags/thirdparty/flexi-streams-1.0.5/
by BKNR Commits 01 Aug '08

01 Aug '08

Revision: 3718 Author: edi URL: http://bknr.net/trac/changeset/3718 Tag version 1.0.5 of flexi-streams A tags/thirdparty/flexi-streams-1.0.5/ Copied: tags/thirdparty/flexi-streams-1.0.5 (from rev 3717, trunk/thirdparty/flexi-streams)

1 0

[bknr-cvs] edi changed trunk/thirdparty/flexi-streams/
by BKNR Commits 01 Aug '08

01 Aug '08

Revision: 3717 Author: edi URL: http://bknr.net/trac/changeset/3717 Update to 1.0.5 U trunk/thirdparty/flexi-streams/CHANGELOG U trunk/thirdparty/flexi-streams/doc/index.html U trunk/thirdparty/flexi-streams/flexi-streams.asd U trunk/thirdparty/flexi-streams/test/packages.lisp Modified: trunk/thirdparty/flexi-streams/CHANGELOG =================================================================== --- trunk/thirdparty/flexi-streams/CHANGELOG 2008-08-01 06:57:30 UTC (rev 3716) +++ trunk/thirdparty/flexi-streams/CHANGELOG 2008-08-01 10:14:17 UTC (rev 3717) @@ -1,3 +1,7 @@ +Version 1.0.5 +2008-08-01 +Export RUN-ALL-TESTS instead of RUN-TESTS (caught by Nick Allen) + Version 1.0.4 2008-07-25 Cosmetic surgery on test suite Modified: trunk/thirdparty/flexi-streams/doc/index.html =================================================================== --- trunk/thirdparty/flexi-streams/doc/index.html 2008-08-01 06:57:30 UTC (rev 3716) +++ trunk/thirdparty/flexi-streams/doc/index.html 2008-08-01 10:14:17 UTC (rev 3717) @@ -229,7 +229,7 @@ <p> FLEXI-STREAMS together with this documentation can be downloaded from <a href="http://weitz.de/files/flexi-streams.tar.gz">http://weitz.de/files/flexi-streams.tar.gz</a>. The -current version is 1.0.4. +current version is 1.0.5. <p> Before you install FLEXI-STREAMS you first need to install the <a @@ -1114,7 +1114,7 @@ his work on making FLEXI-STREAMS faster. <p> -$Header: /usr/local/cvsrep/flexi-streams/doc/index.html,v 1.123 2008/07/25 09:57:00 edi Exp $ +$Header: /usr/local/cvsrep/flexi-streams/doc/index.html,v 1.124 2008/08/01 10:12:41 edi Exp $ <p><a href="http://weitz.de/index.html">BACK TO MY HOMEPAGE</a> </body> Modified: trunk/thirdparty/flexi-streams/flexi-streams.asd =================================================================== --- trunk/thirdparty/flexi-streams/flexi-streams.asd 2008-08-01 06:57:30 UTC (rev 3716) +++ trunk/thirdparty/flexi-streams/flexi-streams.asd 2008-08-01 10:14:17 UTC (rev 3717) @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/flexi-streams/flexi-streams.asd,v 1.76 2008/07/25 09:56:58 edi Exp $ +;;; $Header: /usr/local/cvsrep/flexi-streams/flexi-streams.asd,v 1.77 2008/08/01 10:12:40 edi Exp $ ;;; Copyright (c) 2005-2008, Dr. Edmund Weitz. All rights reserved. @@ -35,7 +35,7 @@ (in-package :flexi-streams-system) (defsystem :flexi-streams - :version "1.0.4" + :version "1.0.5" :serial t :components ((:file "packages") (:file "mapping") Modified: trunk/thirdparty/flexi-streams/test/packages.lisp =================================================================== --- trunk/thirdparty/flexi-streams/test/packages.lisp 2008-08-01 06:57:30 UTC (rev 3716) +++ trunk/thirdparty/flexi-streams/test/packages.lisp 2008-08-01 10:14:17 UTC (rev 3717) @@ -1,5 +1,5 @@ ;;; -*- Mode: LISP; Syntax: COMMON-LISP; Package: CL-USER; Base: 10 -*- -;;; $Header: /usr/local/cvsrep/flexi-streams/test/packages.lisp,v 1.6 2008/05/17 16:38:26 edi Exp $ +;;; $Header: /usr/local/cvsrep/flexi-streams/test/packages.lisp,v 1.8 2008/08/01 10:12:43 edi Exp $ ;;; Copyright (c) 2006-2008, Dr. Edmund Weitz. All rights reserved. @@ -36,4 +36,4 @@ :with-rebinding :char* :normalize-external-format) - (:export :run-tests)) + (:export :run-all-tests))

1 0

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

01 Aug '08

Revision: 3716 Author: hans URL: http://bknr.net/trac/changeset/3716 more news work. make owned-object have only one instead of multiple owners. U trunk/bknr/modules/album/album.lisp U trunk/bknr/web/src/images/image.lisp U trunk/bknr/web/src/packages.lisp U trunk/bknr/web/src/rss/rss.lisp U trunk/bknr/web/src/sysclasses/user.lisp U trunk/projects/quickhoney/src/handlers.lisp U trunk/projects/quickhoney/src/quickhoney.asd U trunk/projects/quickhoney/website/static/javascript.js Modified: trunk/bknr/modules/album/album.lisp =================================================================== --- trunk/bknr/modules/album/album.lisp 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/bknr/modules/album/album.lisp 2008-08-01 06:57:30 UTC (rev 3716) @@ -6,7 +6,7 @@ (let* ((user (find-user username)) (images (when user (remove-if-not #'(lambda (image) - (member user (owned-object-owners image))) + (eq user (owned-object-owner image))) (get-keyword-store-images (make-keyword-from-string album)))))) (html (:ul (dolist (image images) Modified: trunk/bknr/web/src/images/image.lisp =================================================================== --- trunk/bknr/web/src/images/image.lisp 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/bknr/web/src/images/image.lisp 2008-08-01 06:57:30 UTC (rev 3716) @@ -123,7 +123,7 @@ ;; xxx not tx safe. (let ((store-image (apply #'make-object class-name - :owners (list user) + :owner user :timestamp (get-universal-time) :name name :type (make-keyword-from-string type) Modified: trunk/bknr/web/src/packages.lisp =================================================================== --- trunk/bknr/web/src/packages.lisp 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/bknr/web/src/packages.lisp 2008-08-01 06:57:30 UTC (rev 3716) @@ -136,7 +136,7 @@ #:set-user-last-login #:owned-object - #:owned-object-owners + #:owned-object-owner #:store-objects-owned-by #:store-object-owners Modified: trunk/bknr/web/src/rss/rss.lisp =================================================================== --- trunk/bknr/web/src/rss/rss.lisp 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/bknr/web/src/rss/rss.lisp 2008-08-01 06:57:30 UTC (rev 3716) @@ -179,7 +179,7 @@ (:documentation "Add ITEM to CHANNEL. May only be called within transaction context.") (:method ((channel rss-channel) item) - (setf (slot-value channel 'items) (cons item (rss-channel-items channel)))) + (push item (slot-value channel 'items))) (:method ((channel string) item) (aif (find-rss-channel channel) (add-item it item) Modified: trunk/bknr/web/src/sysclasses/user.lisp =================================================================== --- trunk/bknr/web/src/sysclasses/user.lisp 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/bknr/web/src/sysclasses/user.lisp 2008-08-01 06:57:30 UTC (rev 3716) @@ -190,24 +190,23 @@ ;;; owned objects (define-persistent-class owned-object (store-object) - ((owners :update :initform nil - :index-type hash-list-index - :index-reader store-object-owners))) + ((owner :update :initform nil + :index-type hash-index + :index-reader store-object-owner))) -(deftransaction owned-object-remove-owner (object owner) - (setf (owned-object-owners object) - (remove owner (owned-object-owners object)))) +(defmethod convert-slot-value-while-restoring ((object owned-object) (slot-name (eql 'owners)) owners) + (when owners + (unless (= 1 (length owners)) + (warn "object ~A has more than one owner ~S, using first" object owners)) + (setf (slot-value object 'owner) (car owners)))) -(deftransaction owned-object-add-owner (object owner) - (pushnew owner (owned-object-owners object))) - (defgeneric user-owns-object-p (user object)) -(defmethod user-owns-object-p ((user user) object) +(defmethod user-owns-object-p ((user user) (object t)) nil) (defmethod user-owns-object-p ((user user) (object owned-object)) - (member user (owned-object-owners object))) + (eq user (owned-object-owner object))) (define-persistent-class message-event (event) ((from :read :initform nil) Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-08-01 06:57:30 UTC (rev 3716) @@ -136,7 +136,7 @@ (cl-smtp:with-smtp-mail (smtp "localhost" "webserver(a)quickhoney.com" (remove-duplicates (mapcar #'user-email - (or (owned-object-owners image) + (or (owned-object-owner image) (list (find-user "n") (find-user "p")))))) (cl-mime:print-mime smtp @@ -438,13 +438,18 @@ (:method ((item t)) ; do nothing ) + (:method :before ((image quickhoney-image)) + (when (owned-object-owner image) + (encode-object-element "owner" (user-login (owned-object-owner image)))) + (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 "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))))) + (encode-object-element "subcategory" "unknown"))) + (:method ((item quickhoney-news-item)) + (encode-object-element "title" (quickhoney-news-item-title item)) + (encode-object-element "text" (quickhoney-news-item-text item)))) (defmethod handle-object ((handler json-news-handler) (channel rss-channel)) (with-json-response () Modified: trunk/projects/quickhoney/src/quickhoney.asd =================================================================== --- trunk/projects/quickhoney/src/quickhoney.asd 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/projects/quickhoney/src/quickhoney.asd 2008-08-01 06:57:30 UTC (rev 3716) @@ -33,7 +33,7 @@ (:file "layout" :depends-on ("config")) (:file "imageproc" :depends-on ("config")) (:file "json" :depends-on ("packages")) - (:file "handlers" :depends-on ("json" "layout" "config" "image")) + (:file "handlers" :depends-on ("json" "layout" "config" "image" "news")) (:file "tags" :depends-on ("image")) (:file "webserver" :depends-on ("handlers")) (:file "daily" :depends-on ("config")) Modified: trunk/projects/quickhoney/website/static/javascript.js =================================================================== --- trunk/projects/quickhoney/website/static/javascript.js 2008-08-01 06:19:07 UTC (rev 3715) +++ trunk/projects/quickhoney/website/static/javascript.js 2008-08-01 06:57:30 UTC (rev 3716) @@ -246,7 +246,7 @@ IMG({ src: "/image/" + item.name + '/cutout-button,,' + color + ',98,4'}), DIV(null, H1(null, item.name), - item.date, ' by ', item.uploader, ' | ', + item.date, ' by ', item.owner, ' | ', A({ href: '/index#' + item.category + '/' + item.subcategory + '/' + item.image_name }, 'permalink'), BR(), item.description)), @@ -461,7 +461,7 @@ function() { footer_hide(); loadJSONDoc('/json-news-archive/quickhoney').addCallbacks(load_news_archive, alert); - // load_news(); + loadJSONDoc('/json-news/quickhoney').addCallbacks(load_news, alert); }); pages['shop']

1 0

[bknr-cvs] hans changed trunk/thirdparty/hunchentoot/packages.lisp
by BKNR Commits 01 Aug '08

01 Aug '08

Revision: 3715 Author: hans URL: http://bknr.net/trac/changeset/3715 Don't export *CATCH-ERRORS-P* anymore. U trunk/thirdparty/hunchentoot/packages.lisp Modified: trunk/thirdparty/hunchentoot/packages.lisp =================================================================== --- trunk/thirdparty/hunchentoot/packages.lisp 2008-08-01 04:41:26 UTC (rev 3714) +++ trunk/thirdparty/hunchentoot/packages.lisp 2008-08-01 06:19:07 UTC (rev 3715) @@ -39,7 +39,6 @@ #+:lispworks (:import-from :lw "WITH-UNIQUE-NAMES" "WHEN-LET") (:export "*APPROVED-RETURN-CODES*" - "*CATCH-ERRORS-P*" #+:lispworks "*CLEANUP-FUNCTION*" #+:lispworks

1 0