From: espen Date: Wed, 20 Jun 2007 10:16:19 +0000 (+0000) Subject: Improved support for multiple display connections X-Git-Url: https://git.distorted.org.uk/~mdw/clg/commitdiff_plain/f5c99598e1a12d82a1e3223d4fdc90b3ceb144ad Improved support for multiple display connections --- diff --git a/examples/testgtk.lisp b/examples/testgtk.lisp index a8feb8b..b008a04 100644 --- 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 @@ This one is underlined in quite a funky fashion" ;;; 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 @@ This one is underlined in quite a funky fashion" ("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 @@ This one is underlined in quite a funky fashion" :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 49f26fb..d3cdc72 100644 --- 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 @@ (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 @@ (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 @@ (&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 @@ (&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 80725a4..4b19e1c 100644 --- 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 @@ (%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 @@ (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 0bb3154..64aabe4 100644 --- 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 @@ ((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))