X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/9b61d89db2fdaa61cbef5b9bff3c37dc9be4547f..73326d92ff489b66efbf34cd27da49db46ac1bf2:/gdk/gdk.lisp

diff --git a/gdk/gdk.lisp b/gdk/gdk.lisp
index 7bea418..3288559 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.33 2007-01-14 23:24:11 espen Exp $
+;; $Id: gdk.lisp,v 1.49 2008-04-11 19:47:39 espen Exp $
 
 
 (in-package "GDK")
@@ -36,13 +36,39 @@ (defbinding (gdk-init "gdk_parse_args") () nil
 
 ;;; Display
 
-(defbinding %display-open () display
+#-debug-ref-counting
+(defmethod print-object ((display display) stream)
+  (if (and (proxy-valid-p display) (slot-boundp display 'name))
+      (print-unreadable-object (display stream :type t :identity nil)
+        (format stream "~S at 0x~X" 
+	 (display-name display) (pointer-address (foreign-location display))))
+    (call-next-method)))
+
+(defbinding %display-open () (or null display)
   (display-name (or null string)))
 
-(defun display-open (&optional display-name)
-  (let ((display (%display-open 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 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
@@ -71,14 +97,16 @@ (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)
 
 (defbinding display-get-event
-    (&optional (display (display-get-default))) event
+    (&optional (display (display-get-default))) (or null event)
   (display display))
 
 (defbinding display-peek-event
-    (&optional (display (display-get-default))) event
+    (&optional (display (display-get-default))) (or null event)
   (display display))
 
 (defbinding display-put-event
@@ -90,19 +118,69 @@ (defbinding (display-connection-number "clg_gdk_connection_number")
     (&optional (display (display-get-default))) int
   (display display))
 
+(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))))
+
+;; 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 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
 
-(defbinding display-get-default () display)
-
-(defbinding (display-manager "gdk_display_manager_get") () display-manager)
+(defbinding display-get-default () (or null display))
 
 (defbinding (display-set-default "gdk_display_manager_set_default_display")
     (display) nil
   ((display-manager) display-manager)
   (display display))
 
+(defbinding (list-displays "gdk_display_manager_list_displays") ()
+    (gslist (static display))
+  ((display-manager) display-manager))
+
+;; The only purpose of exporting this is to make it possible for
+;; applications to connect to the display-opened signal
+(defbinding (display-manager "gdk_display_manager_get") () display-manager)
+
+(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)
 
@@ -147,7 +225,6 @@ (defbinding %region-destroy () nil
   (location pointer))
 
 (defmethod allocate-foreign ((region region) &key rectangle polygon fill-rule)
-  (declare (ignore initargs))
   (cond
    ((and rectangle polygon) 
     (error "Only one of the keyword arguments :RECTANGLE and :POLYGON can be specified"))
@@ -159,7 +236,9 @@ (defun ensure-region (region)
   (etypecase region 
     (region region)
     ((or rectangle vector) 
-     (make-instance 'region :rectangle (ensure-rectangle region)))))
+     (make-instance 'region :rectangle (ensure-rectangle region)))
+    (list
+     (make-instance 'region :polygon region))))
 
 (defbinding region-get-clipbox (region &optional (rectangle (make-instance 'rectangle))) nil
   (region region)
@@ -174,7 +253,7 @@ (defun region-get-rectangles (region)
   "Obtains the area covered by the region as a list of rectangles."
   (multiple-value-bind (location length) (%region-get-rectangles region)
     (prog1
-	(map-c-vector 'list #'identity location 'point length :get)
+	(map-c-vector 'list #'identity location '(inlined rectangle) length :get)
       (deallocate-memory location))))
 
 (defbinding region-empty-p () boolean
@@ -204,19 +283,19 @@ (defbinding region-shrink () nil
   (dy int))
 
 (defbinding region-intersect (source1 source2) nil
-  (source1 region)
+  ((ensure-region source1) region :in/return)
   ((ensure-region source2) region))
 
 (defbinding region-union (source1 source2) nil
-  (source1 region)
+  ((ensure-region source1) region :in/return)
   ((ensure-region source2) region))
 
 (defbinding region-subtract (source1 source2) nil
-  (source1 region)
+  ((ensure-region source1) region :in/return)
   ((ensure-region source2) region))
 
 (defbinding region-xor (source1 source2) nil
-  (source1 region)
+  ((ensure-region source1) region :in/return)
   ((ensure-region source2) region))
 
 
@@ -224,14 +303,14 @@ (defbinding region-xor (source1 source2) nil
 
 (defbinding (events-pending-p "gdk_events_pending") () boolean)
 
-(defbinding event-get () event)
+(defbinding event-get () (or null event))
 
-(defbinding event-peek () event)
+(defbinding event-peek () (pr null event))
 
 (defbinding event-get-graphics-expose () event
   (window window))
 
-(defbinding event-put () event
+(defbinding event-put () nil
   (event event))
 
 ;(defbinding event-handler-set () ...)
@@ -336,7 +415,9 @@ (defbinding list-visuals () (glist visual))
 (defbinding window-destroy () nil
   (window window))
 
-(defbinding window-at-pointer () window
+(defbinding (window-at-pointer "gdk_display_get_window_at_pointer") 
+    (&optional (display (display-get-default))) (or null window)
+  display
   (x int :out)
   (y int :out))
 
@@ -412,6 +493,13 @@ (defbinding window-scroll () nil
   (dx int)
   (dy int))
 
+#?(pkg-exists-p "gtk+-2.0" :atleast-version "2.8.0")
+(defbinding window-move-region (window region dx dy) nil
+  (window window)
+  ((ensure-region region) region)
+  (dx int)
+  (dy int))
+
 (defbinding window-reparent () nil
   (window window)
   (new-parent window)
@@ -546,9 +634,9 @@ (defbinding %window-shape-combine-region () nil
 
 (defun window-shape-combine (window shape offset-x offset-y)
   (etypecase shape
-    (nil (%window-shape-combine-region window nil 0 0)
+    (null (%window-shape-combine-region window nil 0 0))
     (region (%window-shape-combine-region window shape offset-x offset-y))
-    (bitmask (window-shape-combine-mask window shape offset-x offset-y)))))
+    (bitmap (window-shape-combine-mask window shape offset-x offset-y))))
 
 (defbinding window-set-child-shapes () nil
   (window window))
@@ -572,9 +660,9 @@   (defbinding %window-input-shape-combine-region () nil
   
   (defun window-input-shape-combine (window shape x y)
     (etypecase shape
-      (nil (%window-input-shape-combine-region window nil 0 0)
-	   (region (%window-input-shape-combine-region window shape x y))
-	   (bitmask (%window-input-shape-combine-mask window shape x y)))))
+      (null (%window-input-shape-combine-region window nil 0 0))
+      (region (%window-input-shape-combine-region window shape x y))
+      (bitmap (%window-input-shape-combine-mask window shape x y))))
 
   (defbinding window-set-child-input-shapes () nil
     (window window))
@@ -649,7 +737,7 @@ (defbinding window-get-origin () nil ; this may not work as
   (x int :out)
   (y int :out))
 
-(defbinding window-get-pointer () window
+(defbinding window-get-pointer () (or null window)
   (window window)
   (x int :out)
   (y int :out)
@@ -765,7 +853,7 @@ (defbinding %pixmap-new () pointer
   (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")
@@ -913,22 +1001,20 @@ (defbinding draw-arc () nil
 
 (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
@@ -963,7 +1049,7 @@ (defbinding drawable-copy-to-image
 
 ;;; Key values
 
-(defbinding keyval-name () string
+(defbinding keyval-name () (static string)
   (keyval unsigned-int))
 
 (defbinding %keyval-from-name () unsigned-int
@@ -987,6 +1073,7 @@ (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean
 (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")
@@ -1004,41 +1091,57 @@   (defbinding cairo-set-source-color () nil
     (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))
 )
 
 
 
 ;;; Multi-threading support
 
-#+sbcl
+#+sb-thread
 (progn
-  (defvar *global-lock* (sb-thread:make-mutex :name "global GDK lock"))
-  (let ((recursive-level 0))
-    (defun threads-enter ()
-      (if (eq (sb-thread:mutex-value *global-lock*) sb-thread:*current-thread*)
-	  (incf recursive-level)
- 	(sb-thread:get-mutex *global-lock*)))
-
-    (defun threads-leave (&optional flush-p)
+  (defvar *global-lock* nil)
+  (defvar *recursion-count* 0)
+
+  (defun %global-lock-p ()
+    (eq (sb-thread:mutex-value *global-lock*) sb-thread:*current-thread*))
+
+  (defun threads-enter ()
+    (when *global-lock*
+      (if (%global-lock-p)
+	  (incf *recursion-count*)
+        (sb-thread:get-mutex *global-lock*))))
+    
+  (defun threads-leave (&optional flush-p)
+    (when *global-lock*
+      (assert (%global-lock-p))
       (cond
-       ((zerop recursive-level)	  
+       ((zerop *recursion-count*)
 	(when flush-p
-	  (display-flush))
+	  (flush))
 	(sb-thread:release-mutex *global-lock*))
-       (t (decf recursive-level)))))
+       (t (decf *recursion-count*)))))
 
   (define-callback %enter-fn nil ()
     (threads-enter))
@@ -1046,13 +1149,43 @@   (define-callback %enter-fn nil ()
   (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 ()
+    (setq *global-lock* (sb-thread:make-mutex :name "global GDK lock"))
+    (%threads-set-lock-functions))
+
   (defmacro with-global-lock (&body body)
     `(progn
        (threads-enter)
        (unwind-protect
-	   ,@body
-	 (threads-leave t)))))
+	   (progn ,@body)
+	 (threads-leave t))))
+
+  (defun timeout-add-with-lock (interval function &optional (priority +priority-default+))
+    (timeout-add interval
+     #'(lambda () 
+	 (with-global-lock (funcall function)))
+     priority))
+
+  (defun idle-add-with-lock (function &optional (priority +priority-default-idle+))
+    (idle-add 
+     #'(lambda () 
+	 (with-global-lock (funcall function)))
+     priority)))
+
+
+#-sb-thread
+(progn
+  (defmacro with-global-lock (&body body)
+    `(progn ,@body))
+
+  (defun timeout-add-with-lock (interval function &optional (priority +priority-default+))
+    (timeout-add interval function priority))
+
+  (defun idle-add-with-lock (function &optional (priority +priority-default-idle+))
+    (idle-add function priority)))
+
+