[closure-cvs] CVS update: closure/src/gui/clim-gui.lisp
Eric Marsden
emarsden at common-lisp.net
Sun Jul 10 11:18:35 UTC 2005
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 <gilbert at base-engineering.com>
;;; 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*)
More information about the Closure-cvs
mailing list