September 2008 - bknr-cvs@common-lisp.net

[bknr-cvs] hans changed trunk/bknr/web/src/web/template-handler.lisp
by BKNR Commits 01 Sep '08

01 Sep '08

Revision: 3764 Author: hans URL: http://bknr.net/trac/changeset/3764 Another attempt to fix the template handler. Not yet done, will work on it later. U trunk/bknr/web/src/web/template-handler.lisp Modified: trunk/bknr/web/src/web/template-handler.lisp =================================================================== --- trunk/bknr/web/src/web/template-handler.lisp 2008-09-01 16:08:50 UTC (rev 3763) +++ trunk/bknr/web/src/web/template-handler.lisp 2008-09-01 16:17:30 UTC (rev 3764) @@ -148,13 +148,15 @@ (nsuri-alias-map (make-hash-table :test #'equal))) (setf (gethash "http://www.w3.org/XML/1998/namespace" nsuri-alias-map) "xml") (dolist (attribute (cxml-xmls:node-attrs dom)) - (destructuring-bind ((alias . namespace-url) value) attribute - (cond - ((equal namespace-url "http://www.w3.org/2000/xmlns/") - (setf (gethash value nsuri-alias-map) alias) - (push attribute namespace-declarations)) - (t - (push attribute real-attributes))))) + (if (consp (car attribute)) + (destructuring-bind ((alias . namespace-url) value) attribute + (cond + ((equal namespace-url "http://www.w3.org/2000/xmlns/") + (setf (gethash value nsuri-alias-map) alias) + (push attribute namespace-declarations)) + (t + (push attribute real-attributes)))) + (push attribute real-attributes))) (setf (cxml-xmls:node-attrs dom) real-attributes) (make-parsed-template :namespace-attrs (cxml-xmls::compute-attributes/lnames (cxml-xmls:make-node :attrs namespace-declarations) t)

1 0

[bknr-cvs] hans changed trunk/bknr/web/src/web/template-handler.lisp
by BKNR Commits 01 Sep '08

01 Sep '08

Revision: 3763 Author: hans URL: http://bknr.net/trac/changeset/3763 Always declare xml namespace. U trunk/bknr/web/src/web/template-handler.lisp Modified: trunk/bknr/web/src/web/template-handler.lisp =================================================================== --- trunk/bknr/web/src/web/template-handler.lisp 2008-09-01 16:02:12 UTC (rev 3762) +++ trunk/bknr/web/src/web/template-handler.lisp 2008-09-01 16:08:50 UTC (rev 3763) @@ -144,8 +144,9 @@ (cxml-xmls:make-xmls-builder) :validate nil)) real-attributes - namespace-declarations + (namespace-declarations (list '(("xml" . "http://www.w3.org/2000/xmlns/") "http://www.w3.org/XML/1998/namespace"))) (nsuri-alias-map (make-hash-table :test #'equal))) + (setf (gethash "http://www.w3.org/XML/1998/namespace" nsuri-alias-map) "xml") (dolist (attribute (cxml-xmls:node-attrs dom)) (destructuring-bind ((alias . namespace-url) value) attribute (cond

1 0

[bknr-cvs] hans changed trunk/bknr/web/src/web/template-handler.lisp
by BKNR Commits 01 Sep '08

01 Sep '08

