;; 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)
;;; Main window
-(defun create-main-window ()
+(defun create-main-window (&optional display)
(let* ((button-specs
'(("button box" create-button-box)
("buttons" create-buttons)
("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))
: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
;; 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")
(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
(display display))
(defbinding display-close (&optional (display (display-get-default))) nil
- (display display))
+ ((ensure-display display t) display))
(defbinding flush () nil)
(&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
(&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)
;; 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")
(%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))
(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)))
;; 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
((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))
~mdw / clg / commitdiff