[bknr-cvs] hans changed trunk/projects/quickhoney/src/handlers.lisp

[BKNR Commits]

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 ()