Revision: 3762 Author: hans URL: http://bknr.net/trac/changeset/3762 Fix namespace declaration attribute output. U trunk/bknr/web/src/web/template-handler.lisp Modified: trunk/bknr/web/src/web/template-handler.lisp =================================================================== --- trunk/bknr/web/src/web/template-handler.lisp 2008-09-01 16:01:56 UTC (rev 3761) +++ trunk/bknr/web/src/web/template-handler.lisp 2008-09-01 16:02:12 UTC (rev 3762) @@ -128,11 +128,38 @@ :specified-p t)))) attrs)) +(defstruct parsed-template + namespace-attrs + dom + last-change + nsuri-alias-map) + (defun parse-template (template-pathname) - (let ((sax:*include-xmlns-attributes* t)) - (cxml:parse-file (namestring (probe-file template-pathname)) - (cxml-xmls:make-xmls-builder) - :validate nil))) + "Parse the XML template in the file TEMPLATE-PATHNAME, return a PARSED-TEMPLATE structure." + ;; In order to generate xmlns attributes, we use the internal + ;; CXML-XMLS::COMPUTE-ATTRIBUTES/LNAMES function. This may need to + ;; be revised with newer cxml releases. + (let* ((sax:*include-xmlns-attributes* t) + (dom (cxml:parse-file (namestring (probe-file template-pathname)) + (cxml-xmls:make-xmls-builder) + :validate nil)) + real-attributes + namespace-declarations + (nsuri-alias-map (make-hash-table :test #'equal))) + (dolist (attribute (cxml-xmls:node-attrs dom)) + (destructuring-bind ((alias . namespace-url) value) attribute + (cond + ((equal namespace-url "http://www.w3.org/2000/xmlns/") + (setf (gethash value nsuri-alias-map) alias) + (push attribute namespace-declarations)) + (t + (push attribute real-attributes))))) + (setf (cxml-xmls:node-attrs dom) real-attributes) + (make-parsed-template + :namespace-attrs (cxml-xmls::compute-attributes/lnames (cxml-xmls:make-node :attrs namespace-declarations) t) + :dom dom + :last-change (file-write-date template-pathname) + :nsuri-alias-map nsuri-alias-map))) (defvar *tag-children*) @@ -140,6 +167,9 @@ "Function to be called by application defined tags to emit their children." (mapc (curry #'emit-template-node *template-expander*) *tag-children*)) +(defvar *namespace-attributes* nil + "Bound to the list of namespace attributes to emit on the top level node.") + (defun emit-template-node (expander node) (if (stringp node) (sax:characters *html-sink* (expand-variables node #'get-template-var)) @@ -159,29 +189,19 @@ and collect (expand-variables name #'get-template-var)))))) (t (sax:start-element *html-sink* nil nil name - (xmls-attributes-to-sax (rcurry #'expand-variables #'get-template-var) attrs)) + (append (when *namespace-attributes* + (prog1 + *namespace-attributes* + (setf *namespace-attributes* nil))) + (xmls-attributes-to-sax (rcurry #'expand-variables #'get-template-var) attrs))) (dolist (child children) (emit-template-node expander child)) (sax:end-element *html-sink* nil nil name)))))) -(defun emit-parsed-template (expander toplevel) - "Emit the given XMLS compatible structure as XML to *HTML-SINK*." - ;; In order to generate xmlns attributes, we use the internal - ;; CXML-XMLS::COMPUTE-ATTRIBUTES/LNAMES function. This may need to - ;; be revised with newer cxml releases. - (let* ((toplevel-attributes (cxml-xmls::compute-attributes/lnames toplevel t)) - (*template-expander* expander) - (*nsuri-alias-map* (let ((map (make-hash-table :test #'equal))) - (dolist (attribute toplevel-attributes) - (when (scan "^xmlns($|:)" (sax:attribute-qname attribute)) - (setf (gethash (sax:attribute-value attribute) map) - (sax:attribute-local-name attribute)))) - map))) - (sax:start-element *html-sink* (node-ns toplevel) (node-name toplevel) (node-name toplevel) - toplevel-attributes) - (dolist (node (node-children toplevel)) - (emit-template-node expander node)) - (sax:end-element *html-sink* (node-ns toplevel) (node-name toplevel) (node-name toplevel)))) +(defun emit-parsed-template (expander parsed-template) + "Emit the given parsed template as XHML to *HTML-SINK*." + (let* ((*template-expander* expander)) + (emit-template-node expander (parsed-template-dom parsed-template)))) (defun find-template (dir components) (if (null components) @@ -221,28 +241,28 @@ (defun get-cached-template (pathname expander) (let* ((table (template-expander-cached-templates expander)) (namestring (namestring pathname)) - (cache-entry (gethash namestring table)) + (parsed-template (gethash namestring table)) (current-write-date (file-write-date namestring))) - (unless (and cache-entry (eql (car cache-entry) current-write-date)) - (setf cache-entry - (cons current-write-date (parse-template pathname))) - (setf (gethash namestring table) cache-entry)) - (cdr cache-entry))) + (unless (and parsed-template + (eql current-write-date (parsed-template-last-change parsed-template))) + (setf parsed-template (parse-template pathname) + (gethash namestring table) parsed-template)) + parsed-template)) -(defun emit-template (expander stream node env) +(defun emit-template (expander stream parsed-template env) (let* ((*template-env* env) (*html-sink* (cxml:make-character-stream-sink stream :canonical nil))) - (if (node-attribute node "suppress-xml-headers") - (emit-parsed-template expander node) - (progn - (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*) - (emit-parsed-template expander node))) + (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*) + (let ((*namespace-attributes* (parsed-template-namespace-attrs parsed-template)) + (*nsuri-alias-map* (parsed-template-nsuri-alias-map parsed-template))) + (emit-parsed-template expander parsed-template)) + ;; We call sax:end-document to close the sink, which works even though we did not call sax:start-document. (sax:end-document *html-sink*))) + ;; template handler (defclass template-handler (prefix-handler template-expander)

