src/gui/clim-gui.lisp

   1 ;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: CLIM-USER; -*-
   2 ;;; ---------------------------------------------------------------------------
   3 ;;;     Title: CLIM GUI
   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
  10
  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:
  18 ;;;
  19 ;;;  The above copyright notice and this permission notice shall be
  20 ;;;  included in all copies or substantial portions of the Software.
  21 ;;;
  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.
  29
  30 ;; $Log: clim-gui.lisp,v $
  31 ;; Revision 1.31  2007-02-04 15:10:01  dlichteblau
  32 ;; Tabbed browsing.
  33 ;;
  34 ;; Revision 1.30  2007/01/07 19:32:06  emarsden
  35 ;; Follow HTTP redirects (HTML-level redirects still not supported).
  36 ;;
  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
  40 ;;
  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.
  44 ;;
  45 ;; Revision 1.27  2006/12/31 15:42:40  dlichteblau
  46 ;;
  47 ;; Use Bordeaux Threads for all threading primitives, so that non-GUI parts of
  48 ;; Closure don't have to depend on CLIM anymore.
  49 ;;
  50 ;;   - Removed all mp/ functions from glisp.
  51 ;;
  52 ;;   - Use condition variables instead of process-wait.
  53 ;;
  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)
  57 ;;
  58 ;; Revision 1.25  2006/12/30 15:13:54  emarsden
  59 ;; - use CL from Closure packages
  60 ;; - minor rod fixes
  61 ;; - move PARSE-X11-COLOR from clim-user to ws/x11 package
  62 ;;
  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
  68 ;;
  69 ;; Revision 1.23  2006/12/29 17:37:07  dlichteblau
  70 ;; Make closure start on Gtkairo:
  71 ;;
  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.
  75 ;;
  76 ;; Revision 1.22  2005/08/25 15:14:14  crhodes
  77 ;; OpenMCL support (from Dave Murray aka JQS)
  78 ;;
  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.
  83 ;;
  84 ;; Revision 1.20  2005/07/11 15:58:03  crhodes
  85 ;; Complete the renaming *MEDIUM* -> *PANE*.
  86 ;;
  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.
  92 ;;
  93 ;; Revision 1.19  2005/07/10 11:18:34  emarsden
  94 ;; Distinguish between pane and medium in the CLIM GUI. This should
  95 ;; fix image display.
  96 ;;
  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.
  99 ;;
 100 ;; Revision 1.17  2005/04/12 10:28:55  tdalyjr
 101 ;; Since closure-frame-top-level is no longer used, comment it out.
 102 ;;
 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)
 105 ;;
 106 ;; Reimplement the quit command using frame-exit, since the 'closure-quit
 107 ;; catch tag no longer exists.
 108 ;;
 109 ;; Use process-interrupt from the clim-sys package, instead of from the
 110 ;; mp package, since clim-sys should be more portable.
 111 ;;
 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.
 114 ;;
 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)
 118 ;;
 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%.
 122 ;;
 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
 126 ;;
 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.
 129 ;;
 130 ;; Revision 1.12  2005/03/13 18:01:37  gbaumann
 131 ;; Gross license change
 132 ;;
 133 ;; Revision 1.11  2003/06/15 17:24:24  gilbert
 134 ;; fixes to the recent patches.
 135 ;;
 136 ;; Revision 1.10  2003/06/15 16:47:44  gilbert
 137 ;; OpenMCL patches by Patrik Nordebo
 138 ;;
 139 ;; Revision 1.9  2003/03/16 17:46:19  gilbert
 140 ;; we call xlib:display-finish-output when a page is finished.
 141 ;;
 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
 144 ;;
 145 ;; Revision 1.7  2003/03/14 14:14:36  gilbert
 146 ;; adjusted frame-top-level loop
 147 ;;
 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.
 150 ;;
 151 ;; Revision 1.5  2003/03/13 19:29:17  gilbert
 152 ;; lots of hacking
 153 ;;
 154 ;; Revision 1.4  2002/08/16 17:20:50  gilbert
 155 ;; url-entry fix
 156 ;;
 157 ;; Revision 1.3  2002/07/29 12:39:08  gilbert
 158 ;; - we pass more tests now
 159 ;;
 160 ;; Revision 1.2  2002/07/24 04:11:51  gilbert
 161 ;; Tex Mode On and Tex Mode Off commands
 162 ;;
 163 ;; Revision 1.1.1.1  2002/07/22 02:27:22  gilbert
 164 ;; imported sources
 165 ;;
 166
 167 (in-package :CLIM-USER)
 168 (use-package :clim)
 169
 170 ;;;;;;;
 171
 172 (defvar *medium*)
 173 (defvar *frame*)
 174 (defvar *pane*)
 175
 176 (defvar *initial-url* nil)
 177
 178 (defvar *closure-process* nil)
 179
 180 (defclass closure-pane (application-pane)
 181   ())
 182
 183 ;;; Crude History
 184
 185 (defvar *back-history* nil)
 186 (defvar *forw-history* nil)
 187
 188 (defun make-canvas (&key (height 600) (min-height 600))
 189   (scrolling (:width 830
 190                      :max-height 20000
 191                      :scroll-bar :vertical
 192                      :height height
 193                      :min-height min-height)
 194     (make-pane 'closure-pane
 195                :height 2000
 196                :width 800
 197                :display-time nil)))
 198
 199 (defmacro canvasly (&rest spacereqs)
 200   `(let ((tabs
 201           (clim-tab-layout:with-tab-layout
 202               ('clim-tab-layout:tab-page :name 'tab-layout)
 203             ("(Untitled)"
 204              (make-canvas ,@spacereqs)))))
 205      (assert *frame*)
 206      (setf (slot-value *frame* 'tabs) tabs)
 207      tabs))
 208
 209 (define-application-frame closure ()
 210   ((tabs))
 211   (:menu-bar menubar-command-table)
 212   (:panes
 213    (aux :application
 214     :height 300
 215     :width 300
 216     :min-width 100
 217     :min-height 100
 218     :max-width 300
 219     :max-height 20000
 220     :incremental-redisplay t
 221     :double-buffering 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)
 226     :scroll-bar nil
 227     :height 20
 228     :min-height 20
 229     :max-height 20
 230     :width 300
 231     :background +black+
 232     :foreground +white+)
 233    (interactor
 234     :interactor
 235     :foreground +black+
 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)
 240    (wholine
 241     :pointer-documentation :width 5 :max-width +fill+
 242     :height 25
 243     :text-style (make-text-style :sans-serif :roman 10)
 244     :foreground +white+
 245     :background +black+)
 246    ;;(menu-bar (climi::make-menu-bar 'menubar-command-table :height 25))
 247    )
 248   (:layouts
 249    (default
 250        (vertically ()
 251          (spacing (:thickness 5)
 252            (canvasly :height 600 :min-height 400))
 253          (spacing (:thickness 5)
 254                   interactor)
 255          (horizontally (:height 80 :min-height 80 :max-height 80)
 256            wholine
 257            2
 258            (200 status))))
 259    (hidden-listener
 260        (vertically ()
 261          (spacing (:thickness 5)
 262            (canvasly :height 600 :min-height 600))
 263          (horizontally (:height 80 :min-height 80 :max-height 80)
 264            wholine
 265            2
 266            (200 status))))
 267    #+NIL
 268    (hidden-listener
 269        (vertically ()
 270          menu-bar
 271          (horizontally ()
 272            (vertically ()
 273              (canvasly :height 600 :min-height 400)))
 274          (horizontally ()
 275            wholine
 276            2
 277            (200 status)))))
 278   ;; (:top-level (closure-frame-top-level . nil))
 279   )
 280
 281
 282 (make-command-table 'menubar-command-table
 283                     :errorp nil
 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)
 289                             ))
 290
 291 (make-command-table 'appearance-command-table :errorp nil
 292                     :menu '(("Show Listener" :command com-show-listener)
 293                             ("Hide Listener" :command com-hide-listener)))
 294
 295 (make-command-table 'file-command-table
 296                     :errorp nil
 297                     :menu '(("New Tab" :command com-new-tab)
 298                             ("Quit" :command com-quit)))
 299
 300 (make-command-table 'go-command-table
 301                     :errorp nil
 302                     :menu '(("Back" :command com-back)
 303                             ("Forward" :command com-forward)
 304                             ("Home" :command com-home)))
 305
 306 (make-command-table 'view-command-table
 307                     :errorp nil
 308                     :menu '(("Zoom"    :menu    zoom-command-table)))
 309
 310 (make-command-table 'zoom-command-table
 311                     :errorp nil
 312                     :menu '(("Zoom In" :command com-zoom-in)
 313                             ("Zoom Out" :command com-zoom-out)
 314                             ("Zoom 100%" :command com-zoom-100%)))
 315
 316 (make-command-table 'bookmarks-command-table
 317                     :errorp nil
 318                     :menu '(("Add" :command com-add-bookmark)
 319                             ;;("Forward" :command com-forward)
 320                             ))
 321
 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
 332 ;;     (loop
 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
 338 ;;                                                  frame))
 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)
 352 ;;                 (when prompt
 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*)
 362 ;;                   (when command
 363 ;;                     (execute-frame-command frame command))
 364 ;;                   (fresh-line *standard-input*)))))))))
 365
 366 (define-presentation-type url ())
 367 (define-presentation-type r2::pt ())
 368 (define-presentation-type r2::hyper-link ())
 369
 370 (defun scroller-child (scroller)
 371   (car (sheet-children
 372         (find-if (lambda (x) (typep x 'climi::viewport-pane))
 373                  (sheet-children scroller)))))
 374
 375 (defun current-page ()
 376   (clim-tab-layout:tab-layout-enabled-page (slot-value *frame* 'tabs)))
 377
 378 (defun current-pane ()
 379   (scroller-child (clim-tab-layout:tab-page-pane (current-page))))
 380
 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
 389                                :processes-hooks nil
 390                                :location location
 391                                :http-header nil
 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*
 399                                doc
 400                                device
 401                                (setf *current-pt* (r2::document-pt doc))
 402                                600 t 0)
 403       (clim-backend:port-force-output (find-port))
 404       (reflow))))
 405
 406 ;;;; ----------------------------------------------------------------------------------------------------
 407 ;;;; Commands
 408 ;;;;
 409
 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))
 413
 414 (define-closure-command (com-show-listener :name t) ()
 415   (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame* 'interactor))) t))
 416
 417 (define-closure-command (com-hide-listener :name t) ()
 418   (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame* 'interactor))) nil))
 419
 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 "))
 424     (present url 'url)
 425     (with-text-style (*standard-output* (make-text-style :sans-serif :roman :normal))
 426       (format t ".~%")))
 427   (setf *forw-history* nil
 428         *back-history* (cons url *back-history*))
 429   (let ((*standard-output* *trace-output*))
 430     (foo url)))
 431
 432 (define-gesture-name :visit-in-new-tab :pointer-button-press (:middle))
 433
 434 (define-closure-command (com-visit-url-in-new-tab :name t)
 435     ((url 'url :gesture :visit-in-new-tab))
 436   (com-new-tab)
 437   (setf *pane* (current-pane))
 438   (com-visit-url url))
 439
 440 (define-closure-command (com-reflow :name t) ()
 441   (reflow))
 442
 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.~%"))
 447           (t
 448            (push (pop *back-history*) *forw-history*)
 449            (format t "Going back to ~S.~%" (first *back-history*))
 450            (foo (first *back-history*))))))
 451
 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.~%"))
 456           (t
 457            (push (pop *forw-history*) *back-history*)
 458            (format t "Going forward to ~S.~%" (first *back-history*))
 459            (foo (first *back-history*))))))
 460
 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.~%"))
 465           (t
 466            (format t "Reloading ~S.~%" (first *back-history*))
 467            (foo (first *back-history*))))))
 468
 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.~%"))
 472
 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.~%"))
 476
 477 (define-closure-command (com-quit :name t :keystroke (#\q :control)) ()
 478   (frame-exit *application-frame*))
 479
 480 (defvar *open-new-tabs-in-background* nil)
 481
 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
 486                                 :title "(Untitled)"
 487                                 :pane (make-canvas))
 488                               (slot-value *frame* 'tabs)
 489                               (not *open-new-tabs-in-background*))))
 490
 491 (defun make-google-search-url (string)
 492   (url:merge-url
 493    (url:make-url :query (list
 494                          (cons "hl" "en")
 495                          (cons "ie" "ISO-8859-1")
 496                          (cons "q" string)))
 497    (url:parse-url "http://www.google.com/search")))
 498
 499 (define-closure-command (com-reverse-search-google :name t) ((url 'url))
 500   (let ((*standard-output* *trace-output*))
 501     (com-visit-url
 502      (make-google-search-url (format nil "link:~A" url)))))
 503
 504 (define-closure-command (com-search-google :name t) ((what 'string))
 505   (com-visit-url (make-google-search-url what)))
 506
 507 (define-closure-command (com-home :name t) ()
 508   (com-visit-url gui:*home-page*))
 509
 510 (define-presentation-translator fofo
 511     (url command closure
 512      :gesture :select
 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))
 517                      (princ "." stream)))
 518   (object)
 519   object)
 520
 521 (define-presentation-to-command-translator fofo
 522     (url com-visit-url closure
 523          :gesture :select
 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)
 529                                               object)
 530                                           stream))
 531                                  (princ "." stream)))
 532   (object)
 533   (list object))
 534
 535 ;;;; ----------------------------------------------------------------------------------------------------
 536 ;;;; Lisp Interface
 537 ;;;;
 538
 539 (defvar *closure-lock* (clim-sys:make-recursive-lock "Closure"))
 540
 541 (defmacro with-closure (ignore &body body)
 542   (declare (ignore ignore))
 543   `(clim-sys:with-recursive-lock-held (*closure-lock*)
 544     ,@body))
 545
 546 (defun parse-url* (url)
 547   (etypecase url
 548     (string (url:parse-url url))
 549     (url:url url)))
 550
 551 (defun send-closure-command (command &rest args)
 552   (ensure-closure)
 553   (with-closure ()
 554     (clim-sys:process-interrupt *closure-process*
 555                           #'(lambda () (apply command args)))))
 556
 557
 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)
 562          (ensure-closure))
 563         (t
 564          (ensure-closure)
 565          (when url
 566            (send-closure-command 'com-visit-url url)))))
 567
 568 (defun closure:start ()
 569   (closure:visit))
 570
 571 (defun closure:stop ()
 572   (with-closure ()
 573     (when *closure-process*
 574       (send-closure-command 'com-quit))))
 575
 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)))
 581
 582 (defun ensure-closure ()
 583   (with-closure ()
 584     (unless *closure-process*
 585       (setf *closure-inited-p* nil)
 586       (run-closure)
 587       (clim-sys:process-wait "Waiting for closure init"
 588                              (lambda () *closure-inited-p*)))))
 589
 590 (defun run-closure ()
 591   ;; Care for proxy
 592   (let* ((proxy (glisp:getenv "http_proxy"))
 593          (url   (and proxy (url:parse-url proxy))))
 594     (cond ((and url
 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))))
 600           (t
 601            ;; we go without one:
 602            (setf netlib::*use-http-proxy-p* nil))))
 603   ;;
 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*
 612         '(:normal 12
 613           :tiny 8
 614           :very-small 10
 615           :small 10
 616           :large 14
 617           :very-large 18
 618           :huge 24))
 619   (gui::init-closure)
 620   ;;
 621   (setf *closure-process*
 622         (clim-sys:make-process
 623          (lambda ()
 624            (unwind-protect
 625                 (progn
 626                   (setf *frame* (make-application-frame 'closure))
 627                   (setf *pane*  nil)
 628                   (run-frame-top-level *frame*))
 629              (ignore-errors (ws/netlib::commit-cache))
 630              (setf *closure-process* nil)))
 631          :name "Closure")))
 632
 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)))
 637
 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))))
 643
 644
 645 (defun foo (url)
 646   (let ((*standard-output* *trace-output*))
 647     (clim-sys:make-process
 648      (lambda ()
 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)))
 661                      (when new-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
 665                                               :processes-hooks nil
 666                                               :location (r2::parse-url* url)
 667                                               :http-header header
 668                                               :pt (clue-gui2::make-pt-from-input
 669                                                    io
 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*
 682                         doc
 683                         device
 684                         (setf *current-pt* (r2::document-pt doc))
 685                         600           ;xxx width
 686                         t             ;?
 687                         0)
 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))))))
 704
 705 (defun reflow ()
 706   (let ((*standard-output* *trace-output*))
 707     (funcall ;;clim-sys:make-process
 708      (lambda ()
 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)
 720                    (r2::*canvas-width*
 721                     (bounding-rectangle-width (sheet-parent *pane*))))
 722                (r2::reflow)
 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."))))))))
 730
 731 (defvar *current-document*)
 732 (defvar *current-pt*)
 733
 734 ;;;; ----------------------------------------------------------------------------------------------------
 735
 736 (define-presentation-translator url-from-string
 737     (string url closure)
 738   (x)
 739   (url:parse-url x))
 740
 741 (define-presentation-method accept ((type url)
 742                                     stream
 743                                     (view (eql +textual-view+))
 744                                     &key default default-type)
 745   (url:parse-url (accept 'string :stream stream :prompt nil)))
 746
 747
 748
 749
 750 (define-closure-command (com-clear-interactor :name t) ()
 751     (clim:window-clear (clim:frame-query-io clim:*application-frame*)))
 752
 753 ;;;; ----------------------------------------------------------------------------------------------------
 754
 755
 756 (define-closure-command (com-zoom-100% :name t) ()
 757   (setq gui:*zoom-factor* 1.0)
 758   (send-closure-command 'com-reflow))
 759
 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))
 764
 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))
 769
 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))))))
 777
 778 (define-closure-command (com-page-down :name t
 779                                        :keystroke :next) ()
 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))))))
 786
 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))))
 792
 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))))
 798
 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)))
 803
 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))
 808
 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))
 813
 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))
 820
 821
 822 ;; EOF