Revision: 4029 Author: hans URL: http://bknr.net/trac/changeset/4029

Improve image quality for uploaded jpg images.

U trunk/projects/quickhoney/src/handlers.lisp

Modified: trunk/projects/quickhoney/src/handlers.lisp =================================================================== --- trunk/projects/quickhoney/src/handlers.lisp 2008-11-10 08:39:46 UTC (rev 4028) +++ trunk/projects/quickhoney/src/handlers.lisp 2008-11-10 09:38:22 UTC (rev 4029) @@ -303,7 +303,8 @@ (defun maybe-convert-to-palette (&optional (image cl-gd:*default-image*)) (when (and (cl-gd:true-color-p image) (<= (count-colors-used image) 256)) - (cl-gd:true-color-to-palette :image image))) + (cl-gd:true-color-to-palette :image image) + t))

(defmethod handle ((handler upload-image-handler)) (with-query-params (client spider-keywords) @@ -322,7 +323,8 @@ :class-name 'quickhoney-image :keywords (cons :upload (image-keywords-from-request-parameters)) :initargs (list :owner (bknr-session-user) - :cat-sub (mapcar #'make-keyword-from-string (decoded-handler-path handler)) + :cat-sub (mapcar #'make-keyword-from-string + (decoded-handler-path handler)) :client client :spider-keywords spider-keywords)))) (with-http-response () @@ -367,47 +369,49 @@

(defmethod handle ((handler upload-news-handler)) (with-query-params (title text) - (let ((uploaded-file (request-uploaded-file "image-file"))) + (let ((uploaded-file (or (request-uploaded-file "image-file")))) + (unless uploaded-file + (error "no file uploaded")) (handler-case - (progn - (unless uploaded-file - (error "no file uploaded")) - (with-image-from-upload (uploaded-image uploaded-file) - (maybe-convert-to-palette uploaded-image) - (when (> (cl-gd:image-width uploaded-image) +news-image-width+) - (let* ((scaled-height (floor (* (/ +news-image-width+ (cl-gd:image-width uploaded-image)) - (cl-gd:image-height uploaded-image)))) - (scaled-image (cl-gd:create-image +news-image-width+ scaled-height (cl-gd:true-color-p uploaded-image)))) - (cl-gd:copy-image uploaded-image scaled-image - 0 0 0 0 - (cl-gd:image-width uploaded-image) (cl-gd:image-height uploaded-image) - :resample t :resize t - :dest-width +news-image-width+ :dest-height scaled-height) - (cl-gd:destroy-image uploaded-image) - (setf uploaded-image scaled-image))) - (let* ((name (normalize-news-title title)) - (item (make-store-image :name name - :image uploaded-image - :type (if (cl-gd:true-color-p uploaded-image) :jpg :png) - :class-name 'quickhoney-news-item - :keywords (list :upload) - :initargs (list :cat-sub (list :news) - :title title - :text text - :owner (bknr-session-user))))) - (declare (ignore item)) ; for now - (twitter:update-status (bknr-session-user) - (format nil "Posted news item: http://quickhoney.com/news/~A" name)) - (with-http-response () - (with-http-body () - (html (:html - (:head - (:title "News article created") - ((:script :type "text/javascript" :language "JavaScript") - "function done() { window.opener.reload_news(); window.close(); }")) - (:body - (:p "News article created") - (:p ((:a :href "javascript:done()") "ok")))))))))) + (with-image-from-upload (uploaded-image uploaded-file) + (let* ((processed (when (> (cl-gd:image-width uploaded-image) +news-image-width+) + (let* ((scaled-height (floor (* (/ +news-image-width+ (cl-gd:image-width uploaded-image)) + (cl-gd:image-height uploaded-image)))) + (scaled-image (cl-gd:create-image +news-image-width+ scaled-height + (cl-gd:true-color-p uploaded-image)))) + (cl-gd:copy-image uploaded-image scaled-image + 0 0 0 0 + (cl-gd:image-width uploaded-image) (cl-gd:image-height uploaded-image) + :resample t :resize t + :dest-width +news-image-width+ :dest-height scaled-height) + (cl-gd:destroy-image uploaded-image) + (setf uploaded-image scaled-image)) + t)) + (name (normalize-news-title title)) + (args (list :name name + :type (if (cl-gd:true-color-p uploaded-image) :jpg :png) + :class-name 'quickhoney-news-item + :keywords (list :upload) + :initargs (list :cat-sub (list :news) + :title title + :text text + :owner (bknr-session-user)))) + (item (if processed + (apply #'make-store-image :image uploaded-image args) + (apply #'import-image (upload-pathname uploaded-file) args)))) + (declare (ignore item)) ; for now + (twitter:update-status (bknr-session-user) + (format nil "Posted news item: http://quickhoney.com/news/~A" name)) + (with-http-response () + (with-http-body () + (html (:html + (:head + (:title "News article created") + ((:script :type "text/javascript" :language "JavaScript") + "function done() { window.opener.reload_news(); window.close(); }")) + (:body + (:p "News article created") + (:p ((:a :href "javascript:done()") "ok"))))))))) (error (e) (with-http-response () (with-http-body ()