1 0

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

01 Sep '08

Revision: 3761 Author: ksprotte URL: http://bknr.net/trac/changeset/3761 basic POI edit functionality in place U trunk/projects/bos/payment-website/static/cms.js U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/payment-website/static/cms.js =================================================================== --- trunk/projects/bos/payment-website/static/cms.js 2008-09-01 13:39:00 UTC (rev 3760) +++ trunk/projects/bos/payment-website/static/cms.js 2008-09-01 16:01:56 UTC (rev 3761) @@ -85,3 +85,22 @@ return confirm(confirm_string); } +function upload_new_medium_input_toggle(medium_type) +{ + var upload_new_medium_form = $("upload_new_medium_form"); + var upload_new_medium_input = $("upload_new_medium_input"); + var upload_new_medium_input_label = $("upload_new_medium_input_label"); + if (medium_type == "poi-movie") { + upload_new_medium_input.setAttribute("type", "text"); + upload_new_medium_input.setAttribute("name", "url"); + upload_new_medium_form.setAttribute("onsubmit", "return parse_youtube_link($(\"upload_new_medium_input\"));"); + upload_new_medium_input_label.innerHTML = "URL"; + } else { + upload_new_medium_input.setAttribute("type", "file"); + upload_new_medium_input.setAttribute("name", "image-file"); + upload_new_medium_input.setAttribute("onchange", "return true;"); + upload_new_medium_form.setAttribute("onsubmit", "return true;"); + upload_new_medium_input_label.innerHTML = "File"; + } +} + Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-09-01 13:39:00 UTC (rev 3760) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-01 16:01:56 UTC (rev 3761) @@ -134,17 +134,21 @@ (: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") + ((:form :id "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"))) + (:td ((:select :name "new-medium-type" :size "1" + :onchange "upload_new_medium_input_toggle(this.value);") + ((:option :value "poi-image" :selected "selected") "poi-image") + ((:option :value "poi-airal") "poi-airal") + ((:option :value "poi-panorama") "poi-panorama") + ((:option :value "poi-movie") "poi-movie")))) (:tr - (:td "File") - (:td ((:input :type "file" :name "image-file"))) - (:tr ((:td :colspan "2") (submit-button "upload" "upload")))))) + ((:td :id "upload_new_medium_input_label") "File") + (:td ((:input :id "upload_new_medium_input" :type "file" :size "60" :name "image-file")))) + (:tr ((:td :colspan "2") (submit-button "upload" "upload"))))) (:h2 "Attached POI media") ((:table :border "1") (dolist (medium (poi-media poi)) @@ -231,10 +235,13 @@ (:method ((medium t) &key small) (declare (ignore small)) (html ((:tr :colspan "2") "No preview"))) - (:method ((medium poi-image) &key small) + (:method ((medium store-image) &key small) + "The default method for store-images." (html (:tr (:td "thumbnail") - (:td ((:img :src (format nil "/image/~A/thumbnail,,55,55" (store-object-id medium)))))) + (:td ((:a :href (format nil "/image/~A" (store-object-id medium)) + :target "_blank") + ((:img :src (format nil "/image/~A/thumbnail,,55,55" (store-object-id medium))))))) (unless small (html (:tr (:td "full image") @@ -243,8 +250,32 @@ (declare (ignore small)) (html (:tr (:td "thumbnail") - (:td ((:img :src (format nil "/image/~A/thumbnail,,500,100" (store-object-id medium))))))))) + (:td ((:a :href (format nil "/image/~A" (store-object-id medium)) + :target "_blank") + ((:img :src (format nil "/image/~A/thumbnail,,500,100" (store-object-id medium))))))))) + (:method ((medium poi-movie) &key small) + (if small + (call-next-method) + (html + (:tr (:td "movie") + (:td ((:embed :src (poi-movie-url medium) + :type "application/x-shockwave-flash" + :allowFullScreen "true" + :width "425" :height "344")))))))) +(defgeneric medium-handler-validate-image-size (medium-or-type width height) + (:method (medium-or-type width height) + (declare (ignore medium-or-type width height)) + t) + (:method ((medium standard-object) width height) + (medium-handler-validate-image-size (type-of medium) width height)) + (:method ((type (eql 'poi-image)) width height) + (and (= width *poi-image-width*) + (= height *poi-image-height*))) + (:method ((type (eql 'poi-airal)) width height) + (and (= width *poi-image-width*) + (= height *poi-image-height*)))) + (defmethod handle-object-form ((handler edit-poi-medium-handler) (action (eql :save)) (medium poi-medium)) (with-query-params (title subtitle description language poi) (unless language (setq language (request-language))) @@ -268,25 +299,32 @@ "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 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*)) - (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 (if medium - (type-of medium) - (intern (string-upcase new-medium-type))) - :initargs `(:poi ,poi)))) + (flet ((make-new-medium (new-medium-type poi) + (case new-medium-type + (poi-movie + (make-object 'poi-movie :poi poi :url (query-param "url"))) + (otherwise + (let ((upload (request-uploaded-file "image-file"))) + (unless upload + (error "no file uploaded in upload handler")) + (bknr.web:with-image-from-upload* (upload) + (unless (medium-handler-validate-image-size new-medium-type + (cl-gd:image-width) (cl-gd: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))) + (import-image upload + :class-name new-medium-type + :initargs `(:poi ,poi)))))))) + (with-query-params ((poi nil integer) + new-medium-type) + (setq poi (find-store-object poi :class 'poi)) + (let* ((new-medium-type (if medium + (type-of medium) + (intern (string-upcase new-medium-type)))) + (new-medium (make-new-medium new-medium-type poi))) (when medium (very-shallow-copy-textual-attributes medium new-medium) (delete-object medium))

