January 2007 - closure-cvs@common-lisp.net

[closure-cvs] CVS closure/src/imagelib
by emarsden 03 Jan '07

03 Jan '07

Update of /project/closure/cvsroot/closure/src/imagelib In directory clnet:/tmp/cvs-serv7799/src/imagelib Modified Files: gif.lisp Log Message: Implement transparency support for GIF files (thanks to Zachary Beane for diagnosing the problem). --- /project/closure/cvsroot/closure/src/imagelib/gif.lisp 2007/01/03 16:09:13 1.1 +++ /project/closure/cvsroot/closure/src/imagelib/gif.lisp 2007/01/03 16:41:15 1.2 @@ -43,20 +43,24 @@ (defun gif-stream->aimage (stream) (let* ((data-stream (skippy:read-data-stream (flexi-stream-from stream))) (image (skippy:last-image data-stream)) + (transparent-index (skippy:transparency-index image)) (gif-color-table (skippy:color-table data-stream)) (aimage (make-aimage (skippy:width image) - (skippy:height image) :alpha-p nil)) + (skippy:height image) :alpha-p transparent-index)) (aimage-data (aimage-data aimage))) (dotimes (x (skippy:width image)) (dotimes (y (skippy:height image)) - (multiple-value-bind (r g b) - (skippy:color-rgb - (skippy:color-table-entry gif-color-table (skippy:pixel-ref image x y))) + (multiple-value-bind (r g b a) + (let ((color-index (skippy:pixel-ref image x y))) + (if (eql color-index transparent-index) + (values 0 0 0 255) + (skippy:color-rgb + (skippy:color-table-entry gif-color-table color-index)))) (setf (aref aimage-data y x) (dpb r (byte 8 0) (dpb g (byte 8 8) (dpb b (byte 8 16) - (dpb (- 255 0) (byte 8 24) 0)))))))) + (dpb (or a 0) (byte 8 24) 0)))))))) aimage))

1 0

[closure-cvs] CVS closure/src/gui
by emarsden 03 Jan '07

03 Jan '07

Update of /project/closure/cvsroot/closure/src/gui In directory clnet:/tmp/cvs-serv3885/src/gui Modified Files: clim-gui.lisp Log Message: - new function RENDER-LHTML that renders LHTML - new command "Inspect Page" that runs Clouseau on the current document --- /project/closure/cvsroot/closure/src/gui/clim-gui.lisp 2007/01/03 11:34:45 1.28 +++ /project/closure/cvsroot/closure/src/gui/clim-gui.lisp 2007/01/03 16:14:57 1.29 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.28 2007/01/03 11:34:45 emarsden Exp $ +;;; $Id: clim-gui.lisp,v 1.29 2007/01/03 16:14:57 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,6 +28,10 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.29 2007/01/03 16:14:57 emarsden +;; - new function RENDER-LHTML that renders LHTML +;; - new command "Inspect Page" that runs Clouseau on the current document +;; ;; Revision 1.28 2007/01/03 11:34:45 emarsden ;; GUI: implement beginning-of-page and end-of-page commands; add ;; keyboard shortcuts for back & forward. @@ -344,6 +348,31 @@ (define-presentation-type r2::pt ()) (define-presentation-type r2::hyper-link ()) +;; renders LHTML as per http://opensource.franz.com/xmlutils/xmlutils-dist/phtml.htm +(defun render-lhtml (location lhtml) + (with-simple-restart (forget "Just forget rendering this page.") + (let* ((*package* (find-package :r2)) + (*pane* (find-pane-named *frame* 'canvas)) + (*medium* (sheet-medium *pane*)) + (device (make-instance 'closure/clim-device::clim-device :medium *pane*)) + (doc (make-instance 'r2::document + :processes-hooks nil + :location location + :http-header nil + :pt (sgml::lhtml->pt lhtml))) + (*current-document* doc) + (closure-protocol:*user-agent* nil) + (closure-protocol:*document-language* (make-instance 'r2::html-4.0-document-language)) + (r2::*canvas-width* (bounding-rectangle-width (sheet-parent *pane*)))) + (window-clear *pane*) + (closure-protocol:render closure-protocol:*document-language* + doc + device + (setf *current-pt* (r2::document-pt doc)) + 600 t 0) + (clim-backend:port-force-output (find-port)) + (reflow)))) + ;;;; ---------------------------------------------------------------------------------------------------- ;;;; Commands ;;;; @@ -722,5 +751,12 @@ (setq renderer:*hyphenate-p* nil) (send-closure-command 'com-reflow)) +;; for Closure developers +(define-closure-command (com-inspect-page :name t) () + (write-status "Loading Clouseau") + (asdf:oos 'asdf:load-op :clouseau) + (write-status "Starting inspector") + (funcall (find-symbol "INSPECTOR" :clouseau) *current-document* :new-process t)) + ;; EOF

