From dlichteblau at common-lisp.net  Sun Feb  4 15:10:01 2007
From: dlichteblau at common-lisp.net (dlichteblau)
Date: Sun,  4 Feb 2007 10:10:01 -0500 (EST)
Subject: [closure-cvs] CVS closure/src/gui
Message-ID: <20070204151001.9E6D636017@common-lisp.net>

Update of /project/closure/cvsroot/closure/src/gui
In directory clnet:/tmp/cvs-serv30785/src/gui

Modified Files:
	clim-gui.lisp 
Log Message:
Tabbed browsing.


--- /project/closure/cvsroot/closure/src/gui/clim-gui.lisp	2007/01/07 19:32:06	1.30
+++ /project/closure/cvsroot/closure/src/gui/clim-gui.lisp	2007/02/04 15:10:01	1.31
@@ -4,7 +4,7 @@
 ;;;   Created: 2002-07-22
 ;;;    Author: Gilbert Baumann <gilbert at base-engineering.com>
 ;;;   License: MIT style (see below)
-;;;       $Id: clim-gui.lisp,v 1.30 2007/01/07 19:32:06 emarsden Exp $
+;;;       $Id: clim-gui.lisp,v 1.31 2007/02/04 15:10:01 dlichteblau Exp $
 ;;; ---------------------------------------------------------------------------
 ;;;  (c) copyright 2002 by Gilbert Baumann
 
@@ -28,6 +28,9 @@
 ;;;  SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
 ;; $Log: clim-gui.lisp,v $
+;; Revision 1.31  2007/02/04 15:10:01  dlichteblau
+;; Tabbed browsing.
+;;
 ;; Revision 1.30  2007/01/07 19:32:06  emarsden
 ;; Follow HTTP redirects (HTML-level redirects still not supported).
 ;;
@@ -182,14 +185,31 @@
 (defvar *back-history* nil)
 (defvar *forw-history* nil)
 