1 0

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

01 Sep '08

Revision: 3760 Author: ksprotte URL: http://bknr.net/trac/changeset/3760 removed POI handlers that are not needed anymore U trunk/projects/bos/web/poi-handlers.lisp U trunk/projects/bos/web/webserver.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-09-01 13:11:09 UTC (rev 3759) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-01 13:39:00 UTC (rev 3760) @@ -177,88 +177,6 @@ "continue editing the POI") ".")))) (defmethod handle-object-form ((handler edit-poi-handler) - (action (eql :upload-airal)) - (poi poi)) - (let ((uploaded-file (request-uploaded-file "image-file"))) - (unless uploaded-file - (error "no file uploaded in upload handler")) - (with-image-from-upload* (uploaded-file) - (cond - ((and (eql (cl-gd:image-width) *poi-image-width*) - (eql (cl-gd:image-height) *poi-image-height*)) - (with-transaction ("set airals") - (push (import-image uploaded-file :class-name 'store-image) (poi-airals poi))) - (redirect (format nil "/edit-poi/~D" - (store-object-id poi)))) - (t - (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")))))))) - -(defmethod handle-object-form ((handler edit-poi-handler) - (action (eql :delete-airal)) - (poi poi)) - (with-query-params (airal-id) - (let ((airal (find-store-object (parse-integer airal-id)))) - (with-transaction ("delete poi-airal") - (alexandria:deletef (poi-airals poi) airal)) - (delete-object airal))) - (redirect (format nil "/edit-poi/~D" - (store-object-id poi)))) - - -(defmethod handle-object-form ((handler edit-poi-handler) - (action (eql :add-movie)) - (poi poi)) - (with-query-params (movie-url) - (with-transaction ("add poi movie") - (push (make-object 'poi-movie :poi poi :url movie-url) - (poi-movies poi))) - (redirect (format nil "/edit-poi/~D" (store-object-id poi))))) - - -(defmethod handle-object-form ((handler edit-poi-handler) - (action (eql :delete-movie)) - (poi poi)) - (with-query-params (movie-id) - (let ((movie (find-store-object (parse-integer movie-id)))) - (with-transaction ("delete poi-movie") - (alexandria:deletef (poi-movies poi) movie)) - (delete-object movie))) - (redirect (format nil "/edit-poi/~D" - (store-object-id poi)))) - -(defmethod handle-object-form ((handler edit-poi-handler) - (action (eql :upload-panorama)) - (poi poi)) - (let ((uploaded-file (request-uploaded-file "image-file"))) - (unless uploaded-file - (error "no file uploaded in upload handler")) - ;; just open the image to make sure that gd can process it - (with-image-from-upload* (uploaded-file)) - (with-transaction ("add poi-panorama") - (push (import-image uploaded-file :class-name 'store-image) (poi-panoramas poi)))) - (redirect (format nil "/edit-poi/~D" - (store-object-id poi)))) - -(defmethod handle-object-form ((handler edit-poi-handler) - (action (eql :delete-panorama)) - (poi poi)) - (with-query-params (panorama-id) - (let ((panorama (find-store-object (parse-integer panorama-id)))) - (with-transaction ("delete poi-panorama") - (alexandria:deletef (poi-panoramas poi) panorama)) - (delete-object panorama))) - (redirect (format nil "/edit-poi/~D" - (store-object-id poi)))) - -(defmethod handle-object-form ((handler edit-poi-handler) (action (eql :delete)) (poi poi)) (delete-object poi) (with-bos-cms-page (:title "POI has been deleted") @@ -376,98 +294,6 @@ (store-object-id new-medium) (store-object-id poi))))))) -;;; edit-poi-image-handler -(defclass edit-poi-image-handler (editor-only-handler edit-object-handler) - () - (:default-initargs :object-class 'poi-image)) - -(defmethod handle-object-form ((handler edit-poi-image-handler) action (object (eql nil))) - (with-query-params (poi) - (with-bos-cms-page (:title "Upload new POI image") - (html - (:h2 "Upload new image") - ((:form :method "POST" :enctype "multipart/form-data")) - ((:input :type "hidden" :name "poi" :value poi)) - (:p "Choose a file: " ((:input :type "file" :name "image-file"))) - (:p (submit-button "upload" "upload")))))) - -(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :upload)) poi-image) - (with-query-params (poi) - (setq poi (find-store-object (parse-integer poi) :class 'poi)) - (let ((uploaded-file (request-uploaded-file "image-file"))) - (unless uploaded-file - (error "no file uploaded in upload handler")) - (bknr.web:with-image-from-upload* (uploaded-file) - (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))) - (if poi-image - (blob-from-file poi-image uploaded-file) - (setq poi-image (import-image uploaded-file - :class-name 'poi-image - :initargs `(:poi ,poi)))) - (redirect (format nil "/edit-poi-image/~D?poi=~D" - (store-object-id poi-image) - (store-object-id poi)))))) - -(defmethod handle-object-form ((handler edit-poi-image-handler) action poi-image) - (with-query-params (language poi) - (unless language (setq language (request-language))) - (with-bos-cms-page (:title "Edit POI Image") - (html - (cmslink (edit-object-url (poi-image-poi poi-image)) "Back to POI") - (content-language-chooser) - ((:form :method "post" :enctype "multipart/form-data") - ((:input :type "hidden" :name "poi" :value poi)) - (:table (:tr (:td "thumbnail") - (:td ((:img :src (format nil "/image/~A/thumbnail,,55,55" (store-object-id poi-image)))))) - (:tr (:td "full image") - (: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"))) - (:tr (:td "title") - (:td (text-field "title" - :value (slot-string poi-image 'title language)))) - (:tr (:td "subtitle") - (:td (text-field "subtitle" - :value (slot-string poi-image 'subtitle language)))) - (:tr (:td "description") - (:td (textarea-field "description" - :value (slot-string poi-image 'description language) - :rows 5 - :cols 40))) - (:tr (:td (submit-button "save" "save") - (submit-button "delete" "delete" :confirm "Really delete the image?"))))))))) - -(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :save)) poi-image) - (with-query-params (title subtitle description language) - (unless language (setq language (request-language))) - (update-poi-image poi-image language - :title title - :subtitle subtitle - :description description) - (with-bos-cms-page (:title "POI image has been updated") - (:h2 "The POI image information has been updated") - "You may " (cmslink (edit-object-url poi-image) "continue editing the POI image")))) - -(defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :delete)) poi-image) - (let ((poi (poi-image-poi poi-image))) - (delete-object poi-image) - (with-bos-cms-page (:title "POI image has been deleted") - (: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) ()) @@ -498,44 +324,6 @@ (: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)) - -(defmethod handle-object ((handler poi-image-handler) (poi (eql nil))) - (error "poi not found")) - -(defmethod handle-object ((handler poi-image-handler) poi) - (destructuring-bind (poi-name image-index-string &rest imageproc-arguments) - (multiple-value-list (parse-handler-url handler)) - (declare (ignore poi-name)) - (let ((image-index (1- (parse-integer image-index-string)))) - (if (and (not (minusp image-index)) - (< image-index (length (poi-sat-images poi)))) - (redirect (format nil "/image/~D~@[~{/~a~}~]" - (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))))) - -;;; poi-movie-handler -(defclass poi-movie-handler (admin-only-handler object-handler) - () - (:default-initargs :object-class 'poi-movie)) - -(defmethod handle-object ((handler poi-movie-handler) (poi-movie (eql nil))) - (error "poi-movie not found")) - -(defmethod handle-object ((handler poi-movie-handler) poi-movie) - (with-bos-cms-page (:title "POI movie preview") - (:p (cmslink (edit-object-url (poi-movie-poi poi-movie)) "Back to POI")) - ((:object :width "425" :height "344") - ((: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"))))) - ;;; poi-xml-handler (defun write-poi-xml (poi language) "Writes the poi xml format for one specific language. This is used Modified: trunk/projects/bos/web/webserver.lisp =================================================================== --- trunk/projects/bos/web/webserver.lisp 2008-09-01 13:11:09 UTC (rev 3759) +++ trunk/projects/bos/web/webserver.lisp 2008-09-01 13:39:00 UTC (rev 3760) @@ -156,8 +156,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) + :handler-definitions `(("/edit-poi-medium" edit-poi-medium-handler) ("/edit-poi" edit-poi-handler) ("/edit-sponsor" edit-sponsor-handler) ("/kml-upload" kml-upload-handler) @@ -175,8 +174,6 @@ ("/complete-transfer" complete-transfer-handler) ("/edit-news" edit-news-handler) ("/make-poi" make-poi-handler) - ("/poi-image" poi-image-handler) - ("/poi-movie" poi-movie-handler) ("/poi-xml" poi-xml-handler) ("/poi-kml-all" poi-kml-all-handler) ("/poi-kml" poi-kml-handler)

