Author: hhubner Date: Wed Feb 13 15:22:21 2008 New Revision: 2488
Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp branches/trunk-reorg/bknr/web/src/web/tags.lisp branches/trunk-reorg/projects/bos/web/webserver.lisp branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp branches/trunk-reorg/projects/quickhoney/src/tags.lisp branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Log: Fixes for templater and toplevel, BOS templates now work a bit better.
Modified: branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp (original) +++ branches/trunk-reorg/bknr/web/src/images/imageproc-handler.lisp Wed Feb 13 15:22:21 2008 @@ -16,35 +16,35 @@
(defun apply-imageproc-operation (operation-name args image) (apply (or (gethash (make-keyword-from-string operation-name) *imageproc-operations*) - (error "invalid imageproc operation name ~A" operation-name)) - image args)) + (error "invalid imageproc operation name ~A" operation-name)) + image args))
(defun imageproc (image operations) (with-store-image (input-image image) (setf (save-alpha-p :image input-image) t) (let ((working-image input-image)) (dolist (operation operations) - (destructuring-bind (operation-name &rest args) (substitute nil "" (split "," operation) :test #'equal) - (let ((returned-image (apply-imageproc-operation operation-name args working-image))) - (unless (not returned-image) - (unless (or (eq working-image returned-image) - (eq working-image input-image)) - (destroy-image working-image)) - (setf working-image returned-image))))) + (destructuring-bind (operation-name &rest args) (substitute nil "" (split "," operation) :test #'equal) + (let ((returned-image (apply-imageproc-operation operation-name args working-image))) + (unless (not returned-image) + (unless (or (eq working-image returned-image) + (eq working-image input-image)) + (destroy-image working-image)) + (setf working-image returned-image))))) (when (and (true-color-p working-image) - (not (true-color-p input-image))) - (true-color-to-palette :dither t :image working-image :colors-wanted 256)) + (not (true-color-p input-image))) + (true-color-to-palette :dither t :image working-image :colors-wanted 256)) (let ((stream (send-headers))) - (setf (flex:flexi-stream-element-type stream) 'flex:octet) - (write-image-to-stream stream (image-type-keyword image) :image working-image)) + (setf (flex:flexi-stream-element-type stream) 'flex:octet) + (write-image-to-stream stream (image-type-keyword image) :image working-image)) (unless (eq working-image input-image) - (destroy-image working-image))))) + (destroy-image working-image)))))
#+(or) (unless (member type '(:jpg :jpeg)) (when (true-color-p input-image) (true-color-to-palette :dither t :image input-image - :colors-wanted 256))) + :colors-wanted 256)))
(defparameter *cell-border-width* 5)
@@ -54,38 +54,38 @@ (setf bgcolor (if (and (stringp bgcolor) (not (zerop (length bgcolor)))) bgcolor nil)) (setq border-width (if border-width (parse-integer border-width) *cell-border-width*)) (let* ((width (image-width input-image)) - (height (image-height input-image)) - (ratio (max (/ width (- cell-width (* border-width 2))) - (/ height (- cell-height (* border-width 2))))) - (thumbnail-width (min width (round (/ width ratio)))) - (thumbnail-height (min height (round (/ height ratio)))) - (x-offset (round (/ (- cell-width thumbnail-width) 2))) - (y-offset (round (/ (- cell-height thumbnail-height) 2))) - (cell (create-image cell-width cell-height t))) + (height (image-height input-image)) + (ratio (max (/ width (- cell-width (* border-width 2))) + (/ height (- cell-height (* border-width 2))))) + (thumbnail-width (min width (round (/ width ratio)))) + (thumbnail-height (min height (round (/ height ratio)))) + (x-offset (round (/ (- cell-width thumbnail-width) 2))) + (y-offset (round (/ (- cell-height thumbnail-height) 2))) + (cell (create-image cell-width cell-height t))) (with-default-image (cell) (let ((color (if bgcolor - (parse-color bgcolor) - (allocate-color 255 255 255)))) - (fill-image 0 0 :color color) - (copy-image input-image cell - 0 0 - x-offset - y-offset - width height - :resize t :resample t - :dest-width thumbnail-width :dest-height thumbnail-height) - (unless bgcolor - (setf (transparent-color) color) - (let ((cr (ldb (byte 8 16) color)) - (cg (ldb (byte 8 8) color)) - (cb (ldb (byte 8 0) color))) - (flet ((color-distance (c) - (+ (abs (- (ldb (byte 8 16) c) cr)) - (abs (- (ldb (byte 8 8) c) cg)) - (abs (- (ldb (byte 8 0) c) cb))))) - (do-pixels () - (when (< (color-distance (raw-pixel)) 6) - (setf (raw-pixel) color)))))))) + (parse-color bgcolor) + (allocate-color 255 255 255)))) + (fill-image 0 0 :color color) + (copy-image input-image cell + 0 0 + x-offset + y-offset + width height + :resize t :resample t + :dest-width thumbnail-width :dest-height thumbnail-height) + (unless bgcolor + (setf (transparent-color) color) + (let ((cr (ldb (byte 8 16) color)) + (cg (ldb (byte 8 8) color)) + (cb (ldb (byte 8 0) color))) + (flet ((color-distance (c) + (+ (abs (- (ldb (byte 8 16) c) cr)) + (abs (- (ldb (byte 8 8) c) cg)) + (abs (- (ldb (byte 8 0) c) cb))))) + (do-pixels () + (when (< (color-distance (raw-pixel)) 6) + (setf (raw-pixel) color)))))))) cell))
(define-imageproc-handler thumbnail (input-image &optional bgcolor max-width max-height) @@ -93,50 +93,50 @@ (setf max-width (if max-width (parse-integer max-width) *thumbnail-max-width*)) (setf max-height (if max-height (parse-integer max-height) *thumbnail-max-height*)) (let ((width (image-width input-image)) - (height (image-height input-image))) + (height (image-height input-image))) (when (or (< max-width width) - (< max-height height)) + (< max-height height)) (let* ((ratio (max (/ width max-width) - (/ height max-height))) - (thumbnail-width (round (/ width ratio))) - (thumbnail-height (round (/ height ratio))) - (thumbnail (create-image thumbnail-width - thumbnail-height - t))) - (with-default-image (thumbnail) - (fill-image 0 0 :color (parse-color bgcolor)) - (copy-image input-image thumbnail - 0 0 0 0 - width height - :resize t :resample t - :dest-width thumbnail-width :dest-height thumbnail-height)) - thumbnail)))) + (/ height max-height))) + (thumbnail-width (round (/ width ratio))) + (thumbnail-height (round (/ height ratio))) + (thumbnail (create-image thumbnail-width + thumbnail-height + t))) + (with-default-image (thumbnail) + (fill-image 0 0 :color (parse-color bgcolor)) + (copy-image input-image thumbnail + 0 0 0 0 + width height + :resize t :resample t + :dest-width thumbnail-width :dest-height thumbnail-height)) + thumbnail))))
(define-imageproc-handler double (input-image &optional (times "2")) (let* ((width (image-width input-image)) - (height (image-height input-image)) - (ratio (/ 1 (parse-integer times))) - (double-image-width (round (/ width ratio))) - (double-image-height (round (/ height ratio))) - (double-image (create-image double-image-width double-image-height nil))) + (height (image-height input-image)) + (ratio (/ 1 (parse-integer times))) + (double-image-width (round (/ width ratio))) + (double-image-height (round (/ height ratio))) + (double-image (create-image double-image-width double-image-height nil))) (with-default-image (double-image) (setf (transparent-color double-image) - (find-color-from-image (transparent-color input-image) input-image :alpha t :resolve t)) + (find-color-from-image (transparent-color input-image) input-image :alpha t :resolve t)) (fill-image 0 0 :color (transparent-color double-image)) (copy-image input-image double-image - 0 0 0 0 width height - :resize t - :dest-width double-image-width :dest-height double-image-height)) + 0 0 0 0 width height + :resize t + :dest-width double-image-width :dest-height double-image-height)) double-image))
(define-imageproc-handler color (input-image &rest color-mappings) (with-default-image (input-image) (let ((colors (loop for (old new) on color-mappings by #'cddr - collect (cons (parse-color old) (parse-color new))))) + collect (cons (parse-color old) (parse-color new))))) (do-pixels (input-image) - (let ((new-color (assoc (ldb (byte 24 0) (raw-pixel)) colors))) - (when (cdr new-color) - (setf (raw-pixel) (cdr new-color))))))) + (let ((new-color (assoc (ldb (byte 24 0) (raw-pixel)) colors))) + (when (cdr new-color) + (setf (raw-pixel) (cdr new-color))))))) input-image)
(defun image-url (image &key process (prefix "/image")) @@ -146,19 +146,19 @@ (if (string-equal color-string "transparent") (transparent-color image) (let ((components (multiple-value-bind (match strings) - (scan-to-strings "^#?(..)(..)(..)?$" color-string) - (if match - (mapcar #'(lambda (string) (when string (parse-integer string :radix 16))) - (coerce strings 'list)) - (progn - (warn "can't parse color spec ~a" color-string) - '(0 0 0)))))) - (let ((color (find-color (first components) (second components) (third components) - :exact t :image image))) - (unless color - (setf color (find-color (first components) (second components) (third components) - :exact nil :resolve t :image image))) - color)))) + (scan-to-strings "^#?(..)(..)(..)?$" color-string) + (if match + (mapcar #'(lambda (string) (when string (parse-integer string :radix 16))) + (coerce strings 'list)) + (progn + (warn "can't parse color spec ~a" color-string) + '(0 0 0)))))) + (let ((color (find-color (first components) (second components) (third components) + :exact t :image image))) + (unless color + (setf color (find-color (first components) (second components) (third components) + :exact nil :resolve t :image image))) + color))))
(defclass imageproc-handler (image-handler) ()) @@ -174,14 +174,14 @@ #+(or) (with-http-response (:content-type (image-content-type (image-type-keyword image))) (let ((ims (header-in :if-modified-since)) - (changed-time (blob-timestamp image))) + (changed-time (blob-timestamp image))) (setf (header-out :last-modified) (rfc-1123-date changed-time)) - (if (and ims - (<= changed-time (date-to-universal-time ims))) - (progn - (setf (return-code) +http-not-modified+) - (format t "; image ~A not changed~%" image) - (with-http-body ())) - (with-http-body () - (imageproc image (cdr (decoded-handler-path page-handler)))))))) + (if (and ims + (<= changed-time (date-to-universal-time ims))) + (progn + (setf (return-code) +http-not-modified+) + (format t "; image ~A not changed~%" image) + (with-http-body ())) + (with-http-body () + (imageproc image (cdr (decoded-handler-path page-handler))))))))
Modified: branches/trunk-reorg/bknr/web/src/web/tags.lisp ============================================================================== --- branches/trunk-reorg/bknr/web/src/web/tags.lisp (original) +++ branches/trunk-reorg/bknr/web/src/web/tags.lisp Wed Feb 13 15:22:21 2008 @@ -4,7 +4,7 @@
(defvar *toplevel-children*)
-(define-bknr-tag toplevel (&key children title (template "toplevel")) +(define-bknr-tag toplevel (&key title (template "toplevel")) (setf (get-template-var :title) title) (when (and (not (scan "^/" template)) (scan "/" (request-variable :template-path))) @@ -14,8 +14,8 @@ (let* ((expander *template-expander*) (pathname (find-template-pathname expander template)) (toplevel (get-cached-template pathname expander)) - (*toplevel-children* children)) - (emit-template-node toplevel))) + (*toplevel-children* *tag-children*)) + (emit-template-node *template-expander* toplevel)))
(define-bknr-tag tag-body () (let ((*tag-children* *toplevel-children*))
Modified: branches/trunk-reorg/projects/bos/web/webserver.lisp ============================================================================== --- branches/trunk-reorg/projects/bos/web/webserver.lisp (original) +++ branches/trunk-reorg/projects/bos/web/webserver.lisp Wed Feb 13 15:22:21 2008 @@ -195,6 +195,7 @@
(setf *worldpay-test-mode* worldpay-test-mode) (setf bknr.web:*upload-file-size-limit* 20000000) + (setf hunchentoot::*hunchentoot-default-external-format* (flex:make-external-format :utf-8 :eol-style :lf))
(make-instance 'bos-website :name "create-rainforest.org CMS"
Modified: branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/imageproc.lisp Wed Feb 13 15:22:21 2008 @@ -4,36 +4,35 @@
(define-imageproc-handler cutout-button (input-image &optional keyword (background-color "ffffff")) (let ((button-image (create-image *button-size* *button-size* t)) - (square-size (min (image-width input-image) (image-height input-image))) - (x-offset (if (> (image-width input-image) (image-height input-image)) - (round (/ (- (image-width input-image) (image-height input-image)) 2)) - 0))) + (square-size (min (image-width input-image) (image-height input-image))) + (x-offset (if (> (image-width input-image) (image-height input-image)) + (round (/ (- (image-width input-image) (image-height input-image)) 2)) + 0))) (copy-image input-image button-image - x-offset 0 - 0 0 - square-size square-size - :resize t :resample t - :dest-width *button-size* :dest-height *button-size*) + x-offset 0 + 0 0 + square-size square-size + :resize t :resample t + :dest-width *button-size* :dest-height *button-size*) (when keyword (let ((type-store-image (store-image-with-name (format nil "type-~(~A~)" keyword)))) - (unless type-store-image - (error "can't find type image for keyword ~A" keyword)) - (with-store-image (type-image type-store-image) - (copy-image type-image button-image - 0 0 - 0 0 - (image-width type-image) (image-height type-image))))) + (unless type-store-image + (error "can't find type image for keyword ~A" keyword)) + (with-store-image (type-image type-store-image) + (copy-image type-image button-image + 0 0 + 0 0 + (image-width type-image) (image-height type-image))))) (with-store-image (mask-image (store-image-with-name "button-mask")) - #-(or) ;; notyet (let ((color (parse-color background-color :image mask-image)) - (white (parse-color "ffffff" :image mask-image))) - (do-pixels (mask-image) - (if (eql (ldb (byte 24 0) (raw-pixel)) white) - (setf (raw-pixel) color)))) + (white (parse-color "ffffff" :image mask-image))) + (do-pixels (mask-image) + (when t (eql (ldb (byte 24 0) (raw-pixel)) white) + (setf (raw-pixel) color)))) (copy-image mask-image button-image - 0 0 - 0 0 - *button-size* *button-size*)) + 0 0 + 0 0 + *button-size* *button-size*)) button-image))
(define-imageproc-handler center-thumbnail (input-image width height)
Modified: branches/trunk-reorg/projects/quickhoney/src/tags.lisp ============================================================================== --- branches/trunk-reorg/projects/quickhoney/src/tags.lisp (original) +++ branches/trunk-reorg/projects/quickhoney/src/tags.lisp Wed Feb 13 15:22:21 2008 @@ -2,6 +2,8 @@
(define-bknr-tag version-and-last-change (&rest args) (format *debug-io* "hello world: ~A~%" args) - (html "v1.1 | updated " (:princ-safe (string-downcase - (substitute #\Space #- - (format-date-time (last-image-upload-timestamp) :vms-style t :show-time nil)))))) \ No newline at end of file + (html "v1.1 | updated " + (:princ-safe (string-downcase + (substitute #\Space #- + (format-date-time (last-image-upload-timestamp) + :vms-style t :show-time nil)))))) \ No newline at end of file
Modified: branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp ============================================================================== --- branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp (original) +++ branches/trunk-reorg/xhtmlgen/xhtmlgen.lisp Wed Feb 13 15:22:21 2008 @@ -129,6 +129,8 @@
(defun emit-without-quoting (str) ;; das ist fuer WPDISPLAY + (format t "emit-without-quoting does not work~%") + #+(or) (let ((s (cxml::chained-handler *html-sink*))) (cxml::maybe-close-tag s) (map nil (lambda (c) (cxml::write-rune c s)) str)))