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.32 2007-06-30 14:00:04 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.32  2007-06-30 14:00:04  dlichteblau
  32 ;; New argument new-process to run-closure, which can be disabled to run
  33 ;; closure in a "blocking" mode.  Needed for clbuild, which wants to (quit)
  34 ;; after the application is done.
  35 ;;
  36 ;; Revision 1.31  2007/02/04 15:10:01  dlichteblau
  37 ;; Tabbed browsing.
  38 ;;
  39 ;; Revision 1.30  2007/01/07 19:32:06  emarsden
  40 ;; Follow HTTP redirects (HTML-level redirects still not supported).
  41 ;;
  42 ;; Revision 1.29  2007/01/03 16:14:57  emarsden
  43 ;; - new function RENDER-LHTML that renders LHTML
  44 ;; - new command "Inspect Page" that runs Clouseau on the current document
  45 ;;
  46 ;; Revision 1.28  2007/01/03 11:34:45  emarsden
  47 ;; GUI: implement beginning-of-page and end-of-page commands; add
  48 ;; keyboard shortcuts for back & forward.
  49 ;;
  50 ;; Revision 1.27  2006/12/31 15:42:40  dlichteblau
  51 ;;
  52 ;; Use Bordeaux Threads for all threading primitives, so that non-GUI parts of
  53 ;; Closure don't have to depend on CLIM anymore.
  54 ;;
  55 ;;   - Removed all mp/ functions from glisp.
  56 ;;
  57 ;;   - Use condition variables instead of process-wait.
  58 ;;
  59 ;; Revision 1.26  2006/12/31 13:26:23  emarsden
  60 ;; - add basic wholine support (currently title & last-modified information)
  61 ;; - add "TeX mode On" and "TeX mode Off" commands (experimental)
  62 ;;
  63 ;; Revision 1.25  2006/12/30 15:13:54  emarsden
  64 ;; - use CL from Closure packages
  65 ;; - minor rod fixes
  66 ;; - move PARSE-X11-COLOR from clim-user to ws/x11 package
  67 ;;
  68 ;; Revision 1.24  2006/12/30 15:07:31  emarsden
  69 ;; Minor improvements to user interface:
  70 ;;   - enable double buffering
  71 ;;   - wait until page has been downloaded before erasing previous page
  72 ;;   - enable busy cursor while downloading and rendering
  73 ;;
  74 ;; Revision 1.23  2006/12/29 17:37:07  dlichteblau
  75 ;; Make closure start on Gtkairo:
  76 ;;
  77 ;;      * src/gui/clim-gui.lisp (WRITE-STATUS, FOO, COM-REDRAW): Replace
  78 ;;         calls to xlib:display-finish-output with
  79 ;;         clim-backend:port-force-output.
  80 ;;
  81 ;; Revision 1.22  2005/08/25 15:14:14  crhodes
  82 ;; OpenMCL support (from Dave Murray aka JQS)
  83 ;;
  84 ;; Revision 1.21  2005/08/25 15:05:48  crhodes
  85 ;; Work around problems related to *closure-inited-p* (see #lisp logs for
  86 ;; 2005-08-25 for more discussion).  Not clear where the fault lies: sbcl,
  87 ;; clx, mcclim[-freetype] or closure itself.
  88 ;;
  89 ;; Revision 1.20  2005/07/11 15:58:03  crhodes
  90 ;; Complete the renaming *MEDIUM* -> *PANE*.
  91 ;;
  92 ;; Panes are CLIM extended-streams, and remember output to them in output
  93 ;; records.  Mediums are much simpler, and don't have this kind of
  94 ;; memory.  So, though the same drawing functions (DRAW-TEXT, DRAW-LINE)
  95 ;; can have the same initial effect applied to a pane and a medium, the
  96 ;; output-record state is very different.
  97 ;;
  98 ;; Revision 1.19  2005/07/10 11:18:34  emarsden
  99 ;; Distinguish between pane and medium in the CLIM GUI. This should
 100 ;; fix image display.
 101 ;;
 102 ;; Revision 1.18  2005/07/10 10:57:20  emarsden
 103 ;; Move a number of global variables from the CL-USER to the GUI package.
 104 ;;
 105 ;; Revision 1.17  2005/04/12 10:28:55  tdalyjr
 106 ;; Since closure-frame-top-level is no longer used, comment it out.
 107 ;;
 108 ;; Use a :before method on run-frame-top-level to set
 109 ;; *closure-inited-p*. (this used to be done by closure-frame-top-level)
 110 ;;
 111 ;; Reimplement the quit command using frame-exit, since the 'closure-quit
 112 ;; catch tag no longer exists.
 113 ;;
 114 ;; Use process-interrupt from the clim-sys package, instead of from the
 115 ;; mp package, since clim-sys should be more portable.
 116 ;;
 117 ;; Turn on scrollbars for the interactor pane, since otherwise it trashes
 118 ;; the status line on the bottom of the window and stops updating.
 119 ;;
 120 ;; Revision 1.16  2005/03/13 21:17:28  emarsden
 121 ;;  - Implement PageUp and PageDown support in the CLIM GUI.
 122 ;;  - Add a Redraw command (with Ctrl-R accelerator)
 123 ;;
 124 ;; Revision 1.15  2005/03/13 21:15:06  emarsden
 125 ;; Add zoom support to the renderer, accessible via the commands com-zoom-in,
 126 ;; com-zoom-out and com-zoom-100%.
 127 ;;
 128 ;; Revision 1.14  2005/03/13 20:58:31  emarsden
 129 ;;  - Update to new McCLIM requirements on DEFINE-xx-COMMAND, adding :name t
 130 ;;    so that commands are available from listener pane
 131 ;;
 132 ;; Revision 1.13  2005/03/13 19:24:14  gbaumann
 133 ;; make it at least compile and show a window with CMUCL 19a and cvs mcclim.
 134 ;;
 135 ;; Revision 1.12  2005/03/13 18:01:37  gbaumann
 136 ;; Gross license change
 137 ;;
 138 ;; Revision 1.11  2003/06/15 17:24:24  gilbert
 139 ;; fixes to the recent patches.
 140 ;;
 141 ;; Revision 1.10  2003/06/15 16:47:44  gilbert
 142 ;; OpenMCL patches by Patrik Nordebo
 143 ;;
 144 ;; Revision 1.9  2003/03/16 17:46:19  gilbert
 145 ;; we call xlib:display-finish-output when a page is finished.
 146 ;;
 147 ;; Revision 1.8  2003/03/14 17:06:16  dan
 148 ;; replace defconstants for non-constant variables with defvar, to placate SBCL, which suffers from offensively ANSI behaviour with same
 149 ;;
 150 ;; Revision 1.7  2003/03/14 14:14:36  gilbert
 151 ;; adjusted frame-top-level loop
 152 ;;
 153 ;; Revision 1.6  2003/03/13 20:17:23  gilbert
 154 ;; CLX bug: xlib:put-image grind to halt when the image is widther than 2048 pixels.
 155 ;;
 156 ;; Revision 1.5  2003/03/13 19:29:17  gilbert
 157 ;; lots of hacking
 158 ;;
 159 ;; Revision 1.4  2002/08/16 17:20:50  gilbert
 160 ;; url-entry fix
 161 ;;
 162 ;; Revision 1.3  2002/07/29 12:39:08  gilbert
 163 ;; - we pass more tests now
 164 ;;
 165 ;; Revision 1.2  2002/07/24 04:11:51  gilbert
 166 ;; Tex Mode On and Tex Mode Off commands
 167 ;;
 168 ;; Revision 1.1.1.1  2002/07/22 02:27:22  gilbert
 169 ;; imported sources
 170 ;;
 171
 172 (in-package :CLIM-USER)
 173 (use-package :clim)
 174
 175 ;;;;;;;
 176
 177 (defvar *medium*)
 178 (defvar *frame*)
 179 (defvar *pane*)
 180
 181 (defvar *initial-url* nil)
 182
 183 (defvar *closure-process* nil)
 184
 185 (defclass closure-pane (application-pane)
 186   ())
 187
 188 ;;; Crude History
 189
 190 (defvar *back-history* nil)
 191 (defvar *forw-history* nil)
 192
 193 (defun make-canvas (&key (height 600) (min-height 600))
 194   (scrolling (:width 830
 195                      :max-height 20000
 196                      :scroll-bar :vertical
 197                      :height height
 198                      :min-height min-height)
 199     (make-pane 'closure-pane
 200                :height 2000
 201                :width 800
 202                :display-time nil)))
 203
 204 (defmacro canvasly (&rest spacereqs)
 205   `(let ((tabs
 206           (clim-tab-layout:with-tab-layout
 207               ('clim-tab-layout:tab-page :name 'tab-layout)
 208             ("(Untitled)"
 209              (make-canvas ,@spacereqs)))))
 210      (assert *frame*)
 211      (setf (slot-value *frame* 'tabs) tabs)
 212      tabs))
 213
 214 (define-application-frame closure ()
 215   ((tabs))
 216   (:menu-bar menubar-command-table)
 217   (:panes
 218    (aux :application
 219     :height 300
 220     :width 300
 221     :min-width 100
 222     :min-height 100
 223     :max-width 300
 224     :max-height 20000
 225     :incremental-redisplay t
 226     :double-buffering t
 227     :display-function 'aux-display
 228     :display-time :command-loop)
 229    (status :pointer-documentation
 230     :text-style (make-text-style :sans-serif :roman :normal)
 231     :scroll-bar nil
 232     :height 20
 233     :min-height 20
 234     :max-height 20
 235     :width 300
 236     :background +black+
 237     :foreground +white+)
 238    (interactor
 239     :interactor
 240     :foreground +black+
 241     :background (make-rgb-color 1 1 7/8)
 242     :text-style (make-text-style :sans-serif nil :normal)
 243     :height 50 :min-height 50 :max-height 50
 244     :scroll-bars t :border nil)
 245    (wholine
 246     :pointer-documentation :width 5 :max-width +fill+
 247     :height 25
 248     :text-style (make-text-style :sans-serif :roman 10)
 249     :foreground +white+
 250     :background +black+)
 251    ;;(menu-bar (climi::make-menu-bar 'menubar-command-table :height 25))
 252    )
 253   (:layouts
 254    (default
 255        (vertically ()
 256          (spacing (:thickness 5)
 257            (canvasly :height 600 :min-height 400))
 258          (spacing (:thickness 5)
 259                   interactor)
 260          (horizontally (:height 80 :min-height 80 :max-height 80)
 261            wholine
 262            2
 263            (200 status))))
 264    (hidden-listener
 265        (vertically ()
 266          (spacing (:thickness 5)
 267            (canvasly :height 600 :min-height 600))
 268          (horizontally (:height 80 :min-height 80 :max-height 80)
 269            wholine
 270            2
 271            (200 status))))
 272    #+NIL
 273    (hidden-listener
 274        (vertically ()
 275          menu-bar
 276          (horizontally ()
 277            (vertically ()
 278              (canvasly :height 600 :min-height 400)))
 279          (horizontally ()
 280            wholine
 281            2
 282            (200 status)))))
 283   ;; (:top-level (closure-frame-top-level . nil))
 284   )
 285
 286
 287 (make-command-table 'menubar-command-table
 288                     :errorp nil
 289                     :menu '(("File" :menu file-command-table)
 290                             ("Go"   :menu go-command-table)
 291                             ;; ("Bookmarks"   :menu bookmarks-command-table)
 292                             ;; ("View"     :menu view-command-table)
 293                             ("Appearance" :menu appearance-command-table)
 294                             ))
 295
 296 (make-command-table 'appearance-command-table :errorp nil
 297                     :menu '(("Show Listener" :command com-show-listener)
 298                             ("Hide Listener" :command com-hide-listener)))
 299
 300 (make-command-table 'file-command-table
 301                     :errorp nil
 302                     :menu '(("New Tab" :command com-new-tab)
 303                             ("Quit" :command com-quit)))
 304
 305 (make-command-table 'go-command-table
 306                     :errorp nil
 307                     :menu '(("Back" :command com-back)
 308                             ("Forward" :command com-forward)
 309                             ("Home" :command com-home)))
 310
 311 (make-command-table 'view-command-table
 312                     :errorp nil
 313                     :menu '(("Zoom"    :menu    zoom-command-table)))
 314
 315 (make-command-table 'zoom-command-table
 316                     :errorp nil
 317                     :menu '(("Zoom In" :command com-zoom-in)
 318                             ("Zoom Out" :command com-zoom-out)
 319                             ("Zoom 100%" :command com-zoom-100%)))
 320
 321 (make-command-table 'bookmarks-command-table
 322                     :errorp nil
 323                     :menu '(("Add" :command com-add-bookmark)
 324                             ;;("Forward" :command com-forward)
 325                             ))
 326
 327 ;;; This top level has been abandoned in favor of CLIM's built-in one,
 328 ;;; but let's keep it for a little while to pillage.  -- tpd 2005.4.9
 329 ;; (defmethod closure-frame-top-level
 330 ;;     ((frame application-frame)
 331 ;;      &key (command-parser 'command-line-command-parser)
 332 ;;      (command-unparser 'command-line-command-unparser)
 333 ;;      (partial-command-parser
 334 ;;       'command-line-read-remaining-arguments-for-partial-command)
 335 ;;      (prompt "Closure => "))
 336 ;;   (catch 'closure-quit
 337 ;;     (loop
 338 ;;         (with-simple-restart (forget "Just forget this command, restart the command loop.")
 339 ;;           (let ((*standard-input* (frame-standard-input frame))
 340 ;;                 (*standard-output* (frame-standard-output frame))
 341 ;;                 (*query-io* (frame-query-io frame))
 342 ;;                 (*pointer-documentation-output* (frame-pointer-documentation-output
 343 ;;                                                  frame))
 344 ;;                 ;; during development, don't alter *error-output*
 345 ;;                 ;; (*error-output* (frame-error-output frame))
 346 ;;                 (*command-parser* command-parser)
 347 ;;                 (*command-unparser* command-unparser)
 348 ;;                 (*partial-command-parser* partial-command-parser)
 349 ;;                 (prompt-style (make-text-style :sans-serif :bold :normal)))
 350 ;;             (let ((*application-frame* frame))
 351 ;;               (when *initial-url*
 352 ;;                 (com-visit-url *initial-url*))
 353 ;;               (setf *initial-url* nil)
 354 ;;               (setf *closure-inited-p* t)
 355 ;;               (when *standard-input*
 356 ;;                 (setf (cursor-visibility (stream-text-cursor *standard-input*)) t)
 357 ;;                 (when prompt
 358 ;;                   (with-text-style (*standard-input* prompt-style)
 359 ;;                     (if (stringp prompt)
 360 ;;                         (write-string prompt *standard-input*)
 361 ;;                         (funcall prompt *standard-input* frame))
 362 ;;                     (finish-output *standard-input*)))
 363 ;;                 (let ((command (read-frame-command frame)))
 364 ;;                   (fresh-line *standard-input*)
 365 ;;                   ;;(window-clear *standard-output*)
 366 ;;                   (clim:window-clear *query-io*)
 367 ;;                   (when command
 368 ;;                     (execute-frame-command frame command))
 369 ;;                   (fresh-line *standard-input*)))))))))
 370
 371 (define-presentation-type url ())
 372 (define-presentation-type r2::pt ())
 373 (define-presentation-type r2::hyper-link ())
 374
 375 (defun scroller-child (scroller)
 376   (car (sheet-children
 377         (find-if (lambda (x) (typep x 'climi::viewport-pane))
 378                  (sheet-children scroller)))))
 379
 380 (defun current-page ()
 381   (clim-tab-layout:tab-layout-enabled-page (slot-value *frame* 'tabs)))
 382
 383 (defun current-pane ()
 384   (scroller-child (clim-tab-layout:tab-page-pane (current-page))))
 385
 386 ;; renders LHTML as per http://opensource.franz.com/xmlutils/xmlutils-dist/phtml.htm
 387 (defun render-lhtml (location lhtml)
 388   (with-simple-restart (forget "Just forget rendering this page.")
 389     (let* ((*package* (find-package :r2))
 390            (*pane* (current-pane))
 391            (*medium* (sheet-medium *pane*))
 392            (device (make-instance 'closure/clim-device::clim-device :medium *pane*))
 393            (doc (make-instance 'r2::document
 394                                :processes-hooks nil
 395                                :location location
 396                                :http-header nil
 397                                :pt (sgml::lhtml->pt lhtml)))
 398            (*current-document* doc)
 399            (closure-protocol:*user-agent* nil)
 400            (closure-protocol:*document-language* (make-instance 'r2::html-4.0-document-language))
 401            (r2::*canvas-width* (bounding-rectangle-width (sheet-parent *pane*))))
 402       (window-clear *pane*)
 403       (closure-protocol:render closure-protocol:*document-language*
 404                                doc
 405                                device
 406                                (setf *current-pt* (r2::document-pt doc))
 407                                600 t 0)
 408       (clim-backend:port-force-output (find-port))
 409       (reflow))))
 410
 411 ;;;; ----------------------------------------------------------------------------------------------------
 412 ;;;; Commands
 413 ;;;;
 414
 415 (define-closure-command (com-remove-tab :name t)
 416     ((page 'clim-tab-layout:tab-page :prompt "Tab page" :gesture :delete))
 417   (clim-tab-layout:remove-page page))
 418
 419 (define-closure-command (com-show-listener :name t) ()
 420   (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame* 'interactor))) t))
 421
 422 (define-closure-command (com-hide-listener :name t) ()
 423   (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame* 'interactor))) nil))
 424
 425 (define-closure-command (com-visit-url :name t) ((url 'url)) ;;; :gesture :select))
 426   (let ((*standard-output* *query-io*)) ;;(find-pane-named *frame* 'interactor)))
 427     (with-text-style (*standard-output* (make-text-style :sans-serif :roman :normal))
 428       (format t "You are visiting "))
 429     (present url 'url)
 430     (with-text-style (*standard-output* (make-text-style :sans-serif :roman :normal))
 431       (format t ".~%")))
 432   (setf *forw-history* nil
 433         *back-history* (cons url *back-history*))
 434   (let ((*standard-output* *trace-output*))
 435     (foo url)))
 436
 437 (define-gesture-name :visit-in-new-tab :pointer-button-press (:middle))
 438
 439 (define-closure-command (com-visit-url-in-new-tab :name t)
 440     ((url 'url :gesture :visit-in-new-tab))
 441   (com-new-tab)
 442   (setf *pane* (current-pane))
 443   (com-visit-url url))
 444
 445 (define-closure-command (com-reflow :name t) ()
 446   (reflow))
 447
 448 (define-closure-command (com-back :name t :keystroke (:left :control)) ()
 449   (let ((*standard-output* *query-io*))
 450     (cond ((null (cdr *back-history*))
 451            (format t "There is nowhere you can go back to.~%"))
 452           (t
 453            (push (pop *back-history*) *forw-history*)
 454            (format t "Going back to ~S.~%" (first *back-history*))
 455            (foo (first *back-history*))))))
 456
 457 (define-closure-command (com-forward :name t :keystroke (:right :control)) ()
 458   (let ((*standard-output* *query-io*))
 459     (cond ((null *forw-history*)
 460            (format t "There is nowhere you can go forward to.~%"))
 461           (t
 462            (push (pop *forw-history*) *back-history*)
 463            (format t "Going forward to ~S.~%" (first *back-history*))
 464            (foo (first *back-history*))))))
 465
 466 (define-closure-command (com-reload :name t) ()
 467   (let ((*standard-output* *query-io*))
 468     (cond ((null *back-history*)
 469            (format t "There is nothing to reload.~%"))
 470           (t
 471            (format t "Reloading ~S.~%" (first *back-history*))
 472            (foo (first *back-history*))))))
 473
 474 (define-closure-command (com-images-off :name t) ()
 475   (setf gui:*user-wants-images-p* nil)
 476   (format *query-io* "Images are now off.~%"))
 477
 478 (define-closure-command (com-images-on :name t) ()
 479   (setf gui:*user-wants-images-p* t)
 480   (format *query-io* "Images are now on. You may want to reload.~%"))
 481
 482 (define-closure-command (com-quit :name t :keystroke (#\q :control)) ()
 483   (frame-exit *application-frame*))
 484
 485 (defvar *open-new-tabs-in-background* nil)
 486
 487 (define-closure-command (com-new-tab :name t :keystroke (#\t :control)) ()
 488   (with-look-and-feel-realization
 489       ((frame-manager *application-frame*) *application-frame*)
 490     (clim-tab-layout:add-page (make-instance 'clim-tab-layout:tab-page
 491                                 :title "(Untitled)"
 492                                 :pane (make-canvas))
 493                               (slot-value *frame* 'tabs)
 494                               (not *open-new-tabs-in-background*))))
 495
 496 (defun make-google-search-url (string)
 497   (url:merge-url
 498    (url:make-url :query (list
 499                          (cons "hl" "en")
 500                          (cons "ie" "ISO-8859-1")
 501                          (cons "q" string)))
 502    (url:parse-url "http://www.google.com/search")))
 503
 504 (define-closure-command (com-reverse-search-google :name t) ((url 'url))
 505   (let ((*standard-output* *trace-output*))
 506     (com-visit-url
 507      (make-google-search-url (format nil "link:~A" url)))))
 508
 509 (define-closure-command (com-search-google :name t) ((what 'string))
 510   (com-visit-url (make-google-search-url what)))
 511
 512 (define-closure-command (com-home :name t) ()
 513   (com-visit-url gui:*home-page*))
 514
 515 (define-presentation-translator fofo
 516     (url command closure
 517      :gesture :select
 518      :documentation ((object presentation stream)
 519                      (princ "Goto " stream)
 520                      (with-text-style (stream (make-text-style :fix nil nil))
 521                        (princ (url:unparse-url object) stream))
 522                      (princ "." stream)))
 523   (object)
 524   object)
 525
 526 (define-presentation-to-command-translator fofo
 527     (url com-visit-url closure
 528          :gesture :select
 529          :pointer-documentation ((object presentation stream)
 530                                  (princ "GOTO " stream)
 531                                  (with-text-style (stream (make-text-style :fix nil nil))
 532                                    (princ (if (url:url-p object)
 533                                               (url:unparse-url object)
 534                                               object)
 535                                           stream))
 536                                  (princ "." stream)))
 537   (object)
 538   (list object))
 539
 540 ;;;; ----------------------------------------------------------------------------------------------------
 541 ;;;; Lisp Interface
 542 ;;;;
 543
 544 (defvar *closure-lock* (clim-sys:make-recursive-lock "Closure"))
 545
 546 (defmacro with-closure (ignore &body body)
 547   (declare (ignore ignore))
 548   `(clim-sys:with-recursive-lock-held (*closure-lock*)
 549     ,@body))
 550
 551 (defun parse-url* (url)
 552   (etypecase url
 553     (string (url:parse-url url))
 554     (url:url url)))
 555
 556 (defun send-closure-command (command &rest args)
 557   (ensure-closure)
 558   (with-closure ()
 559     (clim-sys:process-interrupt *closure-process*
 560                           #'(lambda () (apply command args)))))
 561
 562
 563 (defun closure:visit (&optional (url gui:*home-page*))
 564   (and url (setf url (parse-url* url)))
 565   (cond ((and (null *closure-process*) (null url))
 566          (setf *initial-url* url)
 567          (ensure-closure))
 568         (t
 569          (ensure-closure)
 570          (when url
 571            (send-closure-command 'com-visit-url url)))))
 572
 573 (defun closure:start ()
 574   (closure:visit))
 575
 576 (defun closure:stop ()
 577   (with-closure ()
 578     (when *closure-process*
 579       (send-closure-command 'com-quit))))
 580
 581 (defvar *closure-inited-p* nil)
 582 (defmethod clim:read-frame-command :before ((frame closure)
 583                                                &key &allow-other-keys)
 584   (unless *closure-inited-p*
 585     (setf *closure-inited-p* t)))
 586
 587 (defun ensure-closure ()
 588   (with-closure ()
 589     (unless *closure-process*
 590       (setf *closure-inited-p* nil)
 591       (run-closure)
 592       (clim-sys:process-wait "Waiting for closure init"
 593                              (lambda () *closure-inited-p*)))))
 594
 595 (defun run-closure (&key (new-process t))
 596   ;; Care for proxy
 597   (let* ((proxy (glisp:getenv "http_proxy"))
 598          (url   (and proxy (url:parse-url proxy))))
 599     (cond ((and url
 600                 (equal (url:url-protocol url) "http"))
 601            (format t "~:[~&;; Using HTTP proxy ~S port ~S~%~;~]"
 602                    (setf netlib::*use-http-proxy-p* t)
 603                    (setf netlib::*http-proxy-host* (url:url-host url))
 604                    (setf netlib::*http-proxy-port* (url:url-port url))))
 605           (t
 606            ;; we go without one:
 607            (setf netlib::*use-http-proxy-p* nil))))
 608   ;;
 609   (setf CLUE-GUI2::*PIXMAP-CACHE* nil)
 610   (setf CLUE-GUI2::*PIXMAP-CACHE* nil)
 611   (setf CLUE-GUI2::*DCACHE* nil)
 612   (setf climi::*3d-dark-color*   (make-gray-color .45))
 613   (setf climi::*3d-normal-color* (make-gray-color .75))
 614   (setf climi::*3d-light-color*  (make-gray-color .92))
 615   (setf climi::*3d-inner-color*  (make-gray-color .65))
 616   (setf clim-clx::*clx-text-sizes*
 617         '(:normal 12
 618           :tiny 8
 619           :very-small 10
 620           :small 10
 621           :large 14
 622           :very-large 18
 623           :huge 24))
 624   (gui::init-closure)
 625   ;;
 626   (flet ((run-frame ()
 627            (unwind-protect
 628                 (progn
 629                   (setf *frame* (make-application-frame 'closure))
 630                   (setf *pane*  nil)
 631                   (run-frame-top-level *frame*))
 632              (ignore-errors (ws/netlib::commit-cache))
 633              (setf *closure-process* nil))))
 634     (cond (new-process
 635            (setf *closure-process*
 636                  (clim-sys:make-process #'run-frame :name "Closure")))
 637           (t
 638            (setf *closure-process* (clim-sys:current-process))
 639            (run-frame)))))
 640
 641 (defun write-status (string)
 642   (window-clear (find-pane-named *frame* 'status))
 643   (write-string string (find-pane-named *frame* 'status))
 644   (clim-backend:port-force-output (find-port)))
 645
 646 (defun write-wholine (string)
 647   (let ((wholine (find-pane-named *frame* 'wholine)))
 648     (window-clear wholine)
 649     (write-string string wholine)
 650     (clim-backend:port-force-output (find-port))))
 651
 652
 653 (defun foo (url)
 654   (let ((*standard-output* *trace-output*))
 655     (clim-sys:make-process
 656      (lambda ()
 657        (with-simple-restart (forget "Just forget rendering this page.")
 658          (let* ((*package* (find-package :r2))
 659                 (*pane* (current-pane)))
 660            (with-sheet-medium (*medium* *pane*)
 661              (let ((device (make-instance 'closure/clim-device::clim-device :medium *pane*)))
 662                (setf (sheet-pointer-cursor *pane*) :busy)
 663                (setq url (r2::parse-url* url))
 664                (let ((request (clue-gui2::make-request :url url :method :get)))
 665                  (write-status "Fetching Document ...")
 666                  (multiple-value-bind (io header)
 667                      (clue-gui2::open-document-4 request)
 668                    (let ((new-location (netlib::get-header-field header :location)))
 669                      (when new-location
 670                        (unless (string-equal new-location (url:unparse-url url))
 671                          (setq url (url:parse-url new-location)))))
 672                    (let* ((doc (make-instance 'r2::document
 673                                               :processes-hooks nil
 674                                               :location (r2::parse-url* url)
 675                                               :http-header header
 676                                               :pt (clue-gui2::make-pt-from-input
 677                                                    io
 678                                                    (netlib::get-header-field header :content-type) url) )))
 679                      (write-status "Rendering ...")
 680                      (setf *current-document* doc)
 681                      (let ((closure-protocol:*document-language*
 682                             (if (sgml::pt-p (r2::document-pt doc))
 683                                 (make-instance 'r2::html-4.0-document-language)
 684                                 (make-instance 'r2::xml-style-document-language)))
 685                            (closure-protocol:*user-agent* nil)
 686                            (r2::*canvas-width* (bounding-rectangle-width (sheet-parent *pane*))))
 687                        (window-clear *pane*)
 688                        (closure-protocol:render
 689                         closure-protocol:*document-language*
 690                         doc
 691                         device
 692                         (setf *current-pt* (r2::document-pt doc))
 693                         600           ;xxx width
 694                         t             ;?
 695                         0)
 696                        (setf (clim-tab-layout:tab-page-title (current-page))
 697                              (renderer::document-title *current-document*))
 698                        (write-wholine (format nil "Title: ~A~%~@[Modified: ~A~]"
 699                                               (renderer::document-title *current-document*)
 700                                               (or (netlib::get-header-field header :last-modified)
 701                                                   (netlib::get-header-field header :date))))
 702                        (let ((x2 (bounding-rectangle-max-x (stream-output-history *pane*)))
 703                              (y2 (bounding-rectangle-max-y (stream-output-history *pane*))))
 704                          (setf y2 (max y2 r2::*document-height*))
 705                          (clim:change-space-requirements *pane* :width x2 :height y2)
 706                          ;; While we are at it, force a repaint
 707                          (handle-repaint *pane* (sheet-region (pane-viewport *pane*)))
 708                          (clim-backend:port-force-output (find-port)))))))
 709                (setf (sheet-pointer-cursor *pane*) :default)
 710                (write-status "Done.")))))
 711        #+nil (clim-backend:port-force-output (find-port))))))
 712
 713 (defun reflow ()
 714   (let ((*standard-output* *trace-output*))
 715     (funcall ;;clim-sys:make-process
 716      (lambda ()
 717        (with-simple-restart (forget "Just forget rendering this page.")
 718          (let ((*package* (find-package :r2))
 719                (*pane* (current-pane)))
 720            (window-clear *pane*)
 721            (with-sheet-medium (*medium* *pane*)
 722              (write-status "Rendering ...")
 723              (let ((closure-protocol:*document-language*
 724                     (if (sgml::pt-p (r2::document-pt *current-document*))
 725                         (make-instance 'r2::html-4.0-document-language)
 726                         (make-instance 'r2::xml-style-document-language)))
 727                    (closure-protocol:*user-agent* nil)
 728                    (r2::*canvas-width*
 729                     (bounding-rectangle-width (sheet-parent *pane*))))
 730                (r2::reflow)
 731                (let ((x2 (bounding-rectangle-max-x (stream-output-history *pane*)))
 732                      (y2 (bounding-rectangle-max-y (stream-output-history *pane*))))
 733                  (setf y2 (max y2 r2::*document-height*))
 734                  (clim:change-space-requirements *pane* :width x2 :height y2)
 735                  ;; While we are at it, force a repaint
 736                  (handle-repaint *pane* (sheet-region (pane-viewport *pane*)))))
 737              (write-status "Done."))))))))
 738
 739 (defvar *current-document*)
 740 (defvar *current-pt*)
 741
 742 ;;;; ----------------------------------------------------------------------------------------------------
 743
 744 (define-presentation-translator url-from-string
 745     (string url closure)
 746   (x)
 747   (url:parse-url x))
 748
 749 (define-presentation-method accept ((type url)
 750                                     stream
 751                                     (view (eql +textual-view+))
 752                                     &key default default-type)
 753   (url:parse-url (accept 'string :stream stream :prompt nil)))
 754
 755
 756
 757
 758 (define-closure-command (com-clear-interactor :name t) ()
 759     (clim:window-clear (clim:frame-query-io clim:*application-frame*)))
 760
 761 ;;;; ----------------------------------------------------------------------------------------------------
 762
 763
 764 (define-closure-command (com-zoom-100% :name t) ()
 765   (setq gui:*zoom-factor* 1.0)
 766   (send-closure-command 'com-reflow))
 767
 768 (define-closure-command (com-zoom-in :name t :keystroke (#\+ :control)) ()
 769   (write-status "Zooming in...")
 770   (setq gui:*zoom-factor* (* gui:*zoom-factor* 1.2))
 771   (send-closure-command 'com-reflow))
 772
 773 (define-closure-command (com-zoom-out :name t :keystroke (#\- :control)) ()
 774   (write-status "Zooming out...")
 775   (setq gui:*zoom-factor* (* gui:*zoom-factor* 0.8))
 776   (send-closure-command 'com-reflow))
 777
 778 (define-closure-command (com-page-up :name t
 779                                      :keystroke :prior) ()
 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 (max (gadget-min-value scrollbar) (- current-y (* 0.9 window-height))))))
 785
 786 (define-closure-command (com-page-down :name t
 787                                        :keystroke :next) ()
 788   (let* ((pane (current-pane))
 789          (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar))
 790          (current-y (gadget-value scrollbar))
 791          (window-height (bounding-rectangle-height (pane-viewport-region pane))))
 792     (scroll-extent pane 0
 793                    (min (gadget-max-value scrollbar) (+ current-y (* 0.9 window-height))))))
 794
 795 (define-closure-command (com-beginning-of-page :name t
 796                                                :keystroke (:home :control)) ()
 797   (let* ((pane (current-pane))
 798          (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar)))
 799     (scroll-extent pane 0 (gadget-min-value scrollbar))))
 800
 801 (define-closure-command (com-end-of-page :name t
 802                                          :keystroke (:end :control)) ()
 803   (let* ((pane (current-pane))
 804          (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar)))
 805     (scroll-extent pane 0 (gadget-max-value scrollbar))))
 806
 807 (define-closure-command (com-redraw :name t :keystroke (#\r :control)) ()
 808   (let* ((*pane* (current-pane)))
 809     (handle-repaint *pane* (sheet-region (pane-viewport *pane*))))
 810   (clim-backend:port-force-output (find-port)))
 811
 812 (define-closure-command (com-tex-mode-on :name t) ()
 813   (setq renderer:*tex-mode-p* t)
 814   (setq renderer:*hyphenate-p* t)
 815   (send-closure-command 'com-reflow))
 816
 817 (define-closure-command (com-tex-mode-off :name t) ()
 818   (setq renderer:*tex-mode-p* nil)
 819   (setq renderer:*hyphenate-p* nil)
 820   (send-closure-command 'com-reflow))
 821
 822 ;; for Closure developers
 823 (define-closure-command (com-inspect-page :name t) ()
 824   (write-status "Loading Clouseau")
 825   (asdf:oos 'asdf:load-op :clouseau)
 826   (write-status "Starting inspector")
 827   (funcall (find-symbol "INSPECTOR" :clouseau) *current-document* :new-process t))
 828
 829
 830 ;; EOF