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

[bknr-cvs] hans changed trunk/projects/quickhoney/src/image.lisp
by BKNR Commits 02 Sep '08

02 Sep '08

Revision: 3770 Author: hans URL: http://bknr.net/trac/changeset/3770 reindent U trunk/projects/quickhoney/src/image.lisp Modified: trunk/projects/quickhoney/src/image.lisp =================================================================== --- trunk/projects/quickhoney/src/image.lisp 2008-09-02 10:57:55 UTC (rev 3769) +++ trunk/projects/quickhoney/src/image.lisp 2008-09-02 14:00:46 UTC (rev 3770) @@ -2,9 +2,9 @@ (define-persistent-class quickhoney-image (store-image rss-item) ((client :update :initform nil - :index-type hash-index :index-initargs (:test #'equal) - :index-reader images-for-client - :index-keys all-clients) + :index-type hash-index :index-initargs (:test #'equal) + :index-reader images-for-client + :index-keys all-clients) (spider-keywords :update :initform nil) (products :update :initform nil))) @@ -20,7 +20,7 @@ (mapc (lambda (image) (persistent-change-class image 'quickhoney-image) (store-object-remove-keywords image 'bknr.web::keywords '(:import))) - (get-keywords-intersection-store-images '(:import)))) + (get-keywords-intersection-store-images '(:import)))) (defmethod quickhoney-image-category ((image quickhoney-image)) (first (intersection (store-image-keywords image) '(:pixel :vector :news :contact)))) @@ -32,7 +32,7 @@ (format nil "~@[~A~]/index#~(~A~@[/~A~]~)/~A" (unless internal (format nil "http://~A" (website-host))) - (quickhoney-image-category image) (quickhoney-image-subcategory image) (store-image-name image))) + (quickhoney-image-category image) (quickhoney-image-subcategory image) (store-image-name image))) (define-persistent-class quickhoney-animation-image (quickhoney-image) ((animation :update)))

1 0

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

02 Sep '08

Revision: 3769 Author: ksprotte URL: http://bknr.net/trac/changeset/3769 updated ptviewer to latest; its now used in the CMS U trunk/projects/bos/payment-website/static/ptviewer.jar U trunk/projects/bos/web/poi-handlers.lisp Modified: trunk/projects/bos/payment-website/static/ptviewer.jar =================================================================== (Binary files differ) Modified: trunk/projects/bos/web/poi-handlers.lisp =================================================================== --- trunk/projects/bos/web/poi-handlers.lisp 2008-09-02 10:22:51 UTC (rev 3768) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-02 10:57:55 UTC (rev 3769) @@ -247,12 +247,21 @@ (:tr (:td "full image") (:td ((:img :src (format nil "/image/~A" (store-object-id medium)))))))))) (:method ((medium poi-panorama) &key small) - (declare (ignore small)) (html (:tr (:td "thumbnail") - (:td ((: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))))))))) + (:td (if small + (html + ((: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)))))) + (html + ((:applet :archive "/static/ptviewer.jar" + :code "ptviewer.class" + :width "300" + :height "150") + ((:param :name "file" + :value (format nil "/image/~A" (store-object-id medium)))) + ((:param :name "quality" :value "3"))))))))) (:method ((medium poi-movie) &key small) (if small (call-next-method)

1 0

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

02 Sep '08

Revision: 3768 Author: ksprotte URL: http://bknr.net/trac/changeset/3768 we need hunchentoot:*use-user-agent-for-sessions* nil (see comment in source) U trunk/projects/bos/web/startup.lisp Modified: trunk/projects/bos/web/startup.lisp =================================================================== --- trunk/projects/bos/web/startup.lisp 2008-09-02 09:14:28 UTC (rev 3767) +++ trunk/projects/bos/web/startup.lisp 2008-09-02 10:22:51 UTC (rev 3768) @@ -44,7 +44,10 @@ (when *webserver* (hunchentoot:stop-server *webserver*)) (setf hunchentoot:*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf) - hunchentoot:*rewrite-for-session-urls* nil) + hunchentoot:*rewrite-for-session-urls* nil + ;; the reason for the following setting is that ptviewer sends + ;; a different User-Agent -- (when requesting PTDefault.html) + hunchentoot:*use-user-agent-for-sessions* nil) (setq *webserver* (hunchentoot:start-server :port *port* :threaded (not debug) :persistent-connections-p (not debug))) (if start-frontend

