X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/50eec23a073d2b2ad48210d100605259a60892f8..1143508416716e1236d7d7b772fa471716f06235:/gdk/gdk.lisp diff --git a/gdk/gdk.lisp b/gdk/gdk.lisp index 49f26fb..d44cbfd 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.48 2008-01-02 15:26:46 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) @@ -805,7 +851,7 @@ (depth int)) (defmethod allocate-foreign ((pximap pixmap) &key width height depth window) - (%pixmap-new window width height depth)) + (%pixmap-new window (or width (drawable-width window)) (or height (drawable-height window)) (or depth -1))) (defun pixmap-new (width height depth &key window) (warn "PIXMAP-NEW is deprecated, use (make-instance 'pixmap ...) instead") @@ -953,22 +999,20 @@ (defbinding %draw-layout () nil (drawable drawable) (gc gc) - (font pango:font) (x int) (y int) (layout pango:layout)) (defbinding %draw-layout-with-colors () nil (drawable drawable) (gc gc) - (font pango:font) (x int) (y int) (layout pango:layout) (foreground (or null color)) (background (or null color))) -(defun draw-layout (drawable gc font x y layout &optional foreground background) +(defun draw-layout (drawable gc x y layout &optional foreground background) (if (or foreground background) - (%draw-layout-with-colors drawable gc font x y layout foreground background) - (%draw-layout drawable gc font x y layout))) + (%draw-layout-with-colors drawable gc x y layout foreground background) + (%draw-layout drawable gc x y layout))) (defbinding draw-drawable (drawable gc src src-x src-y dest-x dest-y &optional width height) nil @@ -1003,7 +1047,7 @@ ;;; Key values -(defbinding keyval-name () string +(defbinding keyval-name () (static string) (keyval unsigned-int)) (defbinding %keyval-from-name () unsigned-int @@ -1027,6 +1071,7 @@ (defbinding (keyval-is-lower-p "gdk_keyval_is_lower") () boolean (keyval unsigned-int)) + ;;; Cairo interaction #?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0") @@ -1044,19 +1089,25 @@ (cr cairo:context) (color color)) - (defbinding cairo-set-source-pixbuf () nil + (defbinding cairo-set-source-pixbuf (cr pixbuf &optional (x 0.0) (y 0.0)) nil (cr cairo:context) (pixbuf pixbuf) (x double-float) (y double-float)) + (defbinding cairo-set-source-pixmap (cr pixmap &optional (x 0.0) (y 0.0)) nil + (cr cairo:context) + (pixmap pixmap) + (x double-float) + (y double-float)) + (defbinding cairo-rectangle () nil (cr cairo:context) (rectangle rectangle)) -;; (defbinding cairo-region () nil -;; (cr cairo:context) -;; (region region)) + (defbinding cairo-region (cr region) nil + (cr cairo:context) + ((ensure-region region) region)) (defbinding (cairo-surface-get-window "clg_gdk_cairo_surface_get_window") () window (surface cairo:surface)) @@ -1069,25 +1120,26 @@ #+sb-thread (progn (defvar *global-lock* nil) + (defvar *recursion-count* 0) (defun %global-lock-p () - (eq (car (sb-thread:mutex-value *global-lock*)) sb-thread:*current-thread*)) + (eq (sb-thread:mutex-value *global-lock*) sb-thread:*current-thread*)) (defun threads-enter () (when *global-lock* (if (%global-lock-p) - (incf (cdr (sb-thread:mutex-value *global-lock*))) - (sb-thread:get-mutex *global-lock* (cons sb-thread:*current-thread* 0))))) + (incf *recursion-count*) + (sb-thread:get-mutex *global-lock*)))) (defun threads-leave (&optional flush-p) (when *global-lock* (assert (%global-lock-p)) (cond - ((zerop (cdr (sb-thread:mutex-value *global-lock*))) + ((zerop *recursion-count*) (when flush-p (flush)) (sb-thread:release-mutex *global-lock*)) - (t (decf (cdr (sb-thread:mutex-value *global-lock*))))))) + (t (decf *recursion-count*))))) (define-callback %enter-fn nil () (threads-enter)) @@ -1095,13 +1147,13 @@ (define-callback %leave-fn nil () (threads-leave)) - (defbinding %threads-set-lock-functions (&optional) nil + (defbinding %threads-set-lock-functions (nil) nil (%enter-fn callback) (%leave-fn callback)) (defun threads-init () - (%threads-set-lock-functions) - (setq *global-lock* (sb-thread:make-mutex :name "global GDK lock"))) + (setq *global-lock* (sb-thread:make-mutex :name "global GDK lock")) + (%threads-set-lock-functions)) (defmacro with-global-lock (&body body) `(progn @@ -1131,7 +1183,7 @@ (defun timeout-add-with-lock (interval function &optional (priority +priority-default+)) (timeout-add interval function priority)) - (defun idle-add-with-lock (funcation &optional (priority +priority-default-idle+)) + (defun idle-add-with-lock (function &optional (priority +priority-default-idle+)) (idle-add function priority)))