1 0

[closure-cvs] CVS closure/src/imagelib
by emarsden 03 Jan '07

03 Jan '07

Update of /project/closure/cvsroot/closure/src/imagelib In directory clnet:/tmp/cvs-serv3503 Added Files: gif.lisp jpeg.lisp Log Message: New files for the "organic" GIF support. --- /project/closure/cvsroot/closure/src/imagelib/gif.lisp 2007/01/03 16:09:13 NONE +++ /project/closure/cvsroot/closure/src/imagelib/gif.lisp 2007/01/03 16:09:13 1.1 ;;; gif.lisp --- render GIF files in Closure ;;; ;;; Author: Eric Marsden <eric.marsden(a)free.fr> ;; ;; ;; Read GIF files using the Skippy library ;; (http://www.xach.com/lisp/skippy/) and convert them to Closure's ;; internal AIMAGE format. (in-package :imagelib) (defgeneric flexi-stream-from (thing)) (defmethod flexi-stream-from ((thing cl:pathname)) (let ((data (make-array 1024 :element-type '(unsigned-byte 8) :fill-pointer 0 :adjustable t))) (with-open-file (in thing :direction :input :element-type '(unsigned-byte 8)) (loop :for b = (read-byte in nil nil) :while b :do (vector-push-extend b data))) (flexi-streams:make-in-memory-input-stream data))) (defmethod flexi-stream-from ((gstream glisp:gstream)) (let ((data (make-array 1024 :element-type '(unsigned-byte 8) :fill-pointer 0 :adjustable t))) (loop :for b = (g/read-byte gstream nil nil) :while b :do (vector-push-extend b data)) (g/close gstream) (flexi-streams:make-in-memory-input-stream data))) (defmethod flexi-stream-from ((stream flexi-streams:flexi-stream)) stream) (defmethod flexi-stream-from ((stream flexi-streams:in-memory-stream)) stream) (defun gif-stream->aimage (stream) (let* ((data-stream (skippy:read-data-stream (flexi-stream-from stream))) (image (skippy:last-image data-stream)) (gif-color-table (skippy:color-table data-stream)) (aimage (make-aimage (skippy:width image) (skippy:height image) :alpha-p nil)) (aimage-data (aimage-data aimage))) (dotimes (x (skippy:width image)) (dotimes (y (skippy:height image)) (multiple-value-bind (r g b) (skippy:color-rgb (skippy:color-table-entry gif-color-table (skippy:pixel-ref image x y))) (setf (aref aimage-data y x) (dpb r (byte 8 0) (dpb g (byte 8 8) (dpb b (byte 8 16) (dpb (- 255 0) (byte 8 24) 0)))))))) aimage)) ;; this is the historical version of GIF-STREAM->AIMAGE, that calls ;; the external program gif2png (defun gif-stream->aimage/gif2png (input) (with-temporary-file (temp-filename) (let ((png-filename (merge-pathnames (make-pathname :type "png") temp-filename))) (with-open-file (sink temp-filename :direction :output :if-exists :overwrite :element-type '(unsigned-byte 8)) (let ((sink (make-instance 'glisp:cl-byte-stream :cl-stream sink))) (let ((tmp (make-array 4096 :element-type '(unsigned-byte 8)))) (do ((n (g/read-byte-sequence tmp input) (g/read-byte-sequence tmp input))) ((= n 0)) (g/write-byte-sequence tmp sink :end n))))) (unwind-protect (progn (run-unix-shell-command (format nil "gif2png -r ~A >/dev/null 2>/dev/null" (namestring (truename temp-filename)))) (with-open-file (input png-filename :direction :input :element-type '(unsigned-byte 8)) (let ((i (make-instance 'cl-byte-stream :cl-stream input))) (png:png-stream->aimage i)))) (ignore-errors (mapc #'(lambda (x) (ignore-errors (delete-file x))) (directory (merge-pathnames (make-pathname :type :wild) temp-filename)))) )))) ;; EOF --- /project/closure/cvsroot/closure/src/imagelib/jpeg.lisp 2007/01/03 16:09:13 NONE +++ /project/closure/cvsroot/closure/src/imagelib/jpeg.lisp 2007/01/03 16:09:13 1.1 ;;; jpeg.lisp -- render JPEG files in Closure ;;; ;;; Author: Eric Marsden <eric.marsden(a)free.fr> ;; ;; ;; This will soon be replaced by an implementation based on cl-jpeg. (in-package :imagelib) (defun jpeg-stream->aimage (input) (any->aimage-by-filter "djpeg" input)) ;; EOF

1 0

[closure-cvs] CVS closure/src/parse
by emarsden 03 Jan '07

03 Jan '07

Update of /project/closure/cvsroot/closure/src/parse In directory clnet:/tmp/cvs-serv3355/src/parse Modified Files: pt.lisp Log Message: Reimplement the LHTML parser. The previous version could not handle forms like ((:a :href "/foo.html") "foo"). --- /project/closure/cvsroot/closure/src/parse/pt.lisp 2006/12/31 13:24:49 1.5 +++ /project/closure/cvsroot/closure/src/parse/pt.lisp 2007/01/03 16:07:25 1.6 @@ -148,7 +148,7 @@ (setf (pt-parent k) res)) res)) -(defun ppt (pt &optional (prefix "") (barp nil)) +(defun ppt (pt &optional (stream *standard-output*) (prefix "") (barp nil)) (cond ((eq (pt-name pt) :pcdata) (let ((s (map 'string #'(lambda (x) @@ -162,15 +162,16 @@ (setq s (concatenate 'string (subseq s 0 (- 120 (length prefix)))) flag t)) (write-string (format nil "~%~A| ~S ~A" prefix s - (if flag "..." ""))))) + (if flag "..." "")) stream))) (t - (write-string (format nil "~%~A| ~A" prefix (pt-name pt))) + (write-string (format nil "~%~A| ~A" prefix (pt-name pt)) stream) (when (pt-children pt) (write-string (format nil "~%~A~A-~A." prefix (if barp "+" "`") (make-string (length (symbol-name (pt-name pt))) - :initial-element #\- ))) + :initial-element #\- )) + stream) (let ((prefix1 (concatenate 'string prefix (if barp "|" " ") (make-string (length (symbol-name (pt-name pt))) @@ -178,7 +179,7 @@ " "))) (do ((q (pt-children pt) (cdr q))) ((null q)) - (ppt (car q) prefix1 (if (cdr q) 't 'nil)))))))) + (ppt (car q) stream prefix1 (if (cdr q) 't 'nil)))))))) ;;; ------------------------------------------------------------------------------------------- @@ -218,27 +219,33 @@ (cond ((null pt) nil) ((cons (pt-name pt) (pt-full-name-path (pt-parent pt)))))) -(defun lhtml->pt (tree) - (cond ((typep tree 'rod) - (sgml::make-pt :name :pcdata :attrs tree)) - ((stringp tree) - (sgml::make-pt :name :pcdata :attrs (string-rod tree))) - ((sgml::pt-p tree) tree) - ((and (consp tree) (keywordp (car tree))) - (let ((attrs nil) - (gi (car tree))) - (do ((q (cdr tree) (cddr q))) - ((or (null q) - (not (keywordp (car q)))) - (sgml::make-pt :name gi - :attrs (nreverse attrs) - :children (mapcar #'lhtml->pt q))) - (push (car q) attrs) - (push (rod (cadr q)) attrs)))) - (t - (error "~S does not look like LHTML." tree)) )) +(defun walk-lhtml (lhtml tag-callback text-callback) + (if (stringp lhtml) + (funcall text-callback lhtml) + (destructuring-bind (tag &rest body) + (if (consp lhtml) lhtml (list lhtml)) + (destructuring-bind (tag-name &rest attributes) + (if (consp tag) tag (list tag)) + (funcall tag-callback tag-name attributes body))))) + +(defun lhtml->pt (lhtml) + (walk-lhtml lhtml + ;; tag callback + (lambda (tag-name attributes body) + (make-pt :name tag-name + :attrs (loop :for (key value) :on attributes :by #'cddr + :collect key + :collect (etypecase value + (string (runes:string-rod value)) + (sgml::rod value))) + :children (mapcar #'lhtml->pt body))) + ;; text callback + (lambda (string) + (assert (stringp string)) + (make-pt :name :pcdata :attrs (runes:string-rod string))))) (defun lhtml-reader (stream subchar arg) + (declare (ignore subchar arg)) `(lhtml->pt ,(funcall (get-macro-character #\`) stream nil)))

1 0

[closure-cvs] CVS closure/src/renderer
by emarsden 03 Jan '07

03 Jan '07

Update of /project/closure/cvsroot/closure/src/renderer In directory clnet:/tmp/cvs-serv29995/src/renderer Modified Files: images.lisp Log Message: Load GIF images using the Skippy library, instead of the external application gif2png. Reorganize the image code in the process. --- /project/closure/cvsroot/closure/src/renderer/images.lisp 2005/07/17 09:38:54 1.3 +++ /project/closure/cvsroot/closure/src/renderer/images.lisp 2007/01/03 15:39:29 1.4 @@ -111,128 +111,14 @@ ((eq mime-type (netlib:find-mime-type "image/png")) (png:png-stream->aimage input)) ((eq mime-type (netlib:find-mime-type "image/gif")) - (let ((*print-array* nil)) - (gif-stream->aimage input))) - - ;; The rest simply goes to the appropriate ->ppm filters. + (imagelib:gif-stream->aimage input)) ((eq mime-type (netlib:find-mime-type "image/jpeg")) - (any->aimage-by-filter "djpeg" input)) + (imagelib:jpeg-stream->aimage input)) + ;; The rest simply goes to the appropriate ->ppm filters. ((eq mime-type (netlib:find-mime-type "image/x-xbitmap")) - (any->aimage-by-filter "xbmtopbm" input)) + (imagelib:any->aimage-by-filter "xbmtopbm" input)) ((eq mime-type (netlib:find-mime-type "image/x-xpixmap")) - (any->aimage-by-filter "xpmtoppm" input)) + (imagelib:any->aimage-by-filter "xpmtoppm" input)) ((eq mime-type (netlib:find-mime-type "image/tiff")) - (any->aimage-by-filter "tifftopnm" input)))) - -(defun gif-stream->aimage (input) - (with-temporary-file (temp-filename) - (let ((png-filename (merge-pathnames (make-pathname :type "png") - temp-filename))) - (with-open-file (sink temp-filename - :direction :output - :if-exists :overwrite - :element-type '(unsigned-byte 8)) - (let ((sink (make-instance 'glisp:cl-byte-stream :cl-stream sink))) - (let ((tmp (make-array 4096 :element-type '(unsigned-byte 8)))) - (do ((n (g/read-byte-sequence tmp input) - (g/read-byte-sequence tmp input))) - ((= n 0)) - (g/write-byte-sequence tmp sink :end n))))) - (unwind-protect - (progn - (run-unix-shell-command - (format nil "gif2png -r ~A >/dev/null 2>/dev/null" - (namestring (truename temp-filename)))) - (with-open-file (input png-filename - :direction :input - :element-type '(unsigned-byte 8)) - (let ((i (make-instance 'cl-byte-stream :cl-stream input))) - (png:png-stream->aimage i)))) - (ignore-errors - (mapc #'(lambda (x) (ignore-errors (delete-file x))) - (directory (merge-pathnames (make-pathname :type :wild) - temp-filename)))) )))) - -#+NIL -(defun gif-stream->aimage (input) - (imagelib.gif::read-gif-image input)) - -(defun any->aimage-by-filter (filter-name input) - (with-temporary-file (temp-filename) - (with-temporary-file (pnm-filename) - (with-open-file (sink temp-filename - :direction :output - :if-exists :overwrite - :element-type '(unsigned-byte 8)) - (let ((sink (make-instance 'glisp:cl-byte-stream :cl-stream sink))) - (let ((tmp (make-array 4096 :element-type '(unsigned-byte 8)))) - (do ((n (g/read-byte-sequence tmp input) - (g/read-byte-sequence tmp input))) - ((= n 0)) - (g/write-byte-sequence tmp sink :end n))))) - (let ((cmd (format nil "~A <~A >~A" filter-name - (namestring (truename temp-filename)) - (namestring pnm-filename)))) - (format *debug-io* "~%;; running: ~A" cmd) - (run-unix-shell-command cmd)) - (progn ;ignore-errors - (with-open-file (input pnm-filename - :direction :input - :element-type '(unsigned-byte 8)) - (pnm-stream->aimage - (make-instance 'cl-byte-stream :cl-stream input)))) ))) - -;;; Image writers - -(defun write-ppm-image (aimage sink) - ;; We write P3/P6 images - (let ((binary-p (subtypep (stream-element-type sink) '(unsigned-byte 8)))) - (let ((header - (with-output-to-string (bag) - (format bag "~A~%" (if binary-p "P6" "P3")) - (format bag "~D ~D ~D" (aimage-width aimage) (aimage-height aimage) 255)))) - (if binary-p - (write-sequence (map '(array (unsigned-byte 8) (*)) #'char-code header) sink) - (write-string header sink)) - (cond (binary-p - (write-byte 10 sink) - (let ((buffer (make-array (* 3 (aimage-width aimage)) :element-type '(unsigned-byte 8))) - (width (aimage-width aimage)) - (data (aimage-data aimage)) - (i 0)) - (declare (type (simple-array (unsigned-byte 8) (*)) buffer) - (type (array (unsigned-byte 32) (* *)) data) - (type fixnum width) - (type fixnum i)) - (dotimes (y (aimage-height aimage)) - (setf i 0) - (do ((x 0 (the fixnum (+ x 1)))) - ((= x width)) - (declare (type fixnum x)) - (let ((byte (aref data y x))) - (declare (type (unsigned-byte 8) byte)) - (setf (aref buffer i) (ldb (byte 8 0) byte)) - (setf i (the fixnum (+ i 1))) - (setf (aref buffer i) (ldb (byte 8 8) byte)) - (setf i (the fixnum (+ i 1))) - (setf (aref buffer i) (ldb (byte 8 16) byte)) - (setf i (the fixnum (+ i 1))))) - (write-sequence buffer sink)))) - (t - (dotimes (y (aimage-height aimage)) - (dotimes (x (aimage-width aimage)) - (when (= (mod x 4) 0) - (terpri sink)) - (let ((byte (aref (aimage-data aimage) y x))) - (format sink " ~D ~D ~D" - (ldb (byte 8 0) byte) - (ldb (byte 8 8) byte) - (ldb (byte 8 16) byte)) ))) - (terpri sink)))))) + (imagelib:any->aimage-by-filter "tifftopnm" input)))) -(defun blu (aimage) - (with-open-file (sink "/tmp/a.ppm" - :direction :output - :if-exists :new-version - :element-type '(unsigned-byte 8)) - (write-ppm-image aimage sink)))

1 0

[closure-cvs] CVS closure/src/imagelib
by emarsden 03 Jan '07

03 Jan '07

Update of /project/closure/cvsroot/closure/src/imagelib In directory clnet:/tmp/cvs-serv29995/src/imagelib Modified Files: package.lisp basic.lisp Log Message: Load GIF images using the Skippy library, instead of the external application gif2png. Reorganize the image code in the process. --- /project/closure/cvsroot/closure/src/imagelib/package.lisp 2006/12/31 11:48:18 1.4 +++ /project/closure/cvsroot/closure/src/imagelib/package.lisp 2007/01/03 15:39:29 1.5 @@ -39,10 +39,10 @@ #:aimage-plist #:make-aimage #:scale-aimage - #:pnm-stream->aimage)) - -(defpackage :imagelib.gif - (:use :cl :glisp :imagelib)) + #:gif-stream->aimage + #:jpeg-stream->aimage + #:pnm-stream->aimage + #:any->aimage-by-filter)) (defpackage :png (:use :cl :glisp :imagelib) --- /project/closure/cvsroot/closure/src/imagelib/basic.lisp 2005/03/13 18:02:00 1.3 +++ /project/closure/cvsroot/closure/src/imagelib/basic.lisp 2007/01/03 15:39:29 1.4 @@ -297,3 +297,83 @@ :alpha-p nil))) +(defun any->aimage-by-filter (filter-name input) + (with-temporary-file (temp-filename) + (with-temporary-file (pnm-filename) + (with-open-file (sink temp-filename + :direction :output + :if-exists :overwrite + :element-type '(unsigned-byte 8)) + (let ((sink (make-instance 'glisp:cl-byte-stream :cl-stream sink))) + (let ((tmp (make-array 4096 :element-type '(unsigned-byte 8)))) + (do ((n (g/read-byte-sequence tmp input) + (g/read-byte-sequence tmp input))) + ((= n 0)) + (g/write-byte-sequence tmp sink :end n))))) + (let ((cmd (format nil "~A <~A >~A" filter-name + (namestring (truename temp-filename)) + (namestring pnm-filename)))) + (format *debug-io* "~%;; running: ~A" cmd) + (run-unix-shell-command cmd)) + (progn ;ignore-errors + (with-open-file (input pnm-filename + :direction :input + :element-type '(unsigned-byte 8)) + (pnm-stream->aimage + (make-instance 'cl-byte-stream :cl-stream input)))) ))) + + +;;; Image writers + +(defun write-ppm-image (aimage sink) + ;; We write P3/P6 images + (let ((binary-p (subtypep (stream-element-type sink) '(unsigned-byte 8)))) + (let ((header + (with-output-to-string (bag) + (format bag "~A~%" (if binary-p "P6" "P3")) + (format bag "~D ~D ~D" (aimage-width aimage) (aimage-height aimage) 255)))) + (if binary-p + (write-sequence (map '(array (unsigned-byte 8) (*)) #'char-code header) sink) + (write-string header sink)) + (cond (binary-p + (write-byte 10 sink) + (let ((buffer (make-array (* 3 (aimage-width aimage)) :element-type '(unsigned-byte 8))) + (width (aimage-width aimage)) + (data (aimage-data aimage)) + (i 0)) + (declare (type (simple-array (unsigned-byte 8) (*)) buffer) + (type (array (unsigned-byte 32) (* *)) data) + (type fixnum width) + (type fixnum i)) + (dotimes (y (aimage-height aimage)) + (setf i 0) + (do ((x 0 (the fixnum (+ x 1)))) + ((= x width)) + (declare (type fixnum x)) + (let ((byte (aref data y x))) + (declare (type (unsigned-byte 8) byte)) + (setf (aref buffer i) (ldb (byte 8 0) byte)) + (setf i (the fixnum (+ i 1))) + (setf (aref buffer i) (ldb (byte 8 8) byte)) + (setf i (the fixnum (+ i 1))) + (setf (aref buffer i) (ldb (byte 8 16) byte)) + (setf i (the fixnum (+ i 1))))) + (write-sequence buffer sink)))) + (t + (dotimes (y (aimage-height aimage)) + (dotimes (x (aimage-width aimage)) + (when (= (mod x 4) 0) + (terpri sink)) + (let ((byte (aref (aimage-data aimage) y x))) + (format sink " ~D ~D ~D" + (ldb (byte 8 0) byte) + (ldb (byte 8 8) byte) + (ldb (byte 8 16) byte)) ))) + (terpri sink)))))) + +(defun blu (aimage) + (with-open-file (sink "/tmp/a.ppm" + :direction :output + :if-exists :new-version + :element-type '(unsigned-byte 8)) + (write-ppm-image aimage sink)))

1 0

[closure-cvs] CVS closure
by emarsden 03 Jan '07

03 Jan '07

Update of /project/closure/cvsroot/closure In directory clnet:/tmp/cvs-serv29995 Modified Files: closure.asd Log Message: Load GIF images using the Skippy library, instead of the external application gif2png. Reorganize the image code in the process. --- /project/closure/cvsroot/closure/closure.asd 2007/01/02 14:30:11 1.16 +++ /project/closure/cvsroot/closure/closure.asd 2007/01/03 15:39:28 1.17 @@ -89,7 +89,8 @@ :bordeaux-threads :trivial-sockets :zip - :flexi-streams) + :flexi-streams + :skippy) :default-component-class closure-source-file :components ((:module src @@ -99,7 +100,7 @@ (:module patches :components ((:file "clx-patch"))) - + ;; Images (:module imagelib @@ -108,12 +109,14 @@ ((:file "package") (:file "basic") (:file "deflate") - (:file "png"))) + (:file "png") + (:file "gif") + (:file "jpeg"))) ;; Early package definitions (:file "defpack") - + ;; Closure Protocol Declarations first (:module protocols

1 0

[closure-cvs] CVS closure/src/glisp
by emarsden 03 Jan '07

03 Jan '07

Update of /project/closure/cvsroot/closure/src/glisp In directory clnet:/tmp/cvs-serv1214/src/glisp Modified Files: dep-sbcl.lisp Log Message: GUI: implement beginning-of-page and end-of-page commands; add keyboard shortcuts for back & forward. --- /project/closure/cvsroot/closure/src/glisp/dep-sbcl.lisp 2007/01/02 13:12:58 1.8 +++ /project/closure/cvsroot/closure/src/glisp/dep-sbcl.lisp 2007/01/03 11:34:45 1.9 @@ -33,7 +33,7 @@ (apply #'read-sequence ap)) (defmacro glisp::with-timeout ((&rest options) &body body) - (declare (ignore ignore)) + (declare (ignore options)) `(progn ,@body))

1 0

[closure-cvs] CVS closure/src/gui
by emarsden 03 Jan '07

03 Jan '07

Update of /project/closure/cvsroot/closure/src/gui In directory clnet:/tmp/cvs-serv1214/src/gui Modified Files: clim-gui.lisp Log Message: GUI: implement beginning-of-page and end-of-page commands; add keyboard shortcuts for back & forward. --- /project/closure/cvsroot/closure/src/gui/clim-gui.lisp 2006/12/31 15:42:40 1.27 +++ /project/closure/cvsroot/closure/src/gui/clim-gui.lisp 2007/01/03 11:34:45 1.28 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann <gilbert(a)base-engineering.com> ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.27 2006/12/31 15:42:40 dlichteblau Exp $ +;;; $Id: clim-gui.lisp,v 1.28 2007/01/03 11:34:45 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,7 +28,12 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.28 2007/01/03 11:34:45 emarsden +;; GUI: implement beginning-of-page and end-of-page commands; add +;; keyboard shortcuts for back & forward. +;; ;; Revision 1.27 2006/12/31 15:42:40 dlichteblau +;; ;; Use Bordeaux Threads for all threading primitives, so that non-GUI parts of ;; Closure don't have to depend on CLIM anymore. ;; @@ -364,7 +369,7 @@ (define-closure-command (com-reflow :name t) () (reflow)) -(define-closure-command (com-back :name t) () +(define-closure-command (com-back :name t :keystroke (:left :control)) () (let ((*standard-output* *query-io*)) (cond ((null (cdr *back-history*)) (format t "There is nowhere you can go back to.~%")) @@ -373,8 +378,8 @@ (format t "Going back to ~S.~%" (first *back-history*)) (foo (first *back-history*)))))) -(define-closure-command (com-forward :name t) () - (let ((*standard-output* *query-io*)) +(define-closure-command (com-forward :name t :keystroke (:right :control)) () + (let ((*standard-output* *query-io*)) (cond ((null *forw-history*) (format t "There is nowhere you can go forward to.~%")) (t @@ -398,7 +403,7 @@ (setf gui:*user-wants-images-p* t) (format *query-io* "Images are now on. You may want to reload.~%")) -(define-closure-command (com-quit :name t) () +(define-closure-command (com-quit :name t :keystroke (#\q :control)) () (frame-exit *application-frame*)) (defun make-google-search-url (string) @@ -561,9 +566,8 @@ (lambda () (with-simple-restart (forget "Just forget rendering this page.") (let* ((*package* (find-package :r2)) - (*pane* (find-pane-named *frame* 'canvas)) - (*medium* (sheet-medium *pane*))) - (progn ;; with-sheet-medium (*medium* *pane*) + (*pane* (find-pane-named *frame* 'canvas))) + (with-sheet-medium (*medium* *pane*) (let ((device (make-instance 'closure/clim-device::clim-device :medium *pane*))) (setf (sheet-pointer-cursor *pane*) :busy) (setq url (r2::parse-url* url)) @@ -664,13 +668,12 @@ (setq gui:*zoom-factor* 1.0) (send-closure-command 'com-reflow)) -;; FIXME the :shift here is a McCLIM bug -(define-closure-command (com-zoom-in :name t :keystroke (#\+ :control :shift)) () +(define-closure-command (com-zoom-in :name t :keystroke (#\+ :control)) () (write-status "Zooming in...") (setq gui:*zoom-factor* (* gui:*zoom-factor* 1.2)) (send-closure-command 'com-reflow)) -(define-closure-command (com-zoom-out :name t :keystroke (#\- :control :shift)) () +(define-closure-command (com-zoom-out :name t :keystroke (#\- :control)) () (write-status "Zooming out...") (setq gui:*zoom-factor* (* gui:*zoom-factor* 0.8)) (send-closure-command 'com-reflow)) @@ -692,6 +695,18 @@ (scroll-extent pane 0 (min (gadget-max-value scrollbar) (+ current-y (* 0.9 window-height)))))) +(define-closure-command (com-beginning-of-page :name t + :keystroke (:home :control)) () + (let* ((pane (find-pane-named *frame* 'canvas)) + (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar))) + (scroll-extent pane 0 (gadget-min-value scrollbar)))) + +(define-closure-command (com-end-of-page :name t + :keystroke (:end :control)) () + (let* ((pane (find-pane-named *frame* 'canvas)) + (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar))) + (scroll-extent pane 0 (gadget-max-value scrollbar)))) + (define-closure-command (com-redraw :name t :keystroke (#\r :control)) () (let* ((*pane* (find-pane-named *frame* 'canvas)) ) (handle-repaint *pane* (sheet-region (pane-viewport *pane*))))

1 0

[closure-cvs] CVS closure/src/net
by dlichteblau 02 Jan '07

02 Jan '07

Update of /project/closure/cvsroot/closure/src/net In directory clnet:/tmp/cvs-serv13003/src/net Modified Files: http.lisp Log Message: Use the ZIP library instead of run-shell-command for the zip:// protocol. --- /project/closure/cvsroot/closure/src/net/http.lisp 2007/01/02 13:13:03 1.11 +++ /project/closure/cvsroot/closure/src/net/http.lisp 2007/01/02 14:30:11 1.12 @@ -959,39 +959,33 @@ ;; </FUTURE> ;; Back to what is actually implemented. To read a document from within a zip -;; archive, we simply pass the request to the `unzip' command. So you must -;; have installed this for a working zip protocol. +;; archive, we simply use the ZIP library. So you must have it installed +;; for a working zip protocol. ;; TODO ;; - detect non-existing archives and non-existing archive documents. ;; - when no archive file name is given, attempt to format the zip file ;; directory as HTML, to be able to inspect the zip file. -;; - detect the non-existence of the `unzip' command and give a reasonable -;; error message. (defun open-zip-document (url) - (multiple-value-bind (zip-archive-pathname archive-component-file-name) (split-zip-url url) - (cond ((null zip-archive-pathname) - (error "Bad zip url: ~S" url)) - (t - (with-temporary-file (temp-filename) - (let ((res (run-unix-shell-command (format nil "unzip -p ~A ~A >~A" - (namestring zip-archive-pathname) - archive-component-file-name - temp-filename)))) - (cond ((zerop res) - (values - (cl-byte-stream->gstream (open temp-filename - :direction :input - :element-type '(unsigned-byte 8))) - (list (cons "Content-Type" - (let ((mt (find-mime-type-from-extension - (url-extension url)))) - (if mt - (mime-type-name mt) - "text/plain")))))) - (t - (error "unzip failed on ~S" url)) ))))))) + (multiple-value-bind (zip-archive-pathname archive-component-file-name) + (split-zip-url url) + (cond + ((null zip-archive-pathname) + (error "Bad zip url: ~S" url)) + (t + (values + (cl-byte-stream->gstream + (flexi-streams:make-in-memory-input-stream + (zip:with-zipfile (zip zip-archive-pathname) + (zip:zipfile-entry-contents + (zip:get-zipfile-entry archive-component-file-name zip))))) + (list (cons "Content-Type" + (let ((mt (find-mime-type-from-extension + (url-extension url)))) + (if mt + (mime-type-name mt) + "text/plain"))))))))) (defun split-zip-url (url) ;; -> zip-archive-pathname ; archive-component-file-name

1 0