[bknr-cvs] r2488 - in branches/trunk-reorg: bknr/web/src/images bknr/web/src/web projects/bos/web projects/quickhoney/src xhtmlgen
hhubner at common-lisp.net
hhubner at common-lisp.net
Wed Feb 13 20:22:23 UTC 2008
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)))
More information about the Bknr-cvs
mailing list