From emarsden at common-lisp.net Sun Jul 10 10:36:04 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 10 Jul 2005 12:36:04 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/imagelib/png.lisp Message-ID: <20050710103604.EB88D884CA@common-lisp.net> Update of /project/closure/cvsroot/closure/src/imagelib In directory common-lisp.net:/tmp/cvs-serv26893 Modified Files: png.lisp Log Message: Move constant definition before its use. Date: Sun Jul 10 12:36:04 2005 Author: emarsden Index: closure/src/imagelib/png.lisp diff -u closure/src/imagelib/png.lisp:1.4 closure/src/imagelib/png.lisp:1.5 --- closure/src/imagelib/png.lisp:1.4 Sun Mar 13 19:02:01 2005 +++ closure/src/imagelib/png.lisp Sun Jul 10 12:36:03 2005 @@ -52,6 +52,9 @@ (defvar *png-magic* '#(137 80 78 71 13 10 26 10) "The first eight bytes of a png file.") +;; largest prime smaller than 65536 +(defconstant *adler-base* 65521) + (defstruct png-image ihdr idat @@ -675,9 +678,6 @@ ;; (funcall cont buf 0 blen))) ) (setf (zlib-stream-bptr zlib-stream) 0))) - -;; largest prime smaller than 65536 -(defconstant *adler-base* 65521) (defun update-adler32-one (adler byte) (let ((s1 (ldb (byte 16 0) adler)) From emarsden at common-lisp.net Sun Jul 10 10:37:54 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 10 Jul 2005 12:37:54 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/xml/xml-parse.lisp Message-ID: <20050710103754.2C962884CA@common-lisp.net> Update of /project/closure/cvsroot/closure/src/xml In directory common-lisp.net:/tmp/cvs-serv26925 Modified Files: xml-parse.lisp Log Message: Fix trivial bugs in debug output. Date: Sun Jul 10 12:37:53 2005 Author: emarsden Index: closure/src/xml/xml-parse.lisp diff -u closure/src/xml/xml-parse.lisp:1.4 closure/src/xml/xml-parse.lisp:1.5 --- closure/src/xml/xml-parse.lisp:1.4 Tue Jul 8 17:41:48 2003 +++ closure/src/xml/xml-parse.lisp Sun Jul 10 12:37:53 2005 @@ -2304,8 +2304,6 @@ (format t "~&**** Test failed on ~S." filename) (fresh-line) (format t "** me: ~A" res) - (fresh-line) - (format t "** he: " res) (finish-output) (with-open-file (in out-filename :direction :input :element-type 'character) (do ((c (read-char in nil nil) (read-char in nil nil))) @@ -2520,7 +2518,7 @@ (unless e (error "Entity '~A' is not defined." (rod-string name))) (unless (eq :internal (cadr e)) - (error "Entity '~A' is not an internal entity.")) + (error "Entity '~A' is not an internal entity." (rod-string name))) (or (cadddr e) (car (setf (cdddr e) From emarsden at common-lisp.net Sun Jul 10 10:57:21 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 10 Jul 2005 12:57:21 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/defpack.lisp Message-ID: <20050710105721.E7C91884CA@common-lisp.net> Update of /project/closure/cvsroot/closure/src In directory common-lisp.net:/tmp/cvs-serv27902 Modified Files: defpack.lisp Log Message: Move a number of global variables from the CL-USER to the GUI package. Date: Sun Jul 10 12:57:19 2005 Author: emarsden Index: closure/src/defpack.lisp diff -u closure/src/defpack.lisp:1.3 closure/src/defpack.lisp:1.4 --- closure/src/defpack.lisp:1.3 Sun Mar 13 19:00:56 2005 +++ closure/src/defpack.lisp Sun Jul 10 12:57:19 2005 @@ -126,6 +126,14 @@ #:make-rectangle*) (:export + #:*home-page* + #:*user-wants-images-p* + #:*tex-mode-p* + #:*hyphenate-p* + #:*closure-dpi* + #:*zoom-factor* + #:*debug-submit-p* + #:display-list #:display-list-p #:display-list-document From emarsden at common-lisp.net Sun Jul 10 10:57:21 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 10 Jul 2005 12:57:21 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/gui/clim-gui.lisp closure/src/gui/clue-input.lisp closure/src/gui/gui.lisp Message-ID: <20050710105721.1ADAC88543@common-lisp.net> Update of /project/closure/cvsroot/closure/src/gui In directory common-lisp.net:/tmp/cvs-serv27902/gui Modified Files: clim-gui.lisp clue-input.lisp gui.lisp Log Message: Move a number of global variables from the CL-USER to the GUI package. Date: Sun Jul 10 12:57:20 2005 Author: emarsden Index: closure/src/gui/clim-gui.lisp diff -u closure/src/gui/clim-gui.lisp:1.17 closure/src/gui/clim-gui.lisp:1.18 --- closure/src/gui/clim-gui.lisp:1.17 Tue Apr 12 12:28:55 2005 +++ closure/src/gui/clim-gui.lisp Sun Jul 10 12:57:20 2005 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.17 2005/04/12 10:28:55 tdalyjr Exp $ +;;; $Id: clim-gui.lisp,v 1.18 2005/07/10 10:57:20 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,6 +28,9 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.18 2005/07/10 10:57:20 emarsden +;; Move a number of global variables from the CL-USER to the GUI package. +;; ;; Revision 1.17 2005/04/12 10:28:55 tdalyjr ;; Since closure-frame-top-level is no longer used, comment it out. ;; @@ -101,13 +104,11 @@ ;;;;;;; (defvar *medium*) +(defvar *frame*) +(defvar *pane*) (defvar *initial-url* nil) -(defvar closure:*home-page* "http://www.stud.uni-karlsruhe.de/~unk6/closure/user.html") -(defvar closure:*user-wants-images-p* t) -(defvar closure::*zoom-factor* 1.0) - (defvar *closure-process* nil) (defclass closure-pane (application-pane) @@ -337,11 +338,11 @@ (foo (first *back-history*)))))) (define-closure-command (com-images-off :name t) () - (setf closure:*user-wants-images-p* nil) + (setf gui:*user-wants-images-p* nil) (format *query-io* "Images are now off.~%")) (define-closure-command (com-images-on :name t) () - (setf closure:*user-wants-images-p* t) + (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) () @@ -364,7 +365,7 @@ (com-visit-url (make-google-search-url what))) (define-closure-command (com-home :name t) () - (com-visit-url closure:*home-page*)) + (com-visit-url gui:*home-page*)) (define-presentation-translator fofo (url command closure @@ -420,7 +421,7 @@ #'(lambda () (apply command args))))) -(defun closure:visit (&optional (url closure:*home-page*)) +(defun closure:visit (&optional (url gui:*home-page*)) (and url (setf url (parse-url* url))) (cond ((and (null *closure-process*) (null url)) (setf *initial-url* url) @@ -453,9 +454,6 @@ *closure-inited-p*))))) -(defvar *frame*) -(defvar *pane*) - (defun run-closure () ;; Care for proxy (let* ((proxy (glisp:getenv "http_proxy")) @@ -651,18 +649,18 @@ (define-closure-command (com-zoom-100% :name t) () - (setq closure::*zoom-factor* 1.0) + (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)) () (write-status "Zooming in...") - (setq closure::*zoom-factor* (* closure::*zoom-factor* 1.2)) + (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)) () (write-status "Zooming out...") - (setq closure::*zoom-factor* (* closure::*zoom-factor* 0.8)) + (setq gui:*zoom-factor* (* gui:*zoom-factor* 0.8)) (send-closure-command 'com-reflow)) (define-closure-command (com-page-up :name t Index: closure/src/gui/clue-input.lisp diff -u closure/src/gui/clue-input.lisp:1.4 closure/src/gui/clue-input.lisp:1.5 --- closure/src/gui/clue-input.lisp:1.4 Sun Mar 13 19:01:37 2005 +++ closure/src/gui/clue-input.lisp Sun Jul 10 12:57:20 2005 @@ -45,9 +45,6 @@ (in-package :CLUE-GUI2) -(defparameter cl-user::*debug-submit-p* nil - "Whether to dump the values about to be submit by a
to the server on the listener.") - ;;; Input elements ;; Input elements as such are replaced objects and obey to the robj Index: closure/src/gui/gui.lisp diff -u closure/src/gui/gui.lisp:1.5 closure/src/gui/gui.lisp:1.6 --- closure/src/gui/gui.lisp:1.5 Sun Mar 13 19:01:37 2005 +++ closure/src/gui/gui.lisp Sun Jul 10 12:57:20 2005 @@ -43,6 +43,23 @@ (in-package :GUI) +(defparameter *home-page* "http://common-lisp.net/project/closure/") + +(defvar *user-wants-images-p* t) + +(defvar *closure-dpi* 96) + +(defvar *zoom-factor* 1.0) + +(defparameter *debug-submit-p* nil + "Whether to dump the values about to be submit by a to the server on the listener.") + +;; experimental code that is not activated by default +(defvar *tex-mode-p* nil) +(defvar *hyphenate-p* nil) + + + (defstruct display-list document items) From emarsden at common-lisp.net Sun Jul 10 10:57:23 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 10 Jul 2005 12:57:23 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/html/html-style.lisp Message-ID: <20050710105723.72CBB884CA@common-lisp.net> Update of /project/closure/cvsroot/closure/src/html In directory common-lisp.net:/tmp/cvs-serv27902/html Modified Files: html-style.lisp Log Message: Move a number of global variables from the CL-USER to the GUI package. Date: Sun Jul 10 12:57:21 2005 Author: emarsden Index: closure/src/html/html-style.lisp diff -u closure/src/html/html-style.lisp:1.5 closure/src/html/html-style.lisp:1.6 --- closure/src/html/html-style.lisp:1.5 Mon Jun 13 12:14:22 2005 +++ closure/src/html/html-style.lisp Sun Jul 10 12:57:21 2005 @@ -484,7 +484,7 @@ elm) (declare (ignorable language user-agent)) (values-list - (cond ((and (not closure:*user-wants-images-p*) + (cond ((and (not gui:*user-wants-images-p*) (member (element-gi elm) '(:IMG))) nil) ((member (element-gi elm) '(:IMG)) From emarsden at common-lisp.net Sun Jul 10 10:57:24 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 10 Jul 2005 12:57:24 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/renderer/x11.lisp Message-ID: <20050710105724.81E5888548@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv27902/renderer Modified Files: x11.lisp Log Message: Move a number of global variables from the CL-USER to the GUI package. Date: Sun Jul 10 12:57:23 2005 Author: emarsden Index: closure/src/renderer/x11.lisp diff -u closure/src/renderer/x11.lisp:1.6 closure/src/renderer/x11.lisp:1.7 --- closure/src/renderer/x11.lisp:1.6 Sun Mar 13 19:03:25 2005 +++ closure/src/renderer/x11.lisp Sun Jul 10 12:57:23 2005 @@ -952,9 +952,8 @@ (defclass x11-device () ((font-database :initform nil) (display :initarg :display) - (dpi :initarg :dpi :initform cl-user::*closure-dpi*) - (scale-font-desc-cache :initform (make-hash-table :test #'equal)) - )) + (dpi :initarg :dpi :initform gui:*closure-dpi*) + (scale-font-desc-cache :initform (make-hash-table :test #'equal)))) (defmethod r2::device-dpi ((self x11-device)) (slot-value self 'dpi)) From emarsden at common-lisp.net Sun Jul 10 11:18:35 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 10 Jul 2005 13:18:35 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/gui/clim-gui.lisp Message-ID: <20050710111835.0E845884CA@common-lisp.net> Update of /project/closure/cvsroot/closure/src/gui In directory common-lisp.net:/tmp/cvs-serv29764/gui Modified Files: clim-gui.lisp Log Message: Distinguish between pane and medium in the CLIM GUI. This should fix image display. Date: Sun Jul 10 13:18:34 2005 Author: emarsden Index: closure/src/gui/clim-gui.lisp diff -u closure/src/gui/clim-gui.lisp:1.18 closure/src/gui/clim-gui.lisp:1.19 --- closure/src/gui/clim-gui.lisp:1.18 Sun Jul 10 12:57:20 2005 +++ closure/src/gui/clim-gui.lisp Sun Jul 10 13:18:34 2005 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.18 2005/07/10 10:57:20 emarsden Exp $ +;;; $Id: clim-gui.lisp,v 1.19 2005/07/10 11:18:34 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.19 2005/07/10 11:18:34 emarsden +;; Distinguish between pane and medium in the CLIM GUI. This should +;; fix image display. +;; ;; Revision 1.18 2005/07/10 10:57:20 emarsden ;; Move a number of global variables from the CL-USER to the GUI package. ;; @@ -124,6 +128,7 @@ (:menu-bar menubar-command-table) (:panes (canvas (make-pane 'closure-pane + :name 'canvas :height 2000 :width 800 :display-time nil)) @@ -460,10 +465,10 @@ (url (and proxy (url:parse-url proxy)))) (cond ((and url (equal (url:url-protocol url) "http")) - (format t "~&;; Using HTTP proxy ~S port ~S~%" + (format t "~:[~&;; Using HTTP proxy ~S port ~S~%~;~]" + (setf netlib::*use-http-proxy-p* t) (setf netlib::*http-proxy-host* (url:url-host url)) - (setf netlib::*http-proxy-port* (url:url-port url)) - (setf netlib::*use-http-proxy-p* t))) + (setf netlib::*http-proxy-port* (url:url-port url)))) (t ;; we go without one: (setf netlib::*use-http-proxy-p* nil)))) @@ -507,76 +512,74 @@ (clim-sys:make-process (lambda () (with-simple-restart (forget "Just forget rendering this page.") - (let ((*package* (find-package :r2))) - (window-clear (find-pane-named *frame* 'canvas)) - (progn;;with-sheet-medium (medium *pane*) - (let ((*medium* (find-pane-named *frame* 'canvas))) - (let ((device (make-instance 'closure/clim-device::clim-device :medium *medium*))) - (setq url (r2::parse-url* url)) - (let ((request (clue-gui2::make-request :url url :method :get))) - (multiple-value-bind (io header) (clue-gui2::open-document-4 request) - (write-status "Fetching Document ...") - (let* ((doc (make-instance 'r2::document - :processes-hooks nil - :location - (r2::parse-url* url) - :http-header header - :pt (clue-gui2::make-pt-from-input - io - (netlib::get-header-field header :content-type) url) ))) - (write-status "Rendering ...") - (setf *current-document* doc) - (let ((closure-protocol:*document-language* - (if (sgml::pt-p (r2::document-pt doc)) - (make-instance 'r2::html-4.0-document-language) - (make-instance 'r2::xml-style-document-language) - )) - (closure-protocol:*user-agent* - nil) - (r2::*canvas-width* - (bounding-rectangle-width (sheet-parent *medium*)))) - (closure-protocol:render - closure-protocol:*document-language* - doc - device - (setf *current-pt* (r2::document-pt doc)) - 600 ;xxx width - t ;? - 0) - (let ((x2 (bounding-rectangle-max-x (stream-output-history (find-pane-named *frame* 'canvas)))) - (y2 (bounding-rectangle-max-y (stream-output-history (find-pane-named *frame* 'canvas))))) - (setf y2 (max y2 r2::*document-height*)) - (clim:change-space-requirements *medium* :width x2 :height y2) - ;; While we are at it, force a repaint - (handle-repaint *medium* (sheet-region (pane-viewport *medium*))) - (xlib:display-finish-output (clim-clx::clx-port-display (find-port))) ))))) - (write-status "Done.")))))) - (xlib:display-finish-output (clim-clx::clx-port-display (find-port))))))) + (let* ((*package* (find-package :r2)) + (*pane* (find-pane-named *frame* 'canvas)) + (*medium* (sheet-medium *pane*))) + (window-clear *pane*) + (progn ;; with-sheet-medium (*medium* *pane*) + (let ((device (make-instance 'closure/clim-device::clim-device :medium *pane*))) + (setq url (r2::parse-url* url)) + (let ((request (clue-gui2::make-request :url url :method :get))) + (multiple-value-bind (io header) (clue-gui2::open-document-4 request) + (write-status "Fetching Document ...") + (let* ((doc (make-instance 'r2::document + :processes-hooks nil + :location + (r2::parse-url* url) + :http-header header + :pt (clue-gui2::make-pt-from-input + io + (netlib::get-header-field header :content-type) url) ))) + (write-status "Rendering ...") + (setf *current-document* doc) + (let ((closure-protocol:*document-language* + (if (sgml::pt-p (r2::document-pt doc)) + (make-instance 'r2::html-4.0-document-language) + (make-instance 'r2::xml-style-document-language))) + (closure-protocol:*user-agent* nil) + (r2::*canvas-width* (bounding-rectangle-width (sheet-parent *pane*)))) + (closure-protocol:render + closure-protocol:*document-language* + doc + device + (setf *current-pt* (r2::document-pt doc)) + 600 ;xxx width + t ;? + 0) + (let ((x2 (bounding-rectangle-max-x (stream-output-history *pane*))) + (y2 (bounding-rectangle-max-y (stream-output-history *pane*)))) + (setf y2 (max y2 r2::*document-height*)) + (clim:change-space-requirements *pane* :width x2 :height y2) + ;; While we are at it, force a repaint + (handle-repaint *pane* (sheet-region (pane-viewport *pane*))) + (xlib:display-finish-output (clim-clx::clx-port-display (find-port)))))))) + #+nil (write-status "Done."))))) + #+nil (xlib:display-finish-output (clim-clx::clx-port-display (find-port))))))) (defun reflow () (let ((*standard-output* *trace-output*)) (funcall ;;clim-sys:make-process (lambda () (with-simple-restart (forget "Just forget rendering this page.") - (let ((*package* (find-package :r2))) - (window-clear (find-pane-named *frame* 'canvas)) - (let* ((*medium* (find-pane-named *frame* 'canvas)) ) + (let ((*package* (find-package :r2)) + (*pane* (find-pane-named *frame* 'canvas))) + (window-clear *pane*) + (with-sheet-medium (*medium* *pane*) (write-status "Rendering ...") (let ((closure-protocol:*document-language* (if (sgml::pt-p (r2::document-pt *current-document*)) (make-instance 'r2::html-4.0-document-language) (make-instance 'r2::xml-style-document-language) )) - (closure-protocol:*user-agent* - nil) + (closure-protocol:*user-agent* nil) (r2::*canvas-width* - (bounding-rectangle-width (sheet-parent *medium*)))) + (bounding-rectangle-width (sheet-parent *pane*)))) (r2::reflow) - (let ((x2 (bounding-rectangle-max-x (stream-output-history (find-pane-named *frame* 'canvas)))) - (y2 (bounding-rectangle-max-y (stream-output-history (find-pane-named *frame* 'canvas))))) + (let ((x2 (bounding-rectangle-max-x (stream-output-history *pane*))) + (y2 (bounding-rectangle-max-y (stream-output-history *pane*)))) (setf y2 (max y2 r2::*document-height*)) - (clim:change-space-requirements *medium* :width x2 :height y2) + (clim:change-space-requirements *pane* :width x2 :height y2) ;; While we are at it, force a repaint - (handle-repaint *medium* (sheet-region (pane-viewport *medium*))))) + (handle-repaint *pane* (sheet-region (pane-viewport *pane*))))) (write-status "Done.")))))))) (defvar *current-document*) From emarsden at common-lisp.net Sun Jul 10 11:18:36 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 10 Jul 2005 13:18:36 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/renderer/clim-device.lisp closure/src/renderer/renderer2.lisp Message-ID: <20050710111836.EB97588525@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv29764/renderer Modified Files: clim-device.lisp renderer2.lisp Log Message: Distinguish between pane and medium in the CLIM GUI. This should fix image display. Date: Sun Jul 10 13:18:35 2005 Author: emarsden Index: closure/src/renderer/clim-device.lisp diff -u closure/src/renderer/clim-device.lisp:1.10 closure/src/renderer/clim-device.lisp:1.11 --- closure/src/renderer/clim-device.lisp:1.10 Mon Jun 20 17:37:33 2005 +++ closure/src/renderer/clim-device.lisp Sun Jul 10 13:18:35 2005 @@ -31,7 +31,7 @@ (defclass clim-device () ((medium :accessor clim-device-medium :initarg :medium) (font-database :initform nil) - (zoom-factor :initform closure::*zoom-factor* :initarg :zoom-factor))) + (zoom-factor :initform gui:*zoom-factor* :initarg :zoom-factor))) (defmethod device-dpi ((device clim-device)) (with-slots (zoom-factor) device @@ -221,6 +221,7 @@ res)) (defun background-pixmap+mask (document drawable bg) + #+emarsden2005-06-23 (print `(background-pixmap+mask ,bg)) (cond ((r2::background-%pixmap bg) ;; already there @@ -243,6 +244,62 @@ (values (r2::background-%pixmap bg) (r2::background-%mask bg)))))) )) +(defun ws/x11::x11-put-pixmap-tiled (drawable ggc pixmap mask x y w h &optional (xo 0) (yo 0)) + (cond ((null mask) ;; xxx + (xlib:with-gcontext (ggc :exposures :off + :fill-style :tiled + :tile pixmap + :ts-x xo + :ts-y yo) + ;;mask wird momentan noch ignoriert! + (xlib:draw-rectangle drawable ggc x y w h t))) + (t + (let* ((old-clip-mask (car (or (ignore-errors (list (xlib:gcontext-clip-mask ggc))) + (list :none)))) + (clip-region (let ((q old-clip-mask)) + (if (consp q) + (region-from-x11-rectangle-list q) + +everywhere+))) + (paint-region (region-intersection + clip-region + (make-rectangle* x y (+ x w) (+ y h)))) ) + ;; There is a bug in CLX wrt to clip-x / clip-y + ;; Turning off caching helps + (setf (xlib:gcontext-cache-p ggc) nil) + + ;; we have to do our own clipping here. + (let ((iw (xlib:drawable-width pixmap)) + (ih (xlib:drawable-height pixmap))) + (loop for i from (floor (- x xo) iw) to (ceiling (- (+ x w) (+ xo iw)) iw) + do + (loop for j from (floor (- y yo) ih) to (ceiling (- (+ y h) (+ yo ih)) ih) + do + (let ((rect (make-rectangle* + (+ xo (* i iw)) + (+ yo (* j ih)) + (+ (+ xo (* i iw)) iw) + (+ (+ yo (* j ih)) ih)))) + (map-region-rectangles + (lambda (rx0 ry0 rx1 ry1) + (xlib:with-gcontext (ggc :exposures :off + :fill-style :tiled + :tile pixmap + :clip-mask mask + :clip-x (+ xo (* i iw)) + :clip-y (+ yo (* j ih)) + :ts-x xo + :ts-y yo) + (xlib:draw-rectangle drawable ggc + rx0 ry0 (max 0 (- rx1 rx0)) (max 0 (- ry1 ry0)) + t))) + (region-intersection paint-region rect))))) ) + ;; turn on caching again (see above) + (setf (xlib:gcontext-cache-p ggc) t) + ;; + ;; and xlib:with-gcontext also is broken! + (setf (xlib:gcontext-clip-mask ggc) old-clip-mask))))) + +#+emarsden #.((lambda (x) #+:CMU `(eval ',x) ;compiler bug #-:CMU x) @@ -396,8 +453,8 @@ (+ x (nth-value 0 (r2::ro/size ro))) (+ y 0))) -(defmethod medium-draw-ro* (medium (self ro/img) x y) - (ignore-errors ;xxx +(defmethod medium-draw-ro* ((medium clim:medium) (self ro/img) x y) + (progn ;; ignore-errors ;xxx (progn (assert (realp x)) (assert (realp y)) Index: closure/src/renderer/renderer2.lisp diff -u closure/src/renderer/renderer2.lisp:1.7 closure/src/renderer/renderer2.lisp:1.8 --- closure/src/renderer/renderer2.lisp:1.7 Sun Mar 13 19:03:25 2005 +++ closure/src/renderer/renderer2.lisp Sun Jul 10 13:18:35 2005 @@ -4,7 +4,7 @@ ;;; Created: somewhen late 2002 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: renderer2.lisp,v 1.7 2005/03/13 18:03:25 gbaumann Exp $ +;;; $Id: renderer2.lisp,v 1.8 2005/07/10 11:18:35 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -1177,6 +1177,7 @@ (defvar *zzz* nil) (defvar *dyn-elm* nil) +#+emarsden2005-06-23 (defun tata (mode) (let ((clim-user::*medium* (clim:find-pane-named clim-user::*frame* 'clim-user::canvas)) (closure-protocol:*document-language* @@ -1262,7 +1263,7 @@ (clim:delete-output-record (para-box-output-record the-pb) papa) ;; now clim is so inherently broken .... (setf (para-box-output-record the-pb) - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-new-output-record (clim-user::*pane*) (funcall (para-box-genesis the-pb))))) (tata mode)) )) @@ -1272,8 +1273,7 @@ (defun format-block (item x1 x2 ss before-markers #||# pos-vertical-margin neg-vertical-margin yy) (let (res) (setf (block-box-output-record item) - (clim:with-new-output-record - (clim-user::*medium*) foo + (clim:with-new-output-record (clim-user::*pane*) foo (setf res (multiple-value-list (case (cooked-style-display (block-box-style item)) @@ -1313,7 +1313,7 @@ (yy0 nil) ;the inner top padding edge ; NIL initially to indicate that we do not know it for now. (bg-record - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-new-output-record (clim-user::*pane*) ))) ;; remember the output record of the decoration @@ -1427,7 +1427,7 @@ before-markers)))))) (setf (para-box-output-record item) - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-new-output-record (clim-user::*pane*) (setf (values pos-vertical-margin neg-vertical-margin x1 x2 yy ss block-style) (funcall (para-box-genesis item))))) @@ -1538,9 +1538,9 @@ (minf neg-vertical-margin bm))) ;; - (clim:with-output-recording-options (clim-user::*medium* :record t :draw nil) + (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) (let ((new-record - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-new-output-record (clim-user::*pane*) ;; (multiple-value-bind (x1 y1 x2 y2) (values (- x1 pl) (+ yy0 @@ -2112,7 +2112,7 @@ (values x1 (+ x1 actual-width)))))) - (let ((bg-record (clim:with-new-output-record (clim-user::*medium*)))) + (let ((bg-record (clim:with-new-output-record (clim-user::*pane*)))) (setf (table-decoration-output-record table) bg-record) (let ((yyy yy) (dangling-cells nil)) ;a list of (rowspan total-rowspan cell) pairs of cells whose row span @@ -2270,8 +2270,8 @@ (clim:clear-output-record bg-record) (multiple-value-bind (xx1 xx2) (table-column-coordinates table column-widths ci (table-cell-colspan cell)) (let ((new-record - (clim:with-output-recording-options (clim-user::*medium* :record t :draw nil) - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) + (clim:with-new-output-record (clim-user::*pane*) (draw-box-decoration clim-user::*medium* (+ x1 xx1) y1 (+ x1 xx2) y2 (block-box-style (table-cell-content cell))))))) (clim:delete-output-record new-record (clim:output-record-parent new-record)) @@ -2284,8 +2284,8 @@ (x1 x1) (x2 x2)) (let ((new-record - (clim:with-output-recording-options (clim-user::*medium* :record t :draw nil) - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) + (clim:with-new-output-record (clim-user::*pane*) (draw-box-decoration clim-user::*medium* x1 y1 x2 y2 (table-style table)))))) (clim:delete-output-record new-record (clim:output-record-parent new-record)) @@ -5061,6 +5061,10 @@ ;; $Log: renderer2.lisp,v $ +;; Revision 1.8 2005/07/10 11:18:35 emarsden +;; Distinguish between pane and medium in the CLIM GUI. This should +;; fix image display. +;; ;; Revision 1.7 2005/03/13 18:03:25 gbaumann ;; Gross license change ;; From emarsden at common-lisp.net Sun Jul 10 12:26:55 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 10 Jul 2005 14:26:55 +0200 (CEST) Subject: [closure-cvs] CVS update: Directory change: closure/resources/patterns Message-ID: <20050710122655.542CA884CA@common-lisp.net> Update of /project/closure/cvsroot/closure/resources/patterns In directory common-lisp.net:/tmp/cvs-serv1056/patterns Log Message: Directory /project/closure/cvsroot/closure/resources/patterns added to the repository Date: Sun Jul 10 14:26:55 2005 Author: emarsden New directory closure/resources/patterns added From emarsden at common-lisp.net Sun Jul 10 12:27:33 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 10 Jul 2005 14:27:33 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/resources/patterns/deutsch.ptn closure/resources/patterns/english.ptn closure/resources/patterns/francais.ptn Message-ID: <20050710122733.298FC884CA@common-lisp.net> Update of /project/closure/cvsroot/closure/resources/patterns In directory common-lisp.net:/tmp/cvs-serv1089/patterns Added Files: deutsch.ptn english.ptn francais.ptn Log Message: Added pattern files for hyphenation (taken from Amaya sources). Date: Sun Jul 10 14:27:32 2005 Author: emarsden From crhodes at common-lisp.net Mon Jul 11 15:58:04 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 11 Jul 2005 17:58:04 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/renderer/tables.lisp closure/src/renderer/renderer2.lisp closure/src/renderer/clim-draw.lisp Message-ID: <20050711155804.0AEA58853D@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv7926/src/renderer Modified Files: tables.lisp renderer2.lisp clim-draw.lisp Log Message: Complete the renaming *MEDIUM* -> *PANE*. Panes are CLIM extended-streams, and remember output to them in output records. Mediums are much simpler, and don't have this kind of memory. So, though the same drawing functions (DRAW-TEXT, DRAW-LINE) can have the same initial effect applied to a pane and a medium, the output-record state is very different. Date: Mon Jul 11 17:57:57 2005 Author: crhodes Index: closure/src/renderer/tables.lisp diff -u closure/src/renderer/tables.lisp:1.3 closure/src/renderer/tables.lisp:1.4 --- closure/src/renderer/tables.lisp:1.3 Sun Mar 13 19:03:25 2005 +++ closure/src/renderer/tables.lisp Mon Jul 11 17:57:56 2005 @@ -943,8 +943,8 @@ (rc-first-line-tasks new-rc) nil (rc-left-floating-boxen new-rc) nil (rc-right-floating-boxen new-rc) nil) - (clim:with-new-output-record (clim-user::*medium* 'clim:standard-sequence-output-record record) - (clim:with-output-recording-options (clim-user::*medium* :record t :draw nil) + (clim:with-new-output-record (clim-user::*pane* 'clim:standard-sequence-output-record record) + (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) (let* ((fake-parent (make-bbox)) (bbox (brender new-rc (cell-content cell) fake-parent))) (if bbox @@ -1030,15 +1030,15 @@ (defun render-table (rc pt parent-box) ;; Now, while we render a table, we unfortunatly have to disable ;; drawing. - (clim:with-output-recording-options (clim-user::*medium* :record t :draw nil) + (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) ;;; xxx not yet correct - (funcall (if t ;(clim:stream-drawing-p clim-user::*medium*) + (funcall (if t ;(clim:stream-drawing-p clim-user::*pane*) #'clim:replay-output-record #'values) - (clim:with-new-output-record (clim-user::*medium*) + (clim:with-new-output-record (clim-user::*pane*) ;; why does drawp nest proper? (render-table-2 rc pt parent-box)) - clim-user::*medium* clim:+everywhere+ 0 0))) + clim-user::*pane* clim:+everywhere+ 0 0))) (defun render-table-2 (rc pt parent-box) (let ((table (parse-table pt)) Index: closure/src/renderer/renderer2.lisp diff -u closure/src/renderer/renderer2.lisp:1.8 closure/src/renderer/renderer2.lisp:1.9 --- closure/src/renderer/renderer2.lisp:1.8 Sun Jul 10 13:18:35 2005 +++ closure/src/renderer/renderer2.lisp Mon Jul 11 17:57:56 2005 @@ -4,7 +4,7 @@ ;;; Created: somewhen late 2002 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: renderer2.lisp,v 1.8 2005/07/10 11:18:35 emarsden Exp $ +;;; $Id: renderer2.lisp,v 1.9 2005/07/11 15:57:56 crhodes Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -435,8 +435,8 @@ (open-chunk-dy chunk)) ))) (when (eql pass 1) - (clim:draw-text* clim-user::*medium* q x y)) - (incf x (clim:text-size clim-user::*medium* q)))) + (clim:draw-text* clim-user::*pane* q x y)) + (incf x (clim:text-size clim-user::*pane* q)))) (push dy ys) (setf dy (open-chunk-dy chunk)) (push (bounding-chunk-style chunk) ss) @@ -451,7 +451,7 @@ (let (p q res.text-seen-p) (cond (link (clim:with-output-as-presentation - (clim-user::*medium* + (clim-user::*pane* (url:unparse-url (hyper-link-url (imap-area-link link))) 'clim-user::url @@ -470,8 +470,8 @@ (chunk-debug-name q) ""))) (when (eql pass 1) - (clim:draw-text* clim-user::*medium* q x y)) - (incf x (clim:text-size clim-user::*medium* q)) + (clim:draw-text* clim-user::*pane* q x y)) + (incf x (clim:text-size clim-user::*pane* q)) ))) (pop ss) @@ -483,7 +483,7 @@ ;; replaced objects are different to dimensions of regular ;; inline boxen. (cond (replaced-object-p - (draw-box-decoration clim-user::*medium* + (draw-box-decoration clim-user::*pane* x1 (- (+ y dy) (open-chunk-height oc) (cooked-style-padding-top (bounding-chunk-style oc)) (- (cooked-style-padding-top (bounding-chunk-style oc))) @@ -499,7 +499,7 @@ :right-halfp (not (bounding-chunk-halfp q)) )) (t - (draw-box-decoration clim-user::*medium* + (draw-box-decoration clim-user::*pane* x1 (- (+ y dy) (open-chunk-height oc) (cooked-style-padding-top (bounding-chunk-style oc))) x (+ (+ y dy) (open-chunk-depth oc) @@ -528,7 +528,7 @@ (when (eql pass 1) (setf (clim:medium-ink clim-user::*medium*) (css-color-ink (cooked-style-color (black-chunk-style chunk)))) - (clim-draw-runes* clim-user::*medium* + (clim-draw-runes* clim-user::*pane* x (+ dy y) (black-chunk-data chunk) 0 (length (black-chunk-data chunk)) @@ -539,7 +539,7 @@ (let ((ro (replaced-object-chunk-object chunk))) (when (eql pass 1) (closure/clim-device::medium-draw-ro* - clim-user::*medium* + clim-user::*pane* ro x (+ dy y))) (incf x (chunk-width chunk))) ))))) ;; @@ -1177,99 +1177,6 @@ (defvar *zzz* nil) (defvar *dyn-elm* nil) -#+emarsden2005-06-23 -(defun tata (mode) - (let ((clim-user::*medium* (clim:find-pane-named clim-user::*frame* 'clim-user::canvas)) - (closure-protocol:*document-language* - (make-instance 'r2::html-4.0-document-language)) - (closure-protocol:*user-agent* nil)) - (multiple-value-bind (x c) - (ignore-errors - ;; first find the chunk - (let ((offender *dyn-elm*) - (the-pb nil)) - (block suche - (labels ((walk (x) - (etypecase x - (marker-box) - (block-box - (mapc #'walk (block-box-content x))) - (para-box - (mapc #'(lambda (z) (walk-chunk x z)) (para-box-items x))))) - (walk-chunk (pb x) - (etypecase x - (floating-chunk) - (bounding-chunk - (setf (bounding-chunk-pt x) offender) - #+NIL - (when (eq (bounding-chunk-pt x) offender) - '(cond ((eql mode :highlight) - (setf (slot-value (bounding-chunk-style x) 'css::border-left-width) 1 - (slot-value (bounding-chunk-style x) 'css::border-left-style) :solid - (slot-value (bounding-chunk-style x) 'css::border-right-width) 1 - (slot-value (bounding-chunk-style x) 'css::border-right-style) :solid - (slot-value (bounding-chunk-style x) 'css::border-top-width) 1 - (slot-value (bounding-chunk-style x) 'css::border-top-style) :solid - (slot-value (bounding-chunk-style x) 'css::border-bottom-width) 1 - (slot-value (bounding-chunk-style x) 'css::border-bottom-style) :solid)) - (t - (setf (slot-value (bounding-chunk-style x) 'css::border-left-width) 0 - (slot-value (bounding-chunk-style x) 'css::border-left-style) :none - (slot-value (bounding-chunk-style x) 'css::border-right-width) 0 - (slot-value (bounding-chunk-style x) 'css::border-right-style) :none - (slot-value (bounding-chunk-style x) 'css::border-top-width) 0 - (slot-value (bounding-chunk-style x) 'css::border-top-style) :none - (slot-value (bounding-chunk-style x) 'css::border-bottom-width) 0 - (slot-value (bounding-chunk-style x) 'css::border-bottom-style) :none))) - '(setf (slot-value (bounding-chunk-style x) 'css::background-color) - (if (eq mode :highlight) - "#ccccff" - :transparent)) - '(setf (slot-value (bounding-chunk-style x) 'css::text-decoration) - (if (eq mode :highlight) - (list :underline) - :none)) - )) - (kern-chunk) - (disc-chunk - (mapc #'(lambda (x) (walk-chunk pb x)) - (disc-chunk-here x)) - (mapc #'(lambda (x) (walk-chunk pb x)) - (disc-chunk-after x)) - (mapc #'(lambda (x) (walk-chunk pb x)) - (disc-chunk-before x))) - (black-chunk - '(setf (slot-value (black-chunk-style x) 'css::color) - (if (eq mode :highlight) - "#ff0000" - "#000000")) - ) - (replaced-object-chunk - (when (typep (replaced-object-chunk-object x) - 'lazy-image) - (setf (replaced-object-chunk-object x) - (replaced-element-p *document* *device* (replaced-object-chunk-element x))) - (setf the-pb pb) - (return-from suche nil)) - )))) - (walk *zzz*))) - - (dprint "@@@@@@@ offender = ~S." offender) - (dprint "@@@@@@@ the-pb = ~S." the-pb) - (when the-pb - (let ( - (papa (clim:output-record-parent (para-box-output-record the-pb)))) - (dprint "@@@@@@@ papa = ~S." papa) - (clim:delete-output-record (para-box-output-record the-pb) papa) - ;; now clim is so inherently broken .... - (setf (para-box-output-record the-pb) - (clim:with-new-output-record (clim-user::*pane*) - (funcall (para-box-genesis the-pb))))) - (tata mode)) - )) - (when c - (dprint "Error: ~A." c))))) - (defun format-block (item x1 x2 ss before-markers #||# pos-vertical-margin neg-vertical-margin yy) (let (res) (setf (block-box-output-record item) @@ -1549,7 +1456,7 @@ (+ x2 pr) (- yy (cooked-style-border-bottom-width s) )) - (draw-box-decoration clim-user::*medium* x1 y1 x2 y2 block-style) + (draw-box-decoration clim-user::*pane* x1 y1 x2 y2 block-style) (incf y1 (cooked-style-padding-top s)) (decf y2 (cooked-style-padding-bottom s)) (when (realp (cooked-style-height s)) @@ -1558,7 +1465,7 @@ (error "Fubar"))) #+NIL (unless (or (= x1 x2) (= y1 y2)) - (clim:draw-rectangle* clim-user::*medium* x1 y1 x2 y2 + (clim:draw-rectangle* clim-user::*pane* x1 y1 x2 y2 :ink clim:+red+ :filled nil)) ) @@ -2162,7 +2069,7 @@ (unless (or (= x1 (+ x1 w)) (= yyy yy)) #-NIL - (clim:draw-rectangle* clim-user::*medium* + (clim:draw-rectangle* clim-user::*pane* x1 yyy (+ x1 w) yy :ink (elt *table-depth-color* (mod *table-depth* (length *table-depth-color*))) @@ -2272,7 +2179,7 @@ (let ((new-record (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) (clim:with-new-output-record (clim-user::*pane*) - (draw-box-decoration clim-user::*medium* (+ x1 xx1) y1 (+ x1 xx2) y2 + (draw-box-decoration clim-user::*pane* (+ x1 xx1) y1 (+ x1 xx2) y2 (block-box-style (table-cell-content cell))))))) (clim:delete-output-record new-record (clim:output-record-parent new-record)) (clim:add-output-record new-record bg-record))))))) @@ -2286,7 +2193,7 @@ (let ((new-record (clim:with-output-recording-options (clim-user::*pane* :record t :draw nil) (clim:with-new-output-record (clim-user::*pane*) - (draw-box-decoration clim-user::*medium* x1 y1 x2 y2 + (draw-box-decoration clim-user::*pane* x1 y1 x2 y2 (table-style table)))))) (clim:delete-output-record new-record (clim:output-record-parent new-record)) (clim:add-output-record new-record bg-record))) @@ -2303,7 +2210,7 @@ (multiple-value-bind (x1 x2) (table-column-coordinates table column-widths j) (let* ( (y1 (+ yy (loop for k below i sum (elt row-heights k))))) - (clim:draw-line* clim-user::*medium* + (clim:draw-line* clim-user::*pane* x1 y1 x2 y1 :ink (clim-user::parse-x11-color color) :line-thickness width))))))) @@ -2317,7 +2224,7 @@ (let* ((y1 (+ yy (loop for k below i sum (elt row-heights k)))) (y2 (+ y1 (elt row-heights i))) (x1 (+ x1 (loop for k below j sum (elt column-widths k))))) - (clim:draw-line* clim-user::*medium* + (clim:draw-line* clim-user::*pane* x1 y1 x1 y2 :ink (clim-user::parse-x11-color color) :line-thickness width)))))) ) @@ -5061,6 +4968,15 @@ ;; $Log: renderer2.lisp,v $ +;; Revision 1.9 2005/07/11 15:57:56 crhodes +;; Complete the renaming *MEDIUM* -> *PANE*. +;; +;; Panes are CLIM extended-streams, and remember output to them in output +;; records. Mediums are much simpler, and don't have this kind of +;; memory. So, though the same drawing functions (DRAW-TEXT, DRAW-LINE) +;; can have the same initial effect applied to a pane and a medium, the +;; output-record state is very different. +;; ;; Revision 1.8 2005/07/10 11:18:35 emarsden ;; Distinguish between pane and medium in the CLIM GUI. This should ;; fix image display. Index: closure/src/renderer/clim-draw.lisp diff -u closure/src/renderer/clim-draw.lisp:1.3 closure/src/renderer/clim-draw.lisp:1.4 --- closure/src/renderer/clim-draw.lisp:1.3 Sun Mar 13 22:39:19 2005 +++ closure/src/renderer/clim-draw.lisp Mon Jul 11 17:57:56 2005 @@ -4,7 +4,7 @@ ;;; Created: 2003-03-08 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: clim-draw.lisp,v 1.3 2005/03/13 21:39:19 emarsden Exp $ +;;; $Id: clim-draw.lisp,v 1.4 2005/07/11 15:57:56 crhodes Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -171,14 +171,14 @@ (dolist (deco text-decoration) (case deco (:underline - (clim:draw-line* clim-user::*medium* + (clim:draw-line* clim-user::*pane* xx1 (+ yy 2) xx (+ yy 2) :ink (clim-user::parse-x11-color color))) (:overline ;; xxx hack - (clim:draw-line* clim-user::*medium* + (clim:draw-line* clim-user::*pane* xx1 (- yy 12) xx (- yy 12) :ink (clim-user::parse-x11-color color))) (:line-through - (clim:draw-line* clim-user::*medium* + (clim:draw-line* clim-user::*pane* xx1 (- yy 6) xx (- yy 6) :ink (clim-user::parse-x11-color color))) )))) ;;;; Runes From crhodes at common-lisp.net Mon Jul 11 15:58:07 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Mon, 11 Jul 2005 17:58:07 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/gui/clim-gui.lisp Message-ID: <20050711155807.E711B88151@common-lisp.net> Update of /project/closure/cvsroot/closure/src/gui In directory common-lisp.net:/tmp/cvs-serv7926/src/gui Modified Files: clim-gui.lisp Log Message: Complete the renaming *MEDIUM* -> *PANE*. Panes are CLIM extended-streams, and remember output to them in output records. Mediums are much simpler, and don't have this kind of memory. So, though the same drawing functions (DRAW-TEXT, DRAW-LINE) can have the same initial effect applied to a pane and a medium, the output-record state is very different. Date: Mon Jul 11 17:58:04 2005 Author: crhodes Index: closure/src/gui/clim-gui.lisp diff -u closure/src/gui/clim-gui.lisp:1.19 closure/src/gui/clim-gui.lisp:1.20 --- closure/src/gui/clim-gui.lisp:1.19 Sun Jul 10 13:18:34 2005 +++ closure/src/gui/clim-gui.lisp Mon Jul 11 17:58:03 2005 @@ -4,7 +4,7 @@ ;;; Created: 2002-07-22 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: clim-gui.lisp,v 1.19 2005/07/10 11:18:34 emarsden Exp $ +;;; $Id: clim-gui.lisp,v 1.20 2005/07/11 15:58:03 crhodes Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 2002 by Gilbert Baumann @@ -28,6 +28,15 @@ ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. ;; $Log: clim-gui.lisp,v $ +;; Revision 1.20 2005/07/11 15:58:03 crhodes +;; Complete the renaming *MEDIUM* -> *PANE*. +;; +;; Panes are CLIM extended-streams, and remember output to them in output +;; records. Mediums are much simpler, and don't have this kind of +;; memory. So, though the same drawing functions (DRAW-TEXT, DRAW-LINE) +;; can have the same initial effect applied to a pane and a medium, the +;; output-record state is very different. +;; ;; Revision 1.19 2005/07/10 11:18:34 emarsden ;; Distinguish between pane and medium in the CLIM GUI. This should ;; fix image display. @@ -128,7 +137,6 @@ (:menu-bar menubar-command-table) (:panes (canvas (make-pane 'closure-pane - :name 'canvas :height 2000 :width 800 :display-time nil)) @@ -620,17 +628,6 @@ ;;;; ---------------------------------------------------------------------------------------------------- -#+NIL -(define-closure-command com-reflow () - (window-clear (find-pane-named *frame* 'canvas)) - (let ((*medium* (find-pane-named *frame* 'canvas))) - (let ((device (make-instance 'closure/clim-device::clim-device :medium *medium*))) - (let ((closure-protocol:*document-language* - (make-instance 'r2::html-4.0-document-language)) - (closure-protocol:*user-agent* - nil)) - (r2::reflow))))) - (define-presentation-translator url-from-string (string url closure) (x) @@ -684,7 +681,7 @@ (min (gadget-max-value scrollbar) (+ current-y (* 0.9 window-height)))))) (define-closure-command (com-redraw :name t :keystroke (#\r :control)) () - (let* ((*medium* (find-pane-named *frame* 'canvas)) ) - (handle-repaint *medium* (sheet-region (pane-viewport *medium*)))) + (let* ((*pane* (find-pane-named *frame* 'canvas)) ) + (handle-repaint *pane* (sheet-region (pane-viewport *pane*)))) (xlib:display-finish-output (clim-clx::clx-port-display (find-port)))) From crhodes at common-lisp.net Wed Jul 13 13:44:57 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Wed, 13 Jul 2005 15:44:57 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/renderer/clim-device.lisp closure/src/renderer/renderer2.lisp closure/src/renderer/x11.lisp Message-ID: <20050713134457.7607888528@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv16629/src/renderer Modified Files: clim-device.lisp renderer2.lisp x11.lisp Log Message: Make images work, more or less. * restore horrible grecording hack for (medium-)draw-ro* * make direct drawing of images to x11 work with my X server (32bpp even for 24-depth images) Obviously this should turn into proper clim support for images, at which point this horribleness can go away. However, this now basically works for me, modulo compiler consistency strangeness at startup. Date: Wed Jul 13 15:44:56 2005 Author: crhodes Index: closure/src/renderer/clim-device.lisp diff -u closure/src/renderer/clim-device.lisp:1.11 closure/src/renderer/clim-device.lisp:1.12 --- closure/src/renderer/clim-device.lisp:1.11 Sun Jul 10 13:18:35 2005 +++ closure/src/renderer/clim-device.lisp Wed Jul 13 15:44:55 2005 @@ -446,12 +446,17 @@ :actual-width (or width (r2::aimage-width aim)) :actual-height (or height (r2::aimage-height aim))))) -#+NIL -(climi::def-grecording draw-ro (() ro x y) - (values x - (- y (nth-value 1 (r2::ro/size ro))) - (+ x (nth-value 0 (r2::ro/size ro))) - (+ y 0))) +(climi::def-grecording draw-ro (() ro x y) () + (values x + (- y (nth-value 1 (r2::ro/size ro))) + (+ x (nth-value 0 (r2::ro/size ro))) + (+ y 0))) +(climi::def-graphic-op draw-ro (ro x y)) + +(defun draw-ro* (sheet ro x y &rest args) + (climi::with-medium-options (sheet args) + (medium-draw-ro* medium ro x y))) + (defmethod medium-draw-ro* ((medium clim:medium) (self ro/img) x y) (progn ;; ignore-errors ;xxx Index: closure/src/renderer/renderer2.lisp diff -u closure/src/renderer/renderer2.lisp:1.9 closure/src/renderer/renderer2.lisp:1.10 --- closure/src/renderer/renderer2.lisp:1.9 Mon Jul 11 17:57:56 2005 +++ closure/src/renderer/renderer2.lisp Wed Jul 13 15:44:55 2005 @@ -4,7 +4,7 @@ ;;; Created: somewhen late 2002 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: renderer2.lisp,v 1.9 2005/07/11 15:57:56 crhodes Exp $ +;;; $Id: renderer2.lisp,v 1.10 2005/07/13 13:44:55 crhodes Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -538,7 +538,7 @@ (replaced-object-chunk (let ((ro (replaced-object-chunk-object chunk))) (when (eql pass 1) - (closure/clim-device::medium-draw-ro* + (closure/clim-device::draw-ro* clim-user::*pane* ro x (+ dy y))) (incf x (chunk-width chunk))) ))))) @@ -4968,6 +4968,18 @@ ;; $Log: renderer2.lisp,v $ +;; Revision 1.10 2005/07/13 13:44:55 crhodes +;; Make images work, more or less. +;; +;; * restore horrible grecording hack for (medium-)draw-ro* +;; +;; * make direct drawing of images to x11 work with my X server (32bpp even +;; for 24-depth images) +;; +;; Obviously this should turn into proper clim support for images, at which +;; point this horribleness can go away. However, this now basically works +;; for me, modulo compiler consistency strangeness at startup. +;; ;; Revision 1.9 2005/07/11 15:57:56 crhodes ;; Complete the renaming *MEDIUM* -> *PANE*. ;; Index: closure/src/renderer/x11.lisp diff -u closure/src/renderer/x11.lisp:1.7 closure/src/renderer/x11.lisp:1.8 --- closure/src/renderer/x11.lisp:1.7 Sun Jul 10 12:57:23 2005 +++ closure/src/renderer/x11.lisp Wed Jul 13 15:44:56 2005 @@ -486,10 +486,16 @@ (let* ((width (imagelib:aimage-width aimage)) (height (imagelib:aimage-height aimage)) (idata (imagelib:aimage-data aimage)) - (xdata (make-array (list height width) :element-type `(unsigned-byte ,depth))) + ;; FIXME: this (and the :BITS-PER-PIXEL, below) is a hack on + ;; top of a hack. At some point in the past, XFree86 and/or + ;; X.org decided that they would no longer support pixmaps + ;; with 24 bpp, which seems to be what most AIMAGEs want to + ;; be. For now, force everything to a 32-bit pixmap. + (xdata (make-array (list height width) :element-type '(unsigned-byte 32))) (ximage (xlib:create-image :width width :height height :depth depth + :bits-per-pixel 32 :data xdata))) (declare (type (simple-array (unsigned-byte 32) (* *)) idata) #+NIL(type (simple-array (unsigned-byte 8) (* *)) xdata) From crhodes at common-lisp.net Wed Jul 13 15:13:05 2005 From: crhodes at common-lisp.net (Christophe Rhodes) Date: Wed, 13 Jul 2005 17:13:05 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/net/http.lisp Message-ID: <20050713151305.D21C388528@common-lisp.net> Update of /project/closure/cvsroot/closure/src/net In directory common-lisp.net:/tmp/cvs-serv23472/src/net Modified Files: http.lisp Log Message: Make the broken-image work under sbcl. * fix REALLY-PROBE-FILE, though we should probably be using some posixish functions instead of opening the file. Date: Wed Jul 13 17:13:05 2005 Author: crhodes Index: closure/src/net/http.lisp diff -u closure/src/net/http.lisp:1.5 closure/src/net/http.lisp:1.6 --- closure/src/net/http.lisp:1.5 Sun Mar 13 19:02:19 2005 +++ closure/src/net/http.lisp Wed Jul 13 17:13:05 2005 @@ -713,9 +713,10 @@ (unwind-protect (progn (setf stream (ignore-errors (open filename :direction :input - :if-does-not-exist nil))) + :element-type '(unsigned-byte 8) + :if-does-not-exist nil))) (and stream - (ignore-errors (read-char stream nil :eof)))) + (ignore-errors (read-byte stream nil :eof)))) (when stream (close stream)) )) )) From emarsden at common-lisp.net Sun Jul 17 09:30:51 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 17 Jul 2005 11:30:51 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/defpack.lisp Message-ID: <20050717093051.BADBD88165@common-lisp.net> Update of /project/closure/cvsroot/closure/src In directory common-lisp.net:/tmp/cvs-serv15903 Modified Files: defpack.lisp Log Message: The hyphenation table can be referenced using an URL, rather than by an absolute filename. Date: Sun Jul 17 11:30:50 2005 Author: emarsden Index: closure/src/defpack.lisp diff -u closure/src/defpack.lisp:1.4 closure/src/defpack.lisp:1.5 --- closure/src/defpack.lisp:1.4 Sun Jul 10 12:57:19 2005 +++ closure/src/defpack.lisp Sun Jul 17 11:30:48 2005 @@ -40,6 +40,8 @@ #:scale-aimage #:pnm-stream->aimage) (:export + #:*tex-mode-p* + #:*hyphenate-p* #:device-font-ascent #:device-dpi #:device-font-descent @@ -128,8 +130,6 @@ (:export #:*home-page* #:*user-wants-images-p* - #:*tex-mode-p* - #:*hyphenate-p* #:*closure-dpi* #:*zoom-factor* #:*debug-submit-p* From emarsden at common-lisp.net Sun Jul 17 09:30:55 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 17 Jul 2005 11:30:55 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/renderer/hyphenation.lisp Message-ID: <20050717093055.A1E2C8853E@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv15903/renderer Modified Files: hyphenation.lisp Log Message: The hyphenation table can be referenced using an URL, rather than by an absolute filename. Date: Sun Jul 17 11:30:51 2005 Author: emarsden Index: closure/src/renderer/hyphenation.lisp diff -u closure/src/renderer/hyphenation.lisp:1.3 closure/src/renderer/hyphenation.lisp:1.4 --- closure/src/renderer/hyphenation.lisp:1.3 Sun Mar 13 19:03:24 2005 +++ closure/src/renderer/hyphenation.lisp Sun Jul 17 11:30:51 2005 @@ -4,7 +4,7 @@ ;;; Created: 2003-03-07 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: hyphenation.lisp,v 1.3 2005/03/13 18:03:24 gbaumann Exp $ +;;; $Id: hyphenation.lisp,v 1.4 2005/07/17 09:30:51 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1999-2003 by Gilbert Baumann @@ -174,18 +174,18 @@ ;;;; Reading Tables -(defun read-hyphen-table-file (filename &key (class 'tree-hyphenation-table)) - (with-open-file (input filename) - (let ((res (make-instance class - :filename filename))) - (read-line input nil nil) - (do ((line (read-line input nil nil) (read-line input nil nil))) - ((null line)) - (let* ((j (position #\space line)) - (pattern (map 'vector #'digit-char-p (subseq line (+ j 1))))) - (insert-hyphenation-pattern res (subseq line 0 j) pattern))) - res))) - +(defun read-hyphen-table (url &key (class 'tree-hyphenation-table)) + (let ((url (if (url:url-p url) url (url:parse-url url)))) + (netlib:with-open-document ((input mime-type) url) + (declare (ignore mime-type)) + (let ((res (make-instance class :filename url))) + (g/read-line input nil nil) + (do ((line (g/read-line input nil nil) (g/read-line input nil nil))) + ((null line)) + (let* ((j (position #\space line)) + (pattern (map 'vector #'digit-char-p (subseq line (+ j 1))))) + (insert-hyphenation-pattern res (subseq line 0 j) pattern))) + res)))) ;; 100,000x hyphenation of "argument": @@ -193,6 +193,10 @@ ;; new: .57s 2.400,000 bytes [technically zero] ;; $Log: hyphenation.lisp,v $ +;; Revision 1.4 2005/07/17 09:30:51 emarsden +;; The hyphenation table can be referenced using an URL, rather than by +;; an absolute filename. +;; ;; Revision 1.3 2005/03/13 18:03:24 gbaumann ;; Gross license change ;; From emarsden at common-lisp.net Sun Jul 17 09:30:58 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 17 Jul 2005 11:30:58 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/gui/gui.lisp Message-ID: <20050717093058.4C63288165@common-lisp.net> Update of /project/closure/cvsroot/closure/src/gui In directory common-lisp.net:/tmp/cvs-serv15903/gui Modified Files: gui.lisp Log Message: The hyphenation table can be referenced using an URL, rather than by an absolute filename. Date: Sun Jul 17 11:30:55 2005 Author: emarsden Index: closure/src/gui/gui.lisp diff -u closure/src/gui/gui.lisp:1.6 closure/src/gui/gui.lisp:1.7 --- closure/src/gui/gui.lisp:1.6 Sun Jul 10 12:57:20 2005 +++ closure/src/gui/gui.lisp Sun Jul 17 11:30:52 2005 @@ -54,10 +54,6 @@ (defparameter *debug-submit-p* nil "Whether to dump the values about to be submit by a to the server on the listener.") -;; experimental code that is not activated by default -(defvar *tex-mode-p* nil) -(defvar *hyphenate-p* nil) - (defstruct display-list From emarsden at common-lisp.net Sun Jul 17 09:35:48 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 17 Jul 2005 11:35:48 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/renderer/renderer2.lisp Message-ID: <20050717093548.4008188165@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv16691/src/renderer Modified Files: renderer2.lisp Log Message: Reference hyphenation table via a file:// URL. Date: Sun Jul 17 11:35:47 2005 Author: emarsden Index: closure/src/renderer/renderer2.lisp diff -u closure/src/renderer/renderer2.lisp:1.10 closure/src/renderer/renderer2.lisp:1.11 --- closure/src/renderer/renderer2.lisp:1.10 Wed Jul 13 15:44:55 2005 +++ closure/src/renderer/renderer2.lisp Sun Jul 17 11:35:47 2005 @@ -4,7 +4,7 @@ ;;; Created: somewhen late 2002 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: renderer2.lisp,v 1.10 2005/07/13 13:44:55 crhodes Exp $ +;;; $Id: renderer2.lisp,v 1.11 2005/07/17 09:35:47 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -4787,7 +4787,7 @@ (defun hyphenation-table () (or *hyphenation-table* (setf *hyphenation-table* - (read-hyphen-table-file "/home/closure/closure/resources/patterns/english.ptn")))) + (read-hyphen-table "file://closure/resources/patterns/english.ptn")))) (defun hyphenate-items (items w) "This takes a chunk list and applies hyphenation it it." @@ -4968,6 +4968,9 @@ ;; $Log: renderer2.lisp,v $ +;; Revision 1.11 2005/07/17 09:35:47 emarsden +;; Reference hyphenation table via a file:// URL. +;; ;; Revision 1.10 2005/07/13 13:44:55 crhodes ;; Make images work, more or less. ;; From emarsden at common-lisp.net Sun Jul 17 09:38:52 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 17 Jul 2005 11:38:52 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/css/css-parse.lisp Message-ID: <20050717093852.B24CD88165@common-lisp.net> Update of /project/closure/cvsroot/closure/src/css In directory common-lisp.net:/tmp/cvs-serv16745/src/css Modified Files: css-parse.lisp Log Message: Reduce amount of debugging information printed to console. Date: Sun Jul 17 11:38:51 2005 Author: emarsden Index: closure/src/css/css-parse.lisp diff -u closure/src/css/css-parse.lisp:1.4 closure/src/css/css-parse.lisp:1.5 --- closure/src/css/css-parse.lisp:1.4 Sun Mar 13 19:00:58 2005 +++ closure/src/css/css-parse.lisp Sun Jul 17 11:38:51 2005 @@ -709,7 +709,6 @@ (defun p/integer (tokens) (let ((r (p/measure tokens '(1)))) - (print r) (and r (integerp (car r)) r))) From emarsden at common-lisp.net Sun Jul 17 09:38:53 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 17 Jul 2005 11:38:53 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/html/html-style.lisp Message-ID: <20050717093853.B2FDB88540@common-lisp.net> Update of /project/closure/cvsroot/closure/src/html In directory common-lisp.net:/tmp/cvs-serv16745/src/html Modified Files: html-style.lisp Log Message: Reduce amount of debugging information printed to console. Date: Sun Jul 17 11:38:52 2005 Author: emarsden Index: closure/src/html/html-style.lisp diff -u closure/src/html/html-style.lisp:1.6 closure/src/html/html-style.lisp:1.7 --- closure/src/html/html-style.lisp:1.6 Sun Jul 10 12:57:21 2005 +++ closure/src/html/html-style.lisp Sun Jul 17 11:38:52 2005 @@ -1160,7 +1160,6 @@ t)))) (defmethod x11-draw-robj (drawable gcontext (self ro/image) box x y) - drawable gcontext self box x y (setf x (floor x)) (setf y (floor y)) (with-slots (alt awidth aheight aimage url) self From emarsden at common-lisp.net Sun Jul 17 09:38:57 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 17 Jul 2005 11:38:57 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/renderer/clim-device.lisp closure/src/renderer/images.lisp Message-ID: <20050717093857.1BF0B88165@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv16745/src/renderer Modified Files: clim-device.lisp images.lisp Log Message: Reduce amount of debugging information printed to console. Date: Sun Jul 17 11:38:54 2005 Author: emarsden Index: closure/src/renderer/clim-device.lisp diff -u closure/src/renderer/clim-device.lisp:1.12 closure/src/renderer/clim-device.lisp:1.13 --- closure/src/renderer/clim-device.lisp:1.12 Wed Jul 13 15:44:55 2005 +++ closure/src/renderer/clim-device.lisp Sun Jul 17 11:38:54 2005 @@ -221,8 +221,6 @@ res)) (defun background-pixmap+mask (document drawable bg) - #+emarsden2005-06-23 - (print `(background-pixmap+mask ,bg)) (cond ((r2::background-%pixmap bg) ;; already there (values (r2::background-%pixmap bg) @@ -371,6 +369,7 @@ (unless (eql (r2::background-image bg) :none) (multiple-value-bind (pixmap mask) (background-pixmap+mask document (sheet-direct-mirror (medium-sheet medium)) bg) + #+emarsden2005-07-15 (print (list 'x11-draw-background pixmap mask)) (unless (eql pixmap :none) (let* ((iw (xlib:drawable-width pixmap)) Index: closure/src/renderer/images.lisp diff -u closure/src/renderer/images.lisp:1.2 closure/src/renderer/images.lisp:1.3 --- closure/src/renderer/images.lisp:1.2 Sun Mar 13 19:03:24 2005 +++ closure/src/renderer/images.lisp Sun Jul 17 11:38:54 2005 @@ -79,7 +79,7 @@ (t (warn "Auch das hat nix genuetzt.") (cond (deliver-broken-image-p - (format T "~%;; ~A -> using broken image." url) + (format *debug-io* "~%;; ~A -> using broken image." url) (broken-aimage document)) (t (error "Image mime type `~A' or `~A' not understood." @@ -88,10 +88,10 @@ (cond ((null aimage) (cond (deliver-broken-image-p (progn - (format T "~%;; ~A -> using broken image. [zweite variante]" url) + (format *debug-io* "~%;; ~A -> using broken image. [zweite variante]" url) (broken-aimage document) )) (t - (format T "~&;; Was unable to read ~S as image, because of:~%;; | ~A." + (format *debug-io* "~&;; Was unable to read ~S as image, because of:~%;; | ~A." url condition) (values nil condition)))) (t @@ -173,7 +173,7 @@ (let ((cmd (format nil "~A <~A >~A" filter-name (namestring (truename temp-filename)) (namestring pnm-filename)))) - (format T "~%;; running: ~A" cmd) + (format *debug-io* "~%;; running: ~A" cmd) (run-unix-shell-command cmd)) (progn ;ignore-errors (with-open-file (input pnm-filename @@ -235,4 +235,4 @@ :direction :output :if-exists :new-version :element-type '(unsigned-byte 8)) - (write-ppm-image aimage sink))) \ No newline at end of file + (write-ppm-image aimage sink))) From emarsden at common-lisp.net Sun Jul 17 09:38:56 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 17 Jul 2005 11:38:56 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/imagelib/png.lisp Message-ID: <20050717093856.620D588541@common-lisp.net> Update of /project/closure/cvsroot/closure/src/imagelib In directory common-lisp.net:/tmp/cvs-serv16745/src/imagelib Modified Files: png.lisp Log Message: Reduce amount of debugging information printed to console. Date: Sun Jul 17 11:38:53 2005 Author: emarsden Index: closure/src/imagelib/png.lisp diff -u closure/src/imagelib/png.lisp:1.5 closure/src/imagelib/png.lisp:1.6 --- closure/src/imagelib/png.lisp:1.5 Sun Jul 10 12:36:03 2005 +++ closure/src/imagelib/png.lisp Sun Jul 17 11:38:52 2005 @@ -175,9 +175,7 @@ (defun decode-trns (palette data) (when palette (dotimes (i (length data)) - (setf (svref (aref palette i) 3) (aref data i)))) - (let ((*print-array* t)) - (print palette))) + (setf (svref (aref palette i) 3) (aref data i))))) (defun read-png-image (input) (unless (read-png-signature-p input) From emarsden at common-lisp.net Sun Jul 17 09:41:35 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 17 Jul 2005 11:41:35 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/renderer/x11.lisp Message-ID: <20050717094135.6B65588165@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv16821/src/renderer Modified Files: x11.lisp Log Message: Reducing debug output to console. Date: Sun Jul 17 11:41:35 2005 Author: emarsden Index: closure/src/renderer/x11.lisp diff -u closure/src/renderer/x11.lisp:1.8 closure/src/renderer/x11.lisp:1.9 --- closure/src/renderer/x11.lisp:1.8 Wed Jul 13 15:44:56 2005 +++ closure/src/renderer/x11.lisp Sun Jul 17 11:41:35 2005 @@ -397,7 +397,6 @@ (setf worst-index (list red green blue) worst-delta (second (aref cube red green blue))))))) (destructuring-bind (bm bd nd) (apply #'aref cube worst-index) - (print (list worst-index worst-delta bm bd nd)) (setf (apply #'aref cube worst-index) (list (list nd (elt my k)) 0 From emarsden at common-lisp.net Sun Jul 17 09:44:40 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Sun, 17 Jul 2005 11:44:40 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/net/http.lisp Message-ID: <20050717094440.E1F8888165@common-lisp.net> Update of /project/closure/cvsroot/closure/src/net In directory common-lisp.net:/tmp/cvs-serv16846/src/net Modified Files: http.lisp Log Message: Partial fix for following HTTP redirects (code 301 or 302 or 303). Certain servers (such as www.lisp.org) only include a path in the Location header, instead of a complete URL. We now accept either a path (in which case the rest of the URL is derived from the current URL), or a complete URL. This fix is only partial, since the GUI code in gui/clim-gui.lisp is not prepared to handle redirects correctly. Date: Sun Jul 17 11:44:40 2005 Author: emarsden Index: closure/src/net/http.lisp diff -u closure/src/net/http.lisp:1.6 closure/src/net/http.lisp:1.7 --- closure/src/net/http.lisp:1.6 Wed Jul 13 17:13:05 2005 +++ closure/src/net/http.lisp Sun Jul 17 11:44:40 2005 @@ -99,7 +99,7 @@ (defparameter *user-agent* "Lynx/2.7.1ac-0.98 libwww-FM/2.14") (defparameter *user-agent* "Mozilla/4.0 (compatible; MSIE 6.0; Windows NT 5.1)") -(defparameter *user-agent* "CLOSURE/0.1") +(defparameter *user-agent* "Closure/200507") #|| @@ -549,20 +549,19 @@ response-header))) ((301 302 303) - ;; moved permanently; moved temponary; see other - (multiple-value-bind (input header) - (http-open-document - (url:parse-url - (or (get-header-field response-header :location) - (error "301/302 Response from ~A lacks a 'Location' field." - (url:url-host url)))) - :yet-urls (cons url yet-urls)) - (values input - (append header - (list - (cons "Location" - (get-header-field response-header :location))))))) - + ;; moved permanently; moved temporary; see other + ;; + ;; the Location field may be either a complete URI, or just a path + (let* ((new-location (or (url:parse-url + (get-header-field response-header :location)) + (error "301/302 Response from ~A lacks a 'Location' field." + (url:url-host url)))) + (new-url (if (url:url-host new-location) new-location + (url:merge-url new-location url)))) + (multiple-value-bind (input header) + (apply #'http-open-document new-url :yet-urls (cons url yet-urls) options) + (values input `(, at header ("Location" . ,(unparse-url new-url))))))) + (304 ;; not modified (values (cl-byte-stream->gstream (open (hce-pathname (http-cache) ce) From emarsden at common-lisp.net Tue Jul 19 20:42:14 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Tue, 19 Jul 2005 22:42:14 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/renderer/document.lisp closure/src/renderer/renderer2.lisp Message-ID: <20050719204214.8EB20880DF@common-lisp.net> Update of /project/closure/cvsroot/closure/src/renderer In directory common-lisp.net:/tmp/cvs-serv17830/renderer Modified Files: document.lisp renderer2.lisp Log Message: More removal of spurious debugging output, and conditionalization of some output on *debug-tables* Date: Tue Jul 19 22:42:09 2005 Author: emarsden Index: closure/src/renderer/document.lisp diff -u closure/src/renderer/document.lisp:1.4 closure/src/renderer/document.lisp:1.5 --- closure/src/renderer/document.lisp:1.4 Sun Mar 13 19:03:24 2005 +++ closure/src/renderer/document.lisp Tue Jul 19 22:42:09 2005 @@ -152,7 +152,6 @@ (when (and (style-sheet-link-p link) (style-link-does-apply-p link selected-style) (link-href link)) - (describe link) (let* ((media-type (or (ignore-errors (css::parse-media-type (link-media link))) Index: closure/src/renderer/renderer2.lisp diff -u closure/src/renderer/renderer2.lisp:1.11 closure/src/renderer/renderer2.lisp:1.12 --- closure/src/renderer/renderer2.lisp:1.11 Sun Jul 17 11:35:47 2005 +++ closure/src/renderer/renderer2.lisp Tue Jul 19 22:42:09 2005 @@ -4,7 +4,7 @@ ;;; Created: somewhen late 2002 ;;; Author: Gilbert Baumann ;;; License: MIT style (see below) -;;; $Id: renderer2.lisp,v 1.11 2005/07/17 09:35:47 emarsden Exp $ +;;; $Id: renderer2.lisp,v 1.12 2005/07/19 20:42:09 emarsden Exp $ ;;; --------------------------------------------------------------------------- ;;; (c) copyright 1997-2003 by Gilbert Baumann @@ -982,7 +982,8 @@ (when (> cww (- x2 x1)) ;; situation persists: give a warning. - (warn "*** Overfull line box.")) + (when *debug-tables* + (warn "*** Overfull line box."))) ;; (dolist (k (reverse cur-word)) (push k cur-line)) (setf cur-word nil) @@ -1880,8 +1881,6 @@ (defparameter *table-depth-color* (list clim:+red+ clim:+blue+ clim:+green+ clim:+cyan+)) -(defparameter *debug-table* nil) - ;;; Vertical align in a table ;; When a cell needs to be made larger than otherwise this is thought @@ -1992,7 +1991,7 @@ (let ((column-widths (allocate-table-columns table style x1 x2)) (row-heights (loop repeat (table-number-of-rows table) collect 0))) ;; - (when *debug-table* + (when *debug-tables* (format *trace-output* "~&=== we have a table at depth ~D.~%" *table-depth*) (format *trace-output* "~&=== column minima: ~S.~%" (loop for i below (table-number-of-columns table) @@ -2065,7 +2064,7 @@ (t (push (list (table-cell-rowspan cell) (table-cell-rowspan cell) cell) dangling-cells))) - (when *debug-table* + (when *debug-tables* (unless (or (= x1 (+ x1 w)) (= yyy yy)) #-NIL @@ -2275,7 +2274,8 @@ ;; compute the dimensions for us, so they should compute ;; in this case too. ((eql table.width :auto) - (format *trace-output* "~&Using auto layout (table.width = ~d) ~%" table.width) + (when *debug-tables* + (format *trace-output* "~&Using auto layout (table.width = ~d) ~%" table.width)) (if (< (+ max gutter) (- x2 x1)) (+ max gutter) (max (- x2 x1) @@ -2288,7 +2288,8 @@ ;; | columns plus cell spacing or borders (MIN). If W is greater than ;; | MIN, the extra width should be distributed over the columns. ((realp table.width) - ;;(format *trace-output* "~&Using fixed layout~%") + (when *debug-tables* + (format *trace-output* "~&Using fixed layout~%")) (max table.width min) ) (t @@ -2509,7 +2510,7 @@ (cond ((eql :table-cell (cooked-style-display block-style)) (setf bl 0 br 0))) ;; - (when *debug-table* + (when *debug-tables* (format *trace-output* "~&~S (~S): ml=~s, bl=~s, pl=~s, wd=~s, pr=~s, br=~s, mr=~s~%" 'minmax-block-content block-style ml bl pl wd pr br mr)) (dolist (item items) @@ -2624,7 +2625,7 @@ (show (disc-chunk-after x)))) (replaced-object-chunk (let ((w (chunk-width x))) - (when *debug-table* + (when *debug-tables* (format *trace-output* "~&~S: ~S = ~S~%" 'minmax-para `(chunk-width ,x) (chunk-width x))) (setf w (ro/size (replaced-object-chunk-object x))) @@ -2685,7 +2686,6 @@ (error "FLOATING-CHUNK has no width?"))) (defun compute-floating-chunk-width (chunk containing-block-width) - (describe (floating-chunk-content chunk)) ;;; Kludge! #+NIL (cond ((and (block-box-p (floating-chunk-content chunk)) @@ -2703,14 +2703,14 @@ ;; kludge (cond ((eq :auto (slot-value style 'css::width)) (setf wd (minmax-block (floating-chunk-content chunk))))) - (print (list 'compute-floating-chunk-width - (cooked-style-display (block-box-style (floating-chunk-content chunk))) - (cooked-style-display style) - ml pl bl wd br pr mr) - *trace-output*) - (finish-output *trace-output*) - (+ - ml pl bl wd br pr mr)))) + (when *debug-tables* + (print (list 'compute-floating-chunk-width + (cooked-style-display (block-box-style (floating-chunk-content chunk))) + (cooked-style-display style) + ml pl bl wd br pr mr) + *trace-output*) + (finish-output *trace-output*)) + (+ ml pl bl wd br pr mr)))) ;;;; @@ -4968,6 +4968,10 @@ ;; $Log: renderer2.lisp,v $ +;; Revision 1.12 2005/07/19 20:42:09 emarsden +;; More removal of spurious debugging output, and conditionalization of +;; some output on *debug-tables* +;; ;; Revision 1.11 2005/07/17 09:35:47 emarsden ;; Reference hyphenation table via a file:// URL. ;; From emarsden at common-lisp.net Tue Jul 19 20:42:14 2005 From: emarsden at common-lisp.net (Eric Marsden) Date: Tue, 19 Jul 2005 22:42:14 +0200 (CEST) Subject: [closure-cvs] CVS update: closure/src/net/http.lisp Message-ID: <20050719204214.AD15388529@common-lisp.net> Update of /project/closure/cvsroot/closure/src/net In directory common-lisp.net:/tmp/cvs-serv17830/net Modified Files: http.lisp Log Message: More removal of spurious debugging output, and conditionalization of some output on *debug-tables* Date: Tue Jul 19 22:42:09 2005 Author: emarsden Index: closure/src/net/http.lisp diff -u closure/src/net/http.lisp:1.7 closure/src/net/http.lisp:1.8 --- closure/src/net/http.lisp:1.7 Sun Jul 17 11:44:40 2005 +++ closure/src/net/http.lisp Tue Jul 19 22:42:08 2005 @@ -529,6 +529,9 @@ ;; xxx when exactly to cache? (and her-date her-expires (> her-expires her-date)))))) + ;; the logic below is incomplete; it should also be looking at Cache-control: headers + ;; emarsden2005-07-19 + #+(and) (when cache-p (unless really-cache-p (warn "~A will not be cached; cache-p = ~S; header: ~S"