1 0

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

01 Sep '08

Revision: 3759 Author: ksprotte URL: http://bknr.net/trac/changeset/3759 Improved POI-medium edit 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-09-01 11:22:08 UTC (rev 3758) +++ trunk/projects/bos/m2/packages.lisp 2008-09-01 13:11:09 UTC (rev 3759) @@ -207,6 +207,7 @@ ;; pois #:title #:subtitle #:description ; for slot-string access #:update-textual-attributes + #:very-shallow-copy-textual-attributes #:poi-medium #:poi-medium-poi #:make-poi-medium Modified: trunk/projects/bos/m2/poi.lisp =================================================================== --- trunk/projects/bos/m2/poi.lisp 2008-09-01 11:22:08 UTC (rev 3758) +++ trunk/projects/bos/m2/poi.lisp 2008-09-01 13:11:09 UTC (rev 3759) @@ -32,6 +32,15 @@ (setf (slot-string obj 'description language) description)) obj) +(deftransaction very-shallow-copy-textual-attributes (from to) + "Useful for making the TEXTUAL-ATTRIBUTES of FROM available to TO, +before FROM is deleted. Please note that copying is so shallow that +FROM and TO must not both continue to exist." + (setf (slot-value to 'title) (slot-value from 'title) + (slot-value to 'subtitle) (slot-value from 'subtitle) + (slot-value to 'description) (slot-value from 'description)) + to) + ;;; poi-medium (defpersistent-class poi-medium (textual-attributes-mixin) ((poi :reader poi-medium-poi :initarg :poi))) @@ -157,7 +166,7 @@ ;;; 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) +(deftransaction poi-sat-images-exchange-neighbours (poi index) (check-type index (mod 6)) (multiple-value-bind (images positions) (poi-images poi) @@ -248,4 +257,3 @@ (warn "~s has a url of ~s" movie (poi-movie-url movie)))))) (mapc #'poi-sanity-check (class-instances 'poi)) (values))) - Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-09-01 11:22:08 UTC (rev 3758) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-01 13:11:09 UTC (rev 3759) @@ -130,8 +130,7 @@ ((:img :border "0" :src "/images/pfeil-r.gif")))))))))) (unless (= 6 (length (poi-sat-images poi))) (html - :br - (cmslink (format nil "edit-poi-medium/?poi=~A" (store-object-id poi)) "[new]"))))) + (:p "You may add to these by uploading a new medium of type 'poi-image' below."))))) (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the POI?"))))) (:h2 "Upload new medium") @@ -274,20 +273,22 @@ (defmethod handle-object-form ((handler edit-poi-medium-handler) action (medium poi-medium)) (with-query-params (language poi) + (assert poi nil "POI id should have been given as a GET param") (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"))) + (:table (medium-handler-preview medium) + (:tr ((:td :colspan "2" :height "10"))) + ((:form :method "post" :enctype "multipart/form-data") + ((:input :type "hidden" :name "poi" :value poi)) (:tr (:td "upload new image") (:td ((:input :type "file" :name "image-file")) :br - (submit-button "upload" "upload"))) - (:tr ((:td :colspan "2" :height "10"))) + (submit-button "upload" "upload")))) + (:tr ((:td :colspan "2" :height "10"))) + ((:form :method "post") (:tr (:td "title") (:td (text-field "title" :value (slot-string medium 'title language)))) @@ -327,7 +328,7 @@ (: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) + (with-query-params (title subtitle description language poi) (unless language (setq language (request-language))) (update-textual-attributes medium language :title title @@ -336,7 +337,8 @@ (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) + "You may " (cmslink (format nil "~A?language=~A&poi=~A" + (edit-object-url medium) language poi) (: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)) @@ -368,6 +370,7 @@ (intern (string-upcase new-medium-type))) :initargs `(:poi ,poi)))) (when medium + (very-shallow-copy-textual-attributes medium new-medium) (delete-object medium)) (redirect (format nil "/edit-poi-medium/~D?poi=~D" (store-object-id new-medium)

