Changeset 2488
- Timestamp:
- 02/13/08 21:22:21 (1 year ago)
- Files:
-
- branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp (modified) (8 diffs)
- branches/trunk-reorg/bknr/web/src/web/tags.lisp (modified) (2 diffs)
- branches/trunk-reorg/projects/bos/web/webserver.lisp (modified) (1 diff)
- branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp (modified) (1 diff)
- branches/trunk-reorg/projects/quickhoney/src/tags.lisp (modified) (1 diff)
- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp (modified) (1 diff)
Legend:
- Unmodified
- Added
- Removed
- Modified
- Copied
- Moved
branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp
r2430 r2488 17 17 (defun apply-imageproc-operation (operation-name args image) 18 18 (apply (or (gethash (make-keyword-from-string operation-name) *imageproc-operations*) 19 20 19 (error "invalid imageproc operation name ~A" operation-name)) 20 image args)) 21 21 22 22 (defun imageproc (image operations) … … 25 25 (let ((working-image input-image)) 26 26 (dolist (operation operations) 27 28 29 30 31 32 33 27 (destructuring-bind (operation-name &rest args) (substitute nil "" (split "," operation) :test #'equal) 28 (let ((returned-image (apply-imageproc-operation operation-name args working-image))) 29 (unless (not returned-image) 30 (unless (or (eq working-image returned-image) 31 (eq working-image input-image)) 32 (destroy-image working-image)) 33 (setf working-image returned-image))))) 34 34 (when (and (true-color-p working-image) 35 36 35 (not (true-color-p input-image))) 36 (true-color-to-palette :dither t :image working-image :colors-wanted 256)) 37 37 (let ((stream (send-headers))) 38 39 38 (setf (flex:flexi-stream-element-type stream) 'flex:octet) 39 (write-image-to-stream stream (image-type-keyword image) :image working-image)) 40 40 (unless (eq working-image input-image) 41 41 (destroy-image working-image))))) 42 42 43 43 #+(or) … … 45 45 (when (true-color-p input-image) 46 46 (true-color-to-palette :dither t :image input-image 47 47 :colors-wanted 256))) 48 48 49 49 (defparameter *cell-border-width* 5) … … 55 55 (setq border-width (if border-width (parse-integer border-width) *cell-border-width*)) 56 56 (let* ((width (image-width input-image)) 57 58 59 60 61 62 63 64 57 (height (image-height input-image)) 58 (ratio (max (/ width (- cell-width (* border-width 2))) 59 (/ height (- cell-height (* border-width 2))))) 60 (thumbnail-width (min width (round (/ width ratio)))) 61 (thumbnail-height (min height (round (/ height ratio)))) 62 (x-offset (round (/ (- cell-width thumbnail-width) 2))) 63 (y-offset (round (/ (- cell-height thumbnail-height) 2))) 64 (cell (create-image cell-width cell-height t))) 65 65 (with-default-image (cell) 66 66 (let ((color (if bgcolor 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 67 (parse-color bgcolor) 68 (allocate-color 255 255 255)))) 69 (fill-image 0 0 :color color) 70 (copy-image input-image cell 71 0 0 72 x-offset 73 y-offset 74 width height 75 :resize t :resample t 76 :dest-width thumbnail-width :dest-height thumbnail-height) 77 (unless bgcolor 78 (setf (transparent-color) color) 79 (let ((cr (ldb (byte 8 16) color)) 80 (cg (ldb (byte 8 8) color)) 81 (cb (ldb (byte 8 0) color))) 82 (flet ((color-distance (c) 83 (+ (abs (- (ldb (byte 8 16) c) cr)) 84 (abs (- (ldb (byte 8 8) c) cg)) 85 (abs (- (ldb (byte 8 0) c) cb))))) 86 (do-pixels () 87 (when (< (color-distance (raw-pixel)) 6) 88 (setf (raw-pixel) color)))))))) 89 89 cell)) 90 90 … … 94 94 (setf max-height (if max-height (parse-integer max-height) *thumbnail-max-height*)) 95 95 (let ((width (image-width input-image)) 96 96 (height (image-height input-image))) 97 97 (when (or (< max-width width) 98 98 (< max-height height)) 99 99 (let* ((ratio (max (/ width max-width) 100 101 102 103 104 105 106 107 108 109 110 111 112 113 100 (/ height max-height))) 101 (thumbnail-width (round (/ width ratio))) 102 (thumbnail-height (round (/ height ratio))) 103 (thumbnail (create-image thumbnail-width 104 thumbnail-height 105 t))) 106 (with-default-image (thumbnail) 107 (fill-image 0 0 :color (parse-color bgcolor)) 108 (copy-image input-image thumbnail 109 0 0 0 0 110 width height 111 :resize t :resample t 112 :dest-width thumbnail-width :dest-height thumbnail-height)) 113 thumbnail)))) 114 114 115 115 (define-imageproc-handler double (input-image &optional (times "2")) 116 116 (let* ((width (image-width input-image)) 117 118 119 120 121 117 (height (image-height input-image)) 118 (ratio (/ 1 (parse-integer times))) 119 (double-image-width (round (/ width ratio))) 120 (double-image-height (round (/ height ratio))) 121 (double-image (create-image double-image-width double-image-height nil))) 122 122 (with-default-image (double-image) 123 123 (setf (transparent-color double-image) 124 124 (find-color-from-image (transparent-color input-image) input-image :alpha t :resolve t)) 125 125 (fill-image 0 0 :color (transparent-color double-image)) 126 126 (copy-image input-image double-image 127 128 129 127 0 0 0 0 width height 128 :resize t 129 :dest-width double-image-width :dest-height double-image-height)) 130 130 double-image)) 131 131 … … 133 133 (with-default-image (input-image) 134 134 (let ((colors (loop for (old new) on color-mappings by #'cddr 135 135 collect (cons (parse-color old) (parse-color new))))) 136 136 (do-pixels (input-image) 137 138 139 137 (let ((new-color (assoc (ldb (byte 24 0) (raw-pixel)) colors))) 138 (when (cdr new-color) 139 (setf (raw-pixel) (cdr new-color))))))) 140 140 input-image) 141 141 … … 147 147 (transparent-color image) 148 148 (let ((components (multiple-value-bind (match strings) 149 150 151 152 153 154 155 156 157 158 159 160 161 149 (scan-to-strings "^#?(..)(..)(..)?$" color-string) 150 (if match 151 (mapcar #'(lambda (string) (when string (parse-integer string :radix 16))) 152 (coerce strings 'list)) 153 (progn 154 (warn "can't parse color spec ~a" color-string) 155 '(0 0 0)))))) 156 (let ((color (find-color (first components) (second components) (third components) 157 :exact t :image image))) 158 (unless color 159 (setf color (find-color (first components) (second components) (third components) 160 :exact nil :resolve t :image image))) 161 color)))) 162 162 163 163 (defclass imageproc-handler (image-handler) … … 175 175 (with-http-response (:content-type (image-content-type (image-type-keyword image))) 176 176 (let ((ims (header-in :if-modified-since)) 177 177 (changed-time (blob-timestamp image))) 178 178 (setf (header-out :last-modified) (rfc-1123-date changed-time)) 179 180 181 182 183 184 185 186 179 (if (and ims 180 (<= changed-time (date-to-universal-time ims))) 181 (progn 182 (setf (return-code) +http-not-modified+) 183 (format t "; image ~A not changed~%" image) 184 (with-http-body ())) 185 (with-http-body () 186 (imageproc image (cdr (decoded-handler-path page-handler)))))))) 187 187 branches/trunk-reorg/bknr/web/src/web/tags.lisp
r2438 r2488 5 5 (defvar *toplevel-children*) 6 6 7 (define-bknr-tag toplevel (&key childrentitle (template "toplevel"))7 (define-bknr-tag toplevel (&key title (template "toplevel")) 8 8 (setf (get-template-var :title) title) 9 9 (when (and (not (scan "^/" template)) … … 15 15 (pathname (find-template-pathname expander template)) 16 16 (toplevel (get-cached-template pathname expander)) 17 (*toplevel-children* children))18 (emit-template-node toplevel)))17 (*toplevel-children* *tag-children*)) 18 (emit-template-node *template-expander* toplevel))) 19 19 20 20 (define-bknr-tag tag-body () branches/trunk-reorg/projects/bos/web/webserver.lisp
r2484 r2488 196 196 (setf *worldpay-test-mode* worldpay-test-mode) 197 197 (setf bknr.web:*upload-file-size-limit* 20000000) 198 (setf hunchentoot::*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf)) 198 199 199 200 (make-instance 'bos-website branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp
r1415 r2488 5 5 (define-imageproc-handler cutout-button (input-image &optional keyword (background-color "ffffff")) 6 6 (let ((button-image (create-image *button-size* *button-size* t)) 7 8 9 10 7 (square-size (min (image-width input-image) (image-height input-image))) 8 (x-offset (if (> (image-width input-image) (image-height input-image)) 9 (round (/ (- (image-width input-image) (image-height input-image)) 2)) 10 0))) 11 11 (copy-image input-image button-image 12 13 14 15 16 12 x-offset 0 13 0 0 14 square-size square-size 15 :resize t :resample t 16 :dest-width *button-size* :dest-height *button-size*) 17 17 (when keyword 18 18 (let ((type-store-image (store-image-with-name (format nil "type-~(~A~)" keyword)))) 19 20 21 22 23 24 25 19 (unless type-store-image 20 (error "can't find type image for keyword ~A" keyword)) 21 (with-store-image (type-image type-store-image) 22 (copy-image type-image button-image 23 0 0 24 0 0 25 (image-width type-image) (image-height type-image))))) 26 26 (with-store-image (mask-image (store-image-with-name "button-mask")) 27 #-(or) ;; notyet28 27 (let ((color (parse-color background-color :image mask-image)) 29 30 31 (if(eql (ldb (byte 24 0) (raw-pixel)) white)32 28 (white (parse-color "ffffff" :image mask-image))) 29 (do-pixels (mask-image) 30 (when t (eql (ldb (byte 24 0) (raw-pixel)) white) 31 (setf (raw-pixel) color)))) 33 32 (copy-image mask-image button-image 34 35 36 33 0 0 34 0 0 35 *button-size* *button-size*)) 37 36 button-image)) 38 37 branches/trunk-reorg/projects/quickhoney/src/tags.lisp
r2438 r2488 3 3 (define-bknr-tag version-and-last-change (&rest args) 4 4 (format *debug-io* "hello world: ~A~%" args) 5 (html "v1.1 | updated " (:princ-safe (string-downcase 6 (substitute #\Space #\- 7 (format-date-time (last-image-upload-timestamp) :vms-style t :show-time nil)))))) 5 (html "v1.1 | updated " 6 (:princ-safe (string-downcase 7 (substitute #\Space #\- 8 (format-date-time (last-image-upload-timestamp) 9 :vms-style t :show-time nil)))))) branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp
r2480 r2488 130 130 (defun emit-without-quoting (str) 131 131 ;; das ist fuer WPDISPLAY 132 (format t "emit-without-quoting does not work~%") 133 #+(or) 132 134 (let ((s (cxml::chained-handler *html-sink*))) 133 135 (cxml::maybe-close-tag s)
