Improved support for multiple display connections

diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp
index 6450ff267f55f98240afc1f0434efc8d91e64552..1448abadd53ba93c8a515e8418e1e5e9e48df0fc 100644 (file)
--- a/examples/testgtk.lisp
+++ b/examples/testgtk.lisp
@@ -26,7 +26,7 @@
 ;; Kimball, Josh MacDonald and others.
 
 
-;; $Id: testgtk.lisp,v 1.39 2007/06/19 12:49:18 espen Exp $
+;; $Id: testgtk.lisp,v 1.40 2007/06/20 10:20:47 espen Exp $
 
 #+sbcl(require :gtk)
 #+(or cmu clisp)(asdf:oos 'asdf:load-op :gtk)
@@ -1909,7 +1909,7 @@ (define-toplevel create-ui-manager (window "UI Manager")
 
 ;;; Main window
       
-(defun create-main-window ()
+(defun create-main-window (&optional display)
   (let* ((button-specs
          '(("button box" create-button-box)
            ("buttons" create-buttons)
@@ -1954,6 +1954,7 @@ (defun create-main-window ()
            ("UI manager" create-ui-manager)))
 
         (main-window (make-instance 'window
+                      :display display
                       :title "testgtk.lisp" :name "main_window"
                       :default-width 200 :default-height 400
                       :allow-grow t :allow-shrink nil))
@@ -1963,7 +1964,7 @@ (defun create-main-window ()
                           :border-width 10))
         (close-button (make-instance 'button 
                        :stock "gtk-close" :can-default t
-                       :signal (list 'clicked #'widget-destroy :object main-window)))) 
+                       :signal (list 'clicked #'widget-destroy :object main-window))))
 
     (let ((icon (gdk:pixbuf-load #p"clg:examples;gtk.png")))
       (setf 

diff --git a/gdk/gdk.lisp b/gdk/gdk.lisp
index 402e9038d0fc84a342e186892d95aa02c4535b11..a5d14d86eb5870028bb17c9bc5b9ac346b1b7c16 100644 (file)
--- a/gdk/gdk.lisp
+++ b/gdk/gdk.lisp
@@ -20,7 +20,7 @@
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-;; $Id: gdk.lisp,v 1.41 2007/06/18 14:27:02 espen Exp $
+;; $Id: gdk.lisp,v 1.42 2007/06/20 10:16:19 espen Exp $
 
 
 (in-package "GDK")
@@ -47,12 +47,28 @@ (defmethod print-object ((display display) stream)
 (defbinding %display-open () display
   (display-name (or null string)))
 
-(defun display-open (&optional display-name)
+(defvar *display-aliases* ())
+
+(defun display-add-alias (display alias)
+  (unless (rassoc display *display-aliases*)
+    (signal-connect display 'closed
+     #'(lambda (is-error-p)
+        (declare (ignore is-error-p))
+        (setq *display-aliases* 
+         (delete-if #'(lambda (mapping)
+                        (eq (cdr mapping) display))
+          *display-aliases*))))
+    (push (cons alias display) *display-aliases*)))
+
+
+(defun display-open (&optional name)
   (let ((display (or
-                 (%display-open display-name)
-                 (error "Opening display failed: ~A" display-name))))
+                 (%display-open name)
+                 (error "Opening display failed: ~A" name))))
     (unless (display-get-default)
       (display-set-default display))
+    (when (and (stringp name) (not (string= name (display-name display))))
+      (display-add-alias display name))
     display))
 
 (defbinding %display-get-n-screens () int
@@ -81,7 +97,7 @@ (defbinding display-flush (&optional (display (display-get-default))) nil
   (display display))
 
 (defbinding display-close (&optional (display (display-get-default))) nil
-  (display display))
+  ((ensure-display display t) display))
 
 (defbinding flush () nil)
 
@@ -102,16 +118,33 @@ (defbinding (display-connection-number "clg_gdk_connection_number")
     (&optional (display (display-get-default))) int
   (display display))
 
-(defun find-display (name)
-  (if (not name)
-      (display-get-default)
-    (find name (list-displays) :key #'display-name :test #'string=)))
+(defun find-display (name &optional (error-p t))
+  (or
+   (find name (list-displays) :key #'display-name :test #'string=)
+   (cdr (assoc name *display-aliases* :test #'string=))
+   (when error-p
+     (error "No such display: ~A" name))))
 
-(defun ensure-display (display)
+;; This will not detect connections to the same server that use
+;; different hostnames
+(defun %find-similar-display (display)
+   (find (display-name display) (delete display (list-displays))
+    :key #'display-name :test #'string=))
+
+(defun ensure-display (display &optional existing-only-p)
   (etypecase display
     (null (display-get-default))
     (display display)
-    (string (or (find-display display) (display-open display)))))
+    (string (or 
+            (find-display display existing-only-p)
+            (let* ((new (display-open display))
+                   (existing (%find-similar-display new)))
+              (if existing
+                  (progn
+                    (display-add-alias existing display)
+                    (display-close new)
+                    existing)
+                new))))))
 
 
 ;;; Display manager
@@ -135,6 +168,19 @@ (defbinding display-get-core-pointer
     (&optional (display (display-get-default))) device
   (display display))
 
+(defmacro with-default-display ((display) &body body)
+  (let ((saved-display (make-symbol "SAVED-DISPLAY"))
+       (current-display (make-symbol "CURRENT-DISPLAY")))
+    `(let* ((,current-display ,display)
+           (,saved-display (when ,current-display
+                             (prog1
+                                 (display-get-default)
+                               (display-set-default (ensure-display ,current-display))))))
+       (unwind-protect 
+          (progn ,@body)
+        (when ,saved-display
+          (display-set-default ,saved-display))))))
+
 
 ;;; Primitive graphics structures (points, rectangles and regions)
 

diff --git a/gtk/gtk.lisp b/gtk/gtk.lisp
index 72e7d58826e1b0ce2b73f744865ac342159d003c..d4cc2ddfad5cc854a2a4f372b3da2dec06eaae6e 100644 (file)
--- a/gtk/gtk.lisp
+++ b/gtk/gtk.lisp
@@ -20,7 +20,7 @@
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-;; $Id: gtk.lisp,v 1.73 2007/06/19 11:32:25 espen Exp $
+;; $Id: gtk.lisp,v 1.74 2007/06/20 10:19:47 espen Exp $
 
 
 (in-package "GTK")
@@ -74,7 +74,7 @@ (defun clg-init (&optional display multi-threading-p)
        (%init-async-event-handling display)
       #+sb-thread(%init-multi-threaded-event-handling display)
       #-sb-thread(error "Multi threading not supported on this platform")))
-  (gdk:find-display display))
+  (gdk:ensure-display display t))
 
 (defun clg-init-with-threading (&optional display)
   (clg-init display t))
@@ -1358,7 +1358,7 @@ (defmethod initialize-instance ((window window) &rest initargs
   (prog1
       (if display
          (apply #'call-next-method
-          window :screen (gdk:display-get-default-screen display) initargs)
+          window :screen (gdk:display-get-default-screen (gdk:ensure-display display)) initargs)
        (call-next-method))
     (initial-add window #'window-add-accel-group 
      initargs :accel-group :accel-groups)))

diff --git a/gtk/gtkwidget.lisp b/gtk/gtkwidget.lisp
index 692b155469acfaf7daa87ec74248df00f53b8138..9ef9b81add28cf67519623c1abf6067838cf7836 100644 (file)
--- a/gtk/gtkwidget.lisp
+++ b/gtk/gtkwidget.lisp
@@ -20,11 +20,10 @@
 ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
 ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
 
-;; $Id: gtkwidget.lisp,v 1.27 2007/02/19 14:29:33 espen Exp $
+;; $Id: gtkwidget.lisp,v 1.28 2007/06/20 10:20:47 espen Exp $
 
 (in-package "GTK")
 
-
 #-debug-ref-counting
 (defmethod print-object ((widget widget) stream)
   (if (and 
@@ -67,25 +66,31 @@ (defmethod slot-unbound ((class gobject-class) (object widget)
    ((call-next-method))))
 
 
+(defparameter *widget-display-as-default-in-signal-handler-p* t)
+
 (defmethod compute-signal-function ((widget widget) signal function object args)
-  (declare (ignore signal))
-  (if (eq object :parent)
-      #'(lambda (&rest emission-args)
-         (let ((all-args (nconc (rest emission-args) args)))
-           (if (slot-boundp widget 'parent)
-               (apply function (widget-parent widget) all-args)
-           ;; Delay until parent is set
-           (signal-connect widget 'parent-set
-            #'(lambda (old-parent)
-                (declare (ignore old-parent))
-                (let ((*signal-stop-emission* 
-                       #'(lambda ()
-                           (warn "Ignoring emission stop in delayed signal handler"))))
-                  (apply function (widget-parent widget) all-args)))
-            :remove t)
-;          (warn "Widget has no parent -- ignoring signal")
-           )))
-    (call-next-method)))
+  (let ((wrapper
+        (if (eq object :parent)
+            #'(lambda (&rest emission-args)
+                (let ((all-args (nconc (rest emission-args) args)))
+                  (if (slot-boundp widget 'parent)
+                      (apply function (widget-parent widget) all-args)
+                    ;; Delay until parent is set
+                    (signal-connect widget 'parent-set
+                     #'(lambda (old-parent)
+                         (declare (ignore old-parent))
+                         (apply #'signal-emit widget signal (rest emission-args)))
+                     :remove t))))
+          (call-next-method))))
+    (if *widget-display-as-default-in-signal-handler-p*
+       #'(lambda (&rest args)
+           (let ((display (when (slot-boundp widget 'window)
+                            (gdk:drawable-display (widget-window widget)))))
+             (gdk:with-default-display (display)
+               (apply wrapper args))))
+      wrapper)))
+
+
       
 (defun child-property-value (widget slot)
   (slot-value (widget-child-properties widget) slot))