1 0

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

01 Sep '08

Revision: 3758 Author: ksprotte URL: http://bknr.net/trac/changeset/3758 edit-poi [locate] and [relocate] now works again nicely U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-09-01 11:11:04 UTC (rev 3757) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-01 11:22:08 UTC (rev 3758) @@ -86,21 +86,22 @@ :rows 6 :cols 60))) (:tr (:td "location") - (:td (cond - ((poi-area poi) - (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&~:[~;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&~:[~;published=on~]" - (hunchentoot:request-uri*) - (poi-published poi)))) - "[choose]"))))) + (:td (flet ((format-chosen-url () + (encode-urlencoded + (format nil "~A?action=save&language=~A&~:[~;published=on~]" + (hunchentoot:script-name*) + language + (poi-published poi))))) + (cond + ((poi-area poi) + (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)) (format-chosen-url)) + "[relocate]")) + (t + (cmslink (format nil "map-browser/?chosen-url=~A" + (format-chosen-url)) + "[choose]")))))) (:tr (:td "icon") (:td (icon-chooser "icon" (poi-icon poi)))) (:tr (:td "sat images") @@ -118,7 +119,8 @@ (html ((:img :src "/images/trans.gif" :width "16"))) (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))))) + (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))) @@ -161,7 +163,6 @@ (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))) (update-textual-attributes poi language :title title @@ -298,7 +299,8 @@ :value (slot-string medium 'description language) :rows 5 :cols 40))) - (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete?"))))))))) + (: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") @@ -442,7 +444,8 @@ :value (slot-string poi-image 'description language) :rows 5 :cols 40))) - (:tr (:td (submit-button "save" "save") (submit-button "delete" "delete" :confirm "Really delete the image?"))))))))) + (:tr (:td (submit-button "save" "save") + (submit-button "delete" "delete" :confirm "Really delete the image?"))))))))) (defmethod handle-object-form ((handler edit-poi-image-handler) (action (eql :save)) poi-image) (with-query-params (title subtitle description language) @@ -489,7 +492,8 @@ ((:script :language "JavaScript") (:princ (make-poi-javascript (request-language))) (:princ "parent.poi_fertig(pois, anzahlSponsoren, anzahlVerkauft);") - (:princ (format nil "parent.last_sponsors([~{~A~^,~%~}]);" (mapcar #'contract-js last-paid-contracts))))))))) + (:princ (format nil "parent.last_sponsors([~{~A~^,~%~}]);" + (mapcar #'contract-js last-paid-contracts))))))))) ;;; poi-image-handler (defclass poi-image-handler (object-handler) @@ -641,7 +645,8 @@ (with-element "head") (with-element "body" (with-element "table" - (attribute "cellspacing" "0") (attribute "width" "500") (attribute "cellpadding" "5") (attribute "border" "0") + (attribute "cellspacing" "0") (attribute "width" "500") + (attribute "cellpadding" "5") (attribute "border" "0") (attribute "style" "background-color: rgb(186, 186, 186);") (with-element "tbody" (with-element "tr"

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/web/map-browser-handler.lisp
by BKNR Commits 01 Sep '08