1 0

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

02 Sep '08

Revision: 3767 Author: ksprotte URL: http://bknr.net/trac/changeset/3767 avoiding a Java-script error when loading the sat-app, by defaulting sponsor-country to "de" instead of NIL 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-02 08:37:24 UTC (rev 3766) +++ trunk/projects/bos/web/poi-handlers.lisp 2008-09-02 09:14:28 UTC (rev 3767) @@ -341,7 +341,7 @@ (store-object-id contract) (format-date-time (contract-date contract) :js-style t) (or (user-full-name (contract-sponsor contract)) "anonymous") - (sponsor-country (contract-sponsor contract)) + (or (sponsor-country (contract-sponsor contract)) "de") (length (contract-m2s contract)))) (defmethod handle ((handler poi-javascript-handler))

1 0

[bknr-cvs] ksprotte changed trunk/projects/bos/payment-website/static/bos.js
by BKNR Commits 02 Sep '08

02 Sep '08

Revision: 3766 Author: ksprotte URL: http://bknr.net/trac/changeset/3766 window_infosys detects the language from a document body attribute. fixed the namespace: bos:lang U trunk/projects/bos/payment-website/static/bos.js Modified: trunk/projects/bos/payment-website/static/bos.js =================================================================== --- trunk/projects/bos/payment-website/static/bos.js 2008-09-01 19:40:08 UTC (rev 3765) +++ trunk/projects/bos/payment-website/static/bos.js 2008-09-02 08:37:24 UTC (rev 3766) @@ -22,7 +22,7 @@ // *** extrafenster fuer satellitenkarte *** // function window_infosys() { - var url = "/infosystem/" + document.body.lang + "/satellitenkarte.htm"; + var url = "/infosystem/" + document.body.getAttribute("bos:lang") + "/satellitenkarte.htm"; var sponsorid_input = document.getElementById('sponsorid-input'); var password_input = document.getElementById('password-input');

1 0

[bknr-cvs] hans changed trunk/bknr/web/src/web/t
by BKNR Commits 01 Sep '08

01 Sep '08

Revision: 3765 Author: hans URL: http://bknr.net/trac/changeset/3765 Fix templater. U trunk/bknr/web/src/web/tags.lisp U trunk/bknr/web/src/web/template-handler.lisp Modified: trunk/bknr/web/src/web/tags.lisp =================================================================== --- trunk/bknr/web/src/web/tags.lisp 2008-09-01 16:17:30 UTC (rev 3764) +++ trunk/bknr/web/src/web/tags.lisp 2008-09-01 19:40:08 UTC (rev 3765) @@ -13,7 +13,7 @@ template))) (let* ((expander *template-expander*) (pathname (find-template-pathname expander template)) - (toplevel (get-cached-template pathname expander)) + (toplevel (parsed-template-dom (get-cached-template pathname expander))) (*toplevel-children* *tag-children*)) (emit-template-node *template-expander* toplevel))) Modified: trunk/bknr/web/src/web/template-handler.lisp =================================================================== --- trunk/bknr/web/src/web/template-handler.lisp 2008-09-01 16:17:30 UTC (rev 3764) +++ trunk/bknr/web/src/web/template-handler.lisp 2008-09-01 19:40:08 UTC (rev 3765) @@ -51,7 +51,7 @@ (function-name (string-upcase name))) (or (gethash function-name (or (gethash (symbol-name package-name) *template-functions*) (error "can't find package ~A in tag function registry" package-name))) - (error "can't find tag function ~A:~A in command package ~A" ns name package-name)))) + (error "can't find tag function ~A in command package ~A" name package-name)))) (defclass local-template-expander () ((parent :initarg :parent :reader local-template-expander-parent)

1 0

[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