1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-USER; -*-
2 ;;; ---------------------------------------------------------------------------
4 ;;; Created: 2002-07-22
5 ;;; Author: Gilbert Baumann <gilbert@base-engineering.com>
6 ;;; License: MIT style (see below)
7 ;;; $Id: clim-gui.lisp,v 1.31 2007-02-04 15:10:01 dlichteblau Exp $
8 ;;; ---------------------------------------------------------------------------
9 ;;; (c) copyright 2002 by Gilbert Baumann
11 ;;; Permission is hereby granted, free of charge, to any person obtaining
12 ;;; a copy of this software and associated documentation files (the
13 ;;; "Software"), to deal in the Software without restriction, including
14 ;;; without limitation the rights to use, copy, modify, merge, publish,
15 ;;; distribute, sublicense, and/or sell copies of the Software, and to
16 ;;; permit persons to whom the Software is furnished to do so, subject to
17 ;;; the following conditions:
19 ;;; The above copyright notice and this permission notice shall be
20 ;;; included in all copies or substantial portions of the Software.
22 ;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
23 ;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
24 ;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
25 ;;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
26 ;;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
27 ;;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
28 ;;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
30 ;; $Log: clim-gui.lisp,v $
31 ;; Revision 1.31 2007-02-04 15:10:01 dlichteblau
34 ;; Revision 1.30 2007/01/07 19:32:06 emarsden
35 ;; Follow HTTP redirects (HTML-level redirects still not supported).
37 ;; Revision 1.29 2007/01/03 16:14:57 emarsden
38 ;; - new function RENDER-LHTML that renders LHTML
39 ;; - new command "Inspect Page" that runs Clouseau on the current document
41 ;; Revision 1.28 2007/01/03 11:34:45 emarsden
42 ;; GUI: implement beginning-of-page and end-of-page commands; add
43 ;; keyboard shortcuts for back & forward.
45 ;; Revision 1.27 2006/12/31 15:42:40 dlichteblau
47 ;; Use Bordeaux Threads for all threading primitives, so that non-GUI parts of
48 ;; Closure don't have to depend on CLIM anymore.
50 ;; - Removed all mp/ functions from glisp.
52 ;; - Use condition variables instead of process-wait.
54 ;; Revision 1.26 2006/12/31 13:26:23 emarsden
55 ;; - add basic wholine support (currently title & last-modified information)
56 ;; - add "TeX mode On" and "TeX mode Off" commands (experimental)
58 ;; Revision 1.25 2006/12/30 15:13:54 emarsden
59 ;; - use CL from Closure packages
61 ;; - move PARSE-X11-COLOR from clim-user to ws/x11 package
63 ;; Revision 1.24 2006/12/30 15:07:31 emarsden
64 ;; Minor improvements to user interface:
65 ;; - enable double buffering
66 ;; - wait until page has been downloaded before erasing previous page
67 ;; - enable busy cursor while downloading and rendering
69 ;; Revision 1.23 2006/12/29 17:37:07 dlichteblau
70 ;; Make closure start on Gtkairo:
72 ;; * src/gui/clim-gui.lisp (WRITE-STATUS, FOO, COM-REDRAW): Replace
73 ;; calls to xlib:display-finish-output with
74 ;; clim-backend:port-force-output.
76 ;; Revision 1.22 2005/08/25 15:14:14 crhodes
77 ;; OpenMCL support (from Dave Murray aka JQS)
79 ;; Revision 1.21 2005/08/25 15:05:48 crhodes
80 ;; Work around problems related to *closure-inited-p* (see #lisp logs for
81 ;; 2005-08-25 for more discussion). Not clear where the fault lies: sbcl,
82 ;; clx, mcclim[-freetype] or closure itself.
84 ;; Revision 1.20 2005/07/11 15:58:03 crhodes
85 ;; Complete the renaming *MEDIUM* -> *PANE*.
87 ;; Panes are CLIM extended-streams, and remember output to them in output
88 ;; records. Mediums are much simpler, and don't have this kind of
89 ;; memory. So, though the same drawing functions (DRAW-TEXT, DRAW-LINE)
90 ;; can have the same initial effect applied to a pane and a medium, the
91 ;; output-record state is very different.
93 ;; Revision 1.19 2005/07/10 11:18:34 emarsden
94 ;; Distinguish between pane and medium in the CLIM GUI. This should
97 ;; Revision 1.18 2005/07/10 10:57:20 emarsden
98 ;; Move a number of global variables from the CL-USER to the GUI package.
100 ;; Revision 1.17 2005/04/12 10:28:55 tdalyjr
101 ;; Since closure-frame-top-level is no longer used, comment it out.
103 ;; Use a :before method on run-frame-top-level to set
104 ;; *closure-inited-p*. (this used to be done by closure-frame-top-level)
106 ;; Reimplement the quit command using frame-exit, since the 'closure-quit
107 ;; catch tag no longer exists.
109 ;; Use process-interrupt from the clim-sys package, instead of from the
110 ;; mp package, since clim-sys should be more portable.
112 ;; Turn on scrollbars for the interactor pane, since otherwise it trashes
113 ;; the status line on the bottom of the window and stops updating.
115 ;; Revision 1.16 2005/03/13 21:17:28 emarsden
116 ;; - Implement PageUp and PageDown support in the CLIM GUI.
117 ;; - Add a Redraw command (with Ctrl-R accelerator)
119 ;; Revision 1.15 2005/03/13 21:15:06 emarsden
120 ;; Add zoom support to the renderer, accessible via the commands com-zoom-in,
121 ;; com-zoom-out and com-zoom-100%.
123 ;; Revision 1.14 2005/03/13 20:58:31 emarsden
124 ;; - Update to new McCLIM requirements on DEFINE-xx-COMMAND, adding :name t
125 ;; so that commands are available from listener pane
127 ;; Revision 1.13 2005/03/13 19:24:14 gbaumann
128 ;; make it at least compile and show a window with CMUCL 19a and cvs mcclim.
130 ;; Revision 1.12 2005/03/13 18:01:37 gbaumann
131 ;; Gross license change
133 ;; Revision 1.11 2003/06/15 17:24:24 gilbert
134 ;; fixes to the recent patches.
136 ;; Revision 1.10 2003/06/15 16:47:44 gilbert
137 ;; OpenMCL patches by Patrik Nordebo
139 ;; Revision 1.9 2003/03/16 17:46:19 gilbert
140 ;; we call xlib:display-finish-output when a page is finished.
142 ;; Revision 1.8 2003/03/14 17:06:16 dan
143 ;; replace defconstants for non-constant variables with defvar, to placate SBCL, which suffers from offensively ANSI behaviour with same
145 ;; Revision 1.7 2003/03/14 14:14:36 gilbert
146 ;; adjusted frame-top-level loop
148 ;; Revision 1.6 2003/03/13 20:17:23 gilbert
149 ;; CLX bug: xlib:put-image grind to halt when the image is widther than 2048 pixels.
151 ;; Revision 1.5 2003/03/13 19:29:17 gilbert
154 ;; Revision 1.4 2002/08/16 17:20:50 gilbert
157 ;; Revision 1.3 2002/07/29 12:39:08 gilbert
158 ;; - we pass more tests now
160 ;; Revision 1.2 2002/07/24 04:11:51 gilbert
161 ;; Tex Mode On and Tex Mode Off commands
163 ;; Revision 1.1.1.1 2002/07/22 02:27:22 gilbert
167 (in-package :CLIM-USER
)
176 (defvar *initial-url
* nil
)
178 (defvar *closure-process
* nil
)
180 (defclass closure-pane
(application-pane)
185 (defvar *back-history
* nil
)
186 (defvar *forw-history
* nil
)
188 (defun make-canvas (&key
(height 600) (min-height 600))
189 (scrolling (:width
830
191 :scroll-bar
:vertical
193 :min-height min-height
)
194 (make-pane 'closure-pane
199 (defmacro canvasly
(&rest spacereqs
)
201 (clim-tab-layout:with-tab-layout
202 ('clim-tab-layout
:tab-page
:name
'tab-layout
)
204 (make-canvas ,@spacereqs
)))))
206 (setf (slot-value *frame
* 'tabs
) tabs
)
209 (define-application-frame closure
()
211 (:menu-bar menubar-command-table
)
220 :incremental-redisplay t
222 :display-function
'aux-display
223 :display-time
:command-loop
)
224 (status :pointer-documentation
225 :text-style
(make-text-style :sans-serif
:roman
:normal
)
236 :background
(make-rgb-color 1 1 7/8)
237 :text-style
(make-text-style :sans-serif nil
:normal
)
238 :height
50 :min-height
50 :max-height
50
239 :scroll-bars t
:border nil
)
241 :pointer-documentation
:width
5 :max-width
+fill
+
243 :text-style
(make-text-style :sans-serif
:roman
10)
246 ;;(menu-bar (climi::make-menu-bar 'menubar-command-table :height 25))
251 (spacing (:thickness
5)
252 (canvasly :height
600 :min-height
400))
253 (spacing (:thickness
5)
255 (horizontally (:height
80 :min-height
80 :max-height
80)
261 (spacing (:thickness
5)
262 (canvasly :height
600 :min-height
600))
263 (horizontally (:height
80 :min-height
80 :max-height
80)
273 (canvasly :height
600 :min-height
400)))
278 ;; (:top-level (closure-frame-top-level . nil))
282 (make-command-table 'menubar-command-table
284 :menu
'(("File" :menu file-command-table
)
285 ("Go" :menu go-command-table
)
286 ;; ("Bookmarks" :menu bookmarks-command-table)
287 ;; ("View" :menu view-command-table)
288 ("Appearance" :menu appearance-command-table
)
291 (make-command-table 'appearance-command-table
:errorp nil
292 :menu
'(("Show Listener" :command com-show-listener
)
293 ("Hide Listener" :command com-hide-listener
)))
295 (make-command-table 'file-command-table
297 :menu
'(("New Tab" :command com-new-tab
)
298 ("Quit" :command com-quit
)))
300 (make-command-table 'go-command-table
302 :menu
'(("Back" :command com-back
)
303 ("Forward" :command com-forward
)
304 ("Home" :command com-home
)))
306 (make-command-table 'view-command-table
308 :menu
'(("Zoom" :menu zoom-command-table
)))
310 (make-command-table 'zoom-command-table
312 :menu
'(("Zoom In" :command com-zoom-in
)
313 ("Zoom Out" :command com-zoom-out
)
314 ("Zoom 100%" :command com-zoom-100%
)))
316 (make-command-table 'bookmarks-command-table
318 :menu
'(("Add" :command com-add-bookmark
)
319 ;;("Forward" :command com-forward)
322 ;;; This top level has been abandoned in favor of CLIM's built-in one,
323 ;;; but let's keep it for a little while to pillage. -- tpd 2005.4.9
324 ;; (defmethod closure-frame-top-level
325 ;; ((frame application-frame)
326 ;; &key (command-parser 'command-line-command-parser)
327 ;; (command-unparser 'command-line-command-unparser)
328 ;; (partial-command-parser
329 ;; 'command-line-read-remaining-arguments-for-partial-command)
330 ;; (prompt "Closure => "))
331 ;; (catch 'closure-quit
333 ;; (with-simple-restart (forget "Just forget this command, restart the command loop.")
334 ;; (let ((*standard-input* (frame-standard-input frame))
335 ;; (*standard-output* (frame-standard-output frame))
336 ;; (*query-io* (frame-query-io frame))
337 ;; (*pointer-documentation-output* (frame-pointer-documentation-output
339 ;; ;; during development, don't alter *error-output*
340 ;; ;; (*error-output* (frame-error-output frame))
341 ;; (*command-parser* command-parser)
342 ;; (*command-unparser* command-unparser)
343 ;; (*partial-command-parser* partial-command-parser)
344 ;; (prompt-style (make-text-style :sans-serif :bold :normal)))
345 ;; (let ((*application-frame* frame))
346 ;; (when *initial-url*
347 ;; (com-visit-url *initial-url*))
348 ;; (setf *initial-url* nil)
349 ;; (setf *closure-inited-p* t)
350 ;; (when *standard-input*
351 ;; (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
353 ;; (with-text-style (*standard-input* prompt-style)
354 ;; (if (stringp prompt)
355 ;; (write-string prompt *standard-input*)
356 ;; (funcall prompt *standard-input* frame))
357 ;; (finish-output *standard-input*)))
358 ;; (let ((command (read-frame-command frame)))
359 ;; (fresh-line *standard-input*)
360 ;; ;;(window-clear *standard-output*)
361 ;; (clim:window-clear *query-io*)
363 ;; (execute-frame-command frame command))
364 ;; (fresh-line *standard-input*)))))))))
366 (define-presentation-type url
())
367 (define-presentation-type r2
::pt
())
368 (define-presentation-type r2
::hyper-link
())
370 (defun scroller-child (scroller)
372 (find-if (lambda (x) (typep x
'climi
::viewport-pane
))
373 (sheet-children scroller
)))))
375 (defun current-page ()
376 (clim-tab-layout:tab-layout-enabled-page
(slot-value *frame
* 'tabs
)))
378 (defun current-pane ()
379 (scroller-child (clim-tab-layout:tab-page-pane
(current-page))))
381 ;; renders LHTML as per http://opensource.franz.com/xmlutils/xmlutils-dist/phtml.htm
382 (defun render-lhtml (location lhtml
)
383 (with-simple-restart (forget "Just forget rendering this page.")
384 (let* ((*package
* (find-package :r2
))
385 (*pane
* (current-pane))
386 (*medium
* (sheet-medium *pane
*))
387 (device (make-instance 'closure
/clim-device
::clim-device
:medium
*pane
*))
388 (doc (make-instance 'r2
::document
392 :pt
(sgml::lhtml-
>pt lhtml
)))
393 (*current-document
* doc
)
394 (closure-protocol:*user-agent
* nil
)
395 (closure-protocol:*document-language
* (make-instance 'r2
::html-4.0-document-language
))
396 (r2::*canvas-width
* (bounding-rectangle-width (sheet-parent *pane
*))))
397 (window-clear *pane
*)
398 (closure-protocol:render closure-protocol
:*document-language
*
401 (setf *current-pt
* (r2::document-pt doc
))
403 (clim-backend:port-force-output
(find-port))
406 ;;;; ----------------------------------------------------------------------------------------------------
410 (define-closure-command (com-remove-tab :name t
)
411 ((page 'clim-tab-layout
:tab-page
:prompt
"Tab page" :gesture
:delete
))
412 (clim-tab-layout:remove-page page
))
414 (define-closure-command (com-show-listener :name t
) ()
415 (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame
* 'interactor
))) t
))
417 (define-closure-command (com-hide-listener :name t
) ()
418 (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame
* 'interactor
))) nil
))
420 (define-closure-command (com-visit-url :name t
) ((url 'url
)) ;;; :gesture :select))
421 (let ((*standard-output
* *query-io
*)) ;;(find-pane-named *frame* 'interactor)))
422 (with-text-style (*standard-output
* (make-text-style :sans-serif
:roman
:normal
))
423 (format t
"You are visiting "))
425 (with-text-style (*standard-output
* (make-text-style :sans-serif
:roman
:normal
))
427 (setf *forw-history
* nil
428 *back-history
* (cons url
*back-history
*))
429 (let ((*standard-output
* *trace-output
*))
432 (define-gesture-name :visit-in-new-tab
:pointer-button-press
(:middle
))
434 (define-closure-command (com-visit-url-in-new-tab :name t
)
435 ((url 'url
:gesture
:visit-in-new-tab
))
437 (setf *pane
* (current-pane))
440 (define-closure-command (com-reflow :name t
) ()
443 (define-closure-command (com-back :name t
:keystroke
(:left
:control
)) ()
444 (let ((*standard-output
* *query-io
*))
445 (cond ((null (cdr *back-history
*))
446 (format t
"There is nowhere you can go back to.~%"))
448 (push (pop *back-history
*) *forw-history
*)
449 (format t
"Going back to ~S.~%" (first *back-history
*))
450 (foo (first *back-history
*))))))
452 (define-closure-command (com-forward :name t
:keystroke
(:right
:control
)) ()
453 (let ((*standard-output
* *query-io
*))
454 (cond ((null *forw-history
*)
455 (format t
"There is nowhere you can go forward to.~%"))
457 (push (pop *forw-history
*) *back-history
*)
458 (format t
"Going forward to ~S.~%" (first *back-history
*))
459 (foo (first *back-history
*))))))
461 (define-closure-command (com-reload :name t
) ()
462 (let ((*standard-output
* *query-io
*))
463 (cond ((null *back-history
*)
464 (format t
"There is nothing to reload.~%"))
466 (format t
"Reloading ~S.~%" (first *back-history
*))
467 (foo (first *back-history
*))))))
469 (define-closure-command (com-images-off :name t
) ()
470 (setf gui
:*user-wants-images-p
* nil
)
471 (format *query-io
* "Images are now off.~%"))
473 (define-closure-command (com-images-on :name t
) ()
474 (setf gui
:*user-wants-images-p
* t
)
475 (format *query-io
* "Images are now on. You may want to reload.~%"))
477 (define-closure-command (com-quit :name t
:keystroke
(#\q
:control
)) ()
478 (frame-exit *application-frame
*))
480 (defvar *open-new-tabs-in-background
* nil
)
482 (define-closure-command (com-new-tab :name t
:keystroke
(#\t :control
)) ()
483 (with-look-and-feel-realization
484 ((frame-manager *application-frame
*) *application-frame
*)
485 (clim-tab-layout:add-page
(make-instance 'clim-tab-layout
:tab-page
488 (slot-value *frame
* 'tabs
)
489 (not *open-new-tabs-in-background
*))))
491 (defun make-google-search-url (string)
493 (url:make-url
:query
(list
495 (cons "ie" "ISO-8859-1")
497 (url:parse-url
"http://www.google.com/search")))
499 (define-closure-command (com-reverse-search-google :name t
) ((url 'url
))
500 (let ((*standard-output
* *trace-output
*))
502 (make-google-search-url (format nil
"link:~A" url
)))))
504 (define-closure-command (com-search-google :name t
) ((what 'string
))
505 (com-visit-url (make-google-search-url what
)))
507 (define-closure-command (com-home :name t
) ()
508 (com-visit-url gui
:*home-page
*))
510 (define-presentation-translator fofo
513 :documentation
((object presentation stream
)
514 (princ "Goto " stream
)
515 (with-text-style (stream (make-text-style :fix nil nil
))
516 (princ (url:unparse-url object
) stream
))
521 (define-presentation-to-command-translator fofo
522 (url com-visit-url closure
524 :pointer-documentation
((object presentation stream
)
525 (princ "GOTO " stream
)
526 (with-text-style (stream (make-text-style :fix nil nil
))
527 (princ (if (url:url-p object
)
528 (url:unparse-url object
)
535 ;;;; ----------------------------------------------------------------------------------------------------
539 (defvar *closure-lock
* (clim-sys:make-recursive-lock
"Closure"))
541 (defmacro with-closure
(ignore &body body
)
542 (declare (ignore ignore
))
543 `(clim-sys:with-recursive-lock-held
(*closure-lock
*)
546 (defun parse-url* (url)
548 (string (url:parse-url url
))
551 (defun send-closure-command (command &rest args
)
554 (clim-sys:process-interrupt
*closure-process
*
555 #'(lambda () (apply command args
)))))
558 (defun closure:visit
(&optional
(url gui
:*home-page
*))
559 (and url
(setf url
(parse-url* url
)))
560 (cond ((and (null *closure-process
*) (null url
))
561 (setf *initial-url
* url
)
566 (send-closure-command 'com-visit-url url
)))))
568 (defun closure:start
()
571 (defun closure:stop
()
573 (when *closure-process
*
574 (send-closure-command 'com-quit
))))
576 (defvar *closure-inited-p
* nil
)
577 (defmethod clim:read-frame-command
:before
((frame closure
)
578 &key
&allow-other-keys
)
579 (unless *closure-inited-p
*
580 (setf *closure-inited-p
* t
)))
582 (defun ensure-closure ()
584 (unless *closure-process
*
585 (setf *closure-inited-p
* nil
)
587 (clim-sys:process-wait
"Waiting for closure init"
588 (lambda () *closure-inited-p
*)))))
590 (defun run-closure ()
592 (let* ((proxy (glisp:getenv
"http_proxy"))
593 (url (and proxy
(url:parse-url proxy
))))
595 (equal (url:url-protocol url
) "http"))
596 (format t
"~:[~&;; Using HTTP proxy ~S port ~S~%~;~]"
597 (setf netlib
::*use-http-proxy-p
* t
)
598 (setf netlib
::*http-proxy-host
* (url:url-host url
))
599 (setf netlib
::*http-proxy-port
* (url:url-port url
))))
601 ;; we go without one:
602 (setf netlib
::*use-http-proxy-p
* nil
))))
604 (setf CLUE-GUI2
::*PIXMAP-CACHE
* nil
)
605 (setf CLUE-GUI2
::*PIXMAP-CACHE
* nil
)
606 (setf CLUE-GUI2
::*DCACHE
* nil
)
607 (setf climi
::*3d-dark-color
* (make-gray-color .45))
608 (setf climi
::*3d-normal-color
* (make-gray-color .75))
609 (setf climi
::*3d-light-color
* (make-gray-color .92))
610 (setf climi
::*3d-inner-color
* (make-gray-color .65))
611 (setf clim-clx
::*clx-text-sizes
*
621 (setf *closure-process
*
622 (clim-sys:make-process
626 (setf *frame
* (make-application-frame 'closure
))
628 (run-frame-top-level *frame
*))
629 (ignore-errors (ws/netlib
::commit-cache
))
630 (setf *closure-process
* nil
)))
633 (defun write-status (string)
634 (window-clear (find-pane-named *frame
* 'status
))
635 (write-string string
(find-pane-named *frame
* 'status
))
636 (clim-backend:port-force-output
(find-port)))
638 (defun write-wholine (string)
639 (let ((wholine (find-pane-named *frame
* 'wholine
)))
640 (window-clear wholine
)
641 (write-string string wholine
)
642 (clim-backend:port-force-output
(find-port))))
646 (let ((*standard-output
* *trace-output
*))
647 (clim-sys:make-process
649 (with-simple-restart (forget "Just forget rendering this page.")
650 (let* ((*package
* (find-package :r2
))
651 (*pane
* (current-pane)))
652 (with-sheet-medium (*medium
* *pane
*)
653 (let ((device (make-instance 'closure
/clim-device
::clim-device
:medium
*pane
*)))
654 (setf (sheet-pointer-cursor *pane
*) :busy
)
655 (setq url
(r2::parse-url
* url
))
656 (let ((request (clue-gui2::make-request
:url url
:method
:get
)))
657 (write-status "Fetching Document ...")
658 (multiple-value-bind (io header
)
659 (clue-gui2::open-document-4 request
)
660 (let ((new-location (netlib::get-header-field header
:location
)))
662 (unless (string-equal new-location
(url:unparse-url url
))
663 (setq url
(url:parse-url new-location
)))))
664 (let* ((doc (make-instance 'r2
::document
666 :location
(r2::parse-url
* url
)
668 :pt
(clue-gui2::make-pt-from-input
670 (netlib::get-header-field header
:content-type
) url
) )))
671 (write-status "Rendering ...")
672 (setf *current-document
* doc
)
673 (let ((closure-protocol:*document-language
*
674 (if (sgml::pt-p
(r2::document-pt doc
))
675 (make-instance 'r2
::html-4.0-document-language
)
676 (make-instance 'r2
::xml-style-document-language
)))
677 (closure-protocol:*user-agent
* nil
)
678 (r2::*canvas-width
* (bounding-rectangle-width (sheet-parent *pane
*))))
679 (window-clear *pane
*)
680 (closure-protocol:render
681 closure-protocol
:*document-language
*
684 (setf *current-pt
* (r2::document-pt doc
))
688 (setf (clim-tab-layout:tab-page-title
(current-page))
689 (renderer::document-title
*current-document
*))
690 (write-wholine (format nil
"Title: ~A~%~@[Modified: ~A~]"
691 (renderer::document-title
*current-document
*)
692 (or (netlib::get-header-field header
:last-modified
)
693 (netlib::get-header-field header
:date
))))
694 (let ((x2 (bounding-rectangle-max-x (stream-output-history *pane
*)))
695 (y2 (bounding-rectangle-max-y (stream-output-history *pane
*))))
696 (setf y2
(max y2 r2
::*document-height
*))
697 (clim:change-space-requirements
*pane
* :width x2
:height y2
)
698 ;; While we are at it, force a repaint
699 (handle-repaint *pane
* (sheet-region (pane-viewport *pane
*)))
700 (clim-backend:port-force-output
(find-port)))))))
701 (setf (sheet-pointer-cursor *pane
*) :default
)
702 (write-status "Done.")))))
703 #+nil
(clim-backend:port-force-output
(find-port))))))
706 (let ((*standard-output
* *trace-output
*))
707 (funcall ;;clim-sys:make-process
709 (with-simple-restart (forget "Just forget rendering this page.")
710 (let ((*package
* (find-package :r2
))
711 (*pane
* (current-pane)))
712 (window-clear *pane
*)
713 (with-sheet-medium (*medium
* *pane
*)
714 (write-status "Rendering ...")
715 (let ((closure-protocol:*document-language
*
716 (if (sgml::pt-p
(r2::document-pt
*current-document
*))
717 (make-instance 'r2
::html-4.0-document-language
)
718 (make-instance 'r2
::xml-style-document-language
)))
719 (closure-protocol:*user-agent
* nil
)
721 (bounding-rectangle-width (sheet-parent *pane
*))))
723 (let ((x2 (bounding-rectangle-max-x (stream-output-history *pane
*)))
724 (y2 (bounding-rectangle-max-y (stream-output-history *pane
*))))
725 (setf y2
(max y2 r2
::*document-height
*))
726 (clim:change-space-requirements
*pane
* :width x2
:height y2
)
727 ;; While we are at it, force a repaint
728 (handle-repaint *pane
* (sheet-region (pane-viewport *pane
*)))))
729 (write-status "Done."))))))))
731 (defvar *current-document
*)
732 (defvar *current-pt
*)
734 ;;;; ----------------------------------------------------------------------------------------------------
736 (define-presentation-translator url-from-string
741 (define-presentation-method accept
((type url
)
743 (view (eql +textual-view
+))
744 &key default default-type
)
745 (url:parse-url
(accept 'string
:stream stream
:prompt nil
)))
750 (define-closure-command (com-clear-interactor :name t
) ()
751 (clim:window-clear
(clim:frame-query-io clim
:*application-frame
*)))
753 ;;;; ----------------------------------------------------------------------------------------------------
756 (define-closure-command (com-zoom-100%
:name t
) ()
757 (setq gui
:*zoom-factor
* 1.0)
758 (send-closure-command 'com-reflow
))
760 (define-closure-command (com-zoom-in :name t
:keystroke
(#\
+ :control
)) ()
761 (write-status "Zooming in...")
762 (setq gui
:*zoom-factor
* (* gui
:*zoom-factor
* 1.2))
763 (send-closure-command 'com-reflow
))
765 (define-closure-command (com-zoom-out :name t
:keystroke
(#\-
:control
)) ()
766 (write-status "Zooming out...")
767 (setq gui
:*zoom-factor
* (* gui
:*zoom-factor
* 0.8))
768 (send-closure-command 'com-reflow
))
770 (define-closure-command (com-page-up :name t
771 :keystroke
:prior
) ()
772 (let* ((pane (current-pane))
773 (scrollbar (slot-value (pane-scroller pane
) 'climi
::vscrollbar
))
774 (current-y (gadget-value scrollbar
))
775 (window-height (bounding-rectangle-height (pane-viewport-region pane
))))
776 (scroll-extent pane
0 (max (gadget-min-value scrollbar
) (- current-y
(* 0.9 window-height
))))))
778 (define-closure-command (com-page-down :name t
780 (let* ((pane (current-pane))
781 (scrollbar (slot-value (pane-scroller pane
) 'climi
::vscrollbar
))
782 (current-y (gadget-value scrollbar
))
783 (window-height (bounding-rectangle-height (pane-viewport-region pane
))))
784 (scroll-extent pane
0
785 (min (gadget-max-value scrollbar
) (+ current-y
(* 0.9 window-height
))))))
787 (define-closure-command (com-beginning-of-page :name t
788 :keystroke
(:home
:control
)) ()
789 (let* ((pane (current-pane))
790 (scrollbar (slot-value (pane-scroller pane
) 'climi
::vscrollbar
)))
791 (scroll-extent pane
0 (gadget-min-value scrollbar
))))
793 (define-closure-command (com-end-of-page :name t
794 :keystroke
(:end
:control
)) ()
795 (let* ((pane (current-pane))
796 (scrollbar (slot-value (pane-scroller pane
) 'climi
::vscrollbar
)))
797 (scroll-extent pane
0 (gadget-max-value scrollbar
))))
799 (define-closure-command (com-redraw :name t
:keystroke
(#\r :control
)) ()
800 (let* ((*pane
* (current-pane)))
801 (handle-repaint *pane
* (sheet-region (pane-viewport *pane
*))))
802 (clim-backend:port-force-output
(find-port)))
804 (define-closure-command (com-tex-mode-on :name t
) ()
805 (setq renderer
:*tex-mode-p
* t
)
806 (setq renderer
:*hyphenate-p
* t
)
807 (send-closure-command 'com-reflow
))
809 (define-closure-command (com-tex-mode-off :name t
) ()
810 (setq renderer
:*tex-mode-p
* nil
)
811 (setq renderer
:*hyphenate-p
* nil
)
812 (send-closure-command 'com-reflow
))
814 ;; for Closure developers
815 (define-closure-command (com-inspect-page :name t
) ()
816 (write-status "Loading Clouseau")
817 (asdf:oos
'asdf
:load-op
:clouseau
)
818 (write-status "Starting inspector")
819 (funcall (find-symbol "INSPECTOR" :clouseau
) *current-document
* :new-process t
))