01 Sep '08

Revision: 3757 Author: ksprotte URL: http://bknr.net/trac/changeset/3757 MAP-BROWSER-HANDLER is more careful when appending get-parameters to CHOSEN-URL (it now inserts a '&', if needed) U trunk/projects/bos/web/map-browser-handler.lisp Modified: trunk/projects/bos/web/map-browser-handler.lisp =================================================================== --- trunk/projects/bos/web/map-browser-handler.lisp 2008-09-01 10:12:19 UTC (rev 3756) +++ trunk/projects/bos/web/map-browser-handler.lisp 2008-09-01 11:11:04 UTC (rev 3757) @@ -1,4 +1,4 @@ - ; please don't read this code, it is not pretty +;; please don't read this code, it is not pretty (in-package :bos.web) @@ -38,9 +38,13 @@ (apply #'ensure-valid-coordinates handler-arguments))))) (defmethod handle ((handler map-browser-handler)) - (with-query-params (chosen-url) - (when chosen-url - (setf (hunchentoot:session-value :chosen-url) chosen-url))) + (flet ((append-&-if-needed (string) + (if (char= #\& (char string (1- (length string)))) + string + (concatenate 'string string "&")))) + (with-query-params (chosen-url) + (when chosen-url + (setf (hunchentoot:session-value :chosen-url) (append-&-if-needed chosen-url))))) (with-query-params (view-x view-y) (destructuring-bind (&optional click-x click-y) (decode-ismap-query-string) (destructuring-bind (&optional point-x point-y) (decode-coords-in-handler-path handler)