+(defun make-canvas (&key (height 600) (min-height 600))
+  (scrolling (:width 830
+		     :max-height 20000
+		     :scroll-bar :vertical
+		     :height height
+		     :min-height min-height)
+    (make-pane 'closure-pane
+	       :height 2000
+	       :width 800
+	       :display-time nil)))
+
+(defmacro canvasly (&rest spacereqs)
+  `(let ((tabs
+	  (clim-tab-layout:with-tab-layout
+	      ('clim-tab-layout:tab-page :name 'tab-layout)
+	    ("(Untitled)"
+	     (make-canvas , at spacereqs)))))
+     (assert *frame*)
+     (setf (slot-value *frame* 'tabs) tabs)
+     tabs))
+
 (define-application-frame closure ()
-  ()
+  ((tabs))
   (:menu-bar menubar-command-table)
   (:panes
-   (canvas (make-pane 'closure-pane
-            :height 2000
-            :width 800
-            :display-time nil))
    (aux :application
     :height 300
     :width 300
@@ -229,9 +249,7 @@
    (default
        (vertically ()
          (spacing (:thickness 5)
-                  (scrolling (:width 830 :height 600 :min-height 400 :max-height 20000
-                              :scroll-bar :vertical)
-                    canvas))
+	   (canvasly :height 600 :min-height 400))
          (spacing (:thickness 5)
                   interactor)
          (horizontally (:height 80 :min-height 80 :max-height 80)
@@ -241,9 +259,7 @@
    (hidden-listener
        (vertically ()
          (spacing (:thickness 5)
-                  (scrolling (:width 830 :height 600 :min-height 600 :max-height 20000
-                              :scroll-bar :vertical)
-                    canvas))
+	   (canvasly :height 600 :min-height 600))
          (horizontally (:height 80 :min-height 80 :max-height 80)
            wholine
            2
@@ -254,8 +270,7 @@
          menu-bar
          (horizontally ()
            (vertically ()
-             (climi::scrolling (:width 830 :height 600 :min-height 400 :max-height 20000)
-                               canvas)) )
+	     (canvasly :height 600 :min-height 400)))
          (horizontally ()
            wholine
            2
@@ -279,7 +294,8 @@
 
 (make-command-table 'file-command-table
                     :errorp nil
-                    :menu '(("Quit" :command com-quit)))
+                    :menu '(("New Tab" :command com-new-tab)
+			    ("Quit" :command com-quit)))
 
 (make-command-table 'go-command-table
 		    :errorp nil
@@ -351,11 +367,22 @@
 (define-presentation-type r2::pt ())
 (define-presentation-type r2::hyper-link ())
 
+(defun scroller-child (scroller)
+  (car (sheet-children
+	(find-if (lambda (x) (typep x 'climi::viewport-pane))
+		 (sheet-children scroller)))))
+
+(defun current-page ()
+  (clim-tab-layout:tab-layout-enabled-page (slot-value *frame* 'tabs)))
+
+(defun current-pane ()
+  (scroller-child (clim-tab-layout:tab-page-pane (current-page))))
+
 ;; renders LHTML as per http://opensource.franz.com/xmlutils/xmlutils-dist/phtml.htm
 (defun render-lhtml (location lhtml)
   (with-simple-restart (forget "Just forget rendering this page.")
     (let* ((*package* (find-package :r2))
-           (*pane* (find-pane-named *frame* 'canvas))
+           (*pane* (current-pane))
            (*medium* (sheet-medium *pane*))
            (device (make-instance 'closure/clim-device::clim-device :medium *pane*))
            (doc (make-instance 'r2::document
@@ -380,6 +407,10 @@
 ;;;; Commands
 ;;;;
 
+(define-closure-command (com-remove-tab :name t)
+    ((page 'clim-tab-layout:tab-page :prompt "Tab page" :gesture :delete))
+  (clim-tab-layout:remove-page page))
+
 (define-closure-command (com-show-listener :name t) ()
   (setf (sheet-enabled-p (sheet-parent (find-pane-named *application-frame* 'interactor))) t))
 
@@ -398,6 +429,14 @@
   (let ((*standard-output* *trace-output*))
     (foo url)))
 
+(define-gesture-name :visit-in-new-tab :pointer-button-press (:middle))
+
+(define-closure-command (com-visit-url-in-new-tab :name t)
+    ((url 'url :gesture :visit-in-new-tab))
+  (com-new-tab)
+  (setf *pane* (current-pane))
+  (com-visit-url url))
+
 (define-closure-command (com-reflow :name t) ()
   (reflow))
 
@@ -438,6 +477,17 @@
 (define-closure-command (com-quit :name t :keystroke (#\q :control)) ()
   (frame-exit *application-frame*))
 
+(defvar *open-new-tabs-in-background* nil)
+
+(define-closure-command (com-new-tab :name t :keystroke (#\t :control)) ()
+  (with-look-and-feel-realization
+      ((frame-manager *application-frame*) *application-frame*)
+    (clim-tab-layout:add-page (make-instance 'clim-tab-layout:tab-page
+				:title "(Untitled)"
+				:pane (make-canvas))
+			      (slot-value *frame* 'tabs)
+			      (not *open-new-tabs-in-background*))))
+
 (defun make-google-search-url (string)
   (url:merge-url
    (url:make-url :query (list
@@ -574,7 +624,7 @@
            (unwind-protect
                 (progn
                   (setf *frame* (make-application-frame 'closure))
-                  (setf *pane*  (find-pane-named *frame* 'canvas))
+                  (setf *pane*  nil)
                   (run-frame-top-level *frame*))
              (ignore-errors (ws/netlib::commit-cache))
              (setf *closure-process* nil)))
@@ -598,7 +648,7 @@
      (lambda ()
        (with-simple-restart (forget "Just forget rendering this page.")
          (let* ((*package* (find-package :r2))
-                (*pane* (find-pane-named *frame* 'canvas)))
+                (*pane* (current-pane)))
            (with-sheet-medium (*medium* *pane*)
              (let ((device (make-instance 'closure/clim-device::clim-device :medium *pane*)))
                (setf (sheet-pointer-cursor *pane*) :busy)
@@ -635,6 +685,8 @@
                         600           ;xxx width
                         t             ;?
                         0)
+		       (setf (clim-tab-layout:tab-page-title (current-page))
+			     (renderer::document-title *current-document*))
                        (write-wholine (format nil "Title: ~A~%~@[Modified: ~A~]"
                                               (renderer::document-title *current-document*)
                                               (or (netlib::get-header-field header :last-modified)
@@ -656,7 +708,7 @@
      (lambda ()
        (with-simple-restart (forget "Just forget rendering this page.")
          (let ((*package* (find-package :r2))
-               (*pane* (find-pane-named *frame* 'canvas)))
+               (*pane* (current-pane)))
            (window-clear *pane*)
            (with-sheet-medium (*medium* *pane*)
              (write-status "Rendering ...")
@@ -717,7 +769,7 @@
 
 (define-closure-command (com-page-up :name t
                                      :keystroke :prior) ()
-  (let* ((pane (find-pane-named *frame* 'canvas))
+  (let* ((pane (current-pane))
          (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar))
          (current-y (gadget-value scrollbar))
          (window-height (bounding-rectangle-height (pane-viewport-region pane))))
@@ -725,7 +777,7 @@
 
 (define-closure-command (com-page-down :name t
                                        :keystroke :next) ()
-  (let* ((pane (find-pane-named *frame* 'canvas))
+  (let* ((pane (current-pane))
          (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar))
          (current-y (gadget-value scrollbar))
          (window-height (bounding-rectangle-height (pane-viewport-region pane))))
@@ -734,18 +786,18 @@
 
 (define-closure-command (com-beginning-of-page :name t
                                                :keystroke (:home :control)) ()
-  (let* ((pane (find-pane-named *frame* 'canvas))
+  (let* ((pane (current-pane))
          (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar)))
     (scroll-extent pane 0 (gadget-min-value scrollbar))))
 
 (define-closure-command (com-end-of-page :name t
                                          :keystroke (:end :control)) ()
-  (let* ((pane (find-pane-named *frame* 'canvas))
+  (let* ((pane (current-pane))
          (scrollbar (slot-value (pane-scroller pane) 'climi::vscrollbar)))
     (scroll-extent pane 0 (gadget-max-value scrollbar))))
 
 (define-closure-command (com-redraw :name t :keystroke (#\r :control)) ()
-  (let* ((*pane* (find-pane-named *frame* 'canvas)) )
+  (let* ((*pane* (current-pane)))
     (handle-repaint *pane* (sheet-region (pane-viewport *pane*))))
   (clim-backend:port-force-output (find-port)))