1 0

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

01 Sep '08

Revision: 3756 Author: ksprotte URL: http://bknr.net/trac/changeset/3756 When saving changes in Edit poi the user is now re-linked from the "Your changes have been saved" page to the edit-page without loosing the current language. Also some indentation and whitespace cleanups. U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-09-01 10:09:00 UTC (rev 3755) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-01 10:12:19 UTC (rev 3756) @@ -65,7 +65,7 @@ (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 6 images " - "has been uploaded."))) + "have been uploaded."))) ((:form :method "POST" :enctype "multipart/form-data") ((:table :border "1") (:tr (:td "name") @@ -113,23 +113,23 @@ (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"))) - (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=~D&shift-id=~D" - (store-object-id poi) index - (store-object-id image))) - ((:img :border "0" :src "/images/pfeil-r.gif")))))))))) + :br + (if (zerop index) + (html ((:img :src "/images/trans.gif" :width "16"))) + (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=~D&shift-id=~D" + (store-object-id poi) index + (store-object-id image))) + ((:img :border "0" :src "/images/pfeil-r.gif")))))))))) (unless (= 6 (length (poi-sat-images poi))) (html :br - (cmslink (format nil "edit-poi-medium/?poi=~A" (store-object-id poi)) "[new]"))))) + (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") @@ -138,7 +138,7 @@ ((: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))) + (class-subclasses (find-class 'poi-medium))) :default "poi-image"))) (:tr (:td "File") @@ -173,7 +173,8 @@ :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") ".")))) + "You may " (cmslink (format nil "~A?language=~A" (edit-object-url poi) language) + "continue editing the POI") ".")))) (defmethod handle-object-form ((handler edit-poi-handler) (action (eql :upload-airal)) @@ -279,12 +280,12 @@ (content-language-chooser) ((:form :method "post" :enctype "multipart/form-data") ((:input :type "hidden" :name "poi" :value poi)) - (:table (medium-handler-preview medium) + (: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"))) + :br + (submit-button "upload" "upload"))) (:tr ((:td :colspan "2" :height "10"))) (:tr (:td "title") (:td (text-field "title" @@ -353,7 +354,7 @@ (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*)) + (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." @@ -364,7 +365,7 @@ (type-of medium) (intern (string-upcase new-medium-type))) :initargs `(:poi ,poi)))) - (when medium + (when medium (delete-object medium)) (redirect (format nil "/edit-poi-medium/~D?poi=~D" (store-object-id new-medium) @@ -428,8 +429,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)))) @@ -525,8 +526,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"))))) ;;; poi-xml-handler (defun write-poi-xml (poi language)

1 0

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

01 Sep '08

Revision: 3755 Author: ksprotte URL: http://bknr.net/trac/changeset/3755 small indentation change U trunk/projects/bos/web/web-utils.lisp Modified: trunk/projects/bos/web/web-utils.lisp =================================================================== --- trunk/projects/bos/web/web-utils.lisp 2008-08-30 20:20:16 UTC (rev 3754) +++ trunk/projects/bos/web/web-utils.lisp 2008-09-01 10:09:00 UTC (rev 3755) @@ -37,18 +37,19 @@ (defun language-name (language-short-name) (cadr (assoc language-short-name (website-languages) :test #'equal))) -(defun content-language-chooser () +(defun content-language-chooser () (html ((:p :class "languages") "Content languages: " (loop for (language-symbol language-name) in (website-languages) - do (labels ((show-language-link () + 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)) + (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)

1 0