X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/7abdba43523dd39f28caab7d728d2a2821e30e89..18b84c8043e09adb90c047fd5dfe6860e26b27e8:/gdk/gdk.lisp?ds=sidebyside diff --git a/gdk/gdk.lisp b/gdk/gdk.lisp index 57c6db4..c8ac552 100644 --- a/gdk/gdk.lisp +++ b/gdk/gdk.lisp @@ -1,21 +1,26 @@ -;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 1999-2005 Espen S. Johnsen +;; Common Lisp bindings for GTK+ v2.x +;; Copyright 2000-2005 Espen S. Johnsen ;; -;; This library is free software; you can redistribute it and/or -;; modify it under the terms of the GNU Lesser General Public -;; License as published by the Free Software Foundation; either -;; version 2 of the License, or (at your option) any later version. +;; Permission is hereby granted, free of charge, to any person obtaining +;; a copy of this software and associated documentation files (the +;; "Software"), to deal in the Software without restriction, including +;; without limitation the rights to use, copy, modify, merge, publish, +;; distribute, sublicense, and/or sell copies of the Software, and to +;; permit persons to whom the Software is furnished to do so, subject to +;; the following conditions: ;; -;; This library is distributed in the hope that it will be useful, -;; but WITHOUT ANY WARRANTY; without even the implied warranty of -;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU -;; Lesser General Public License for more details. +;; The above copyright notice and this permission notice shall be +;; included in all copies or substantial portions of the Software. ;; -;; You should have received a copy of the GNU Lesser General Public -;; License along with this library; if not, write to the Free Software -;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA +;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, +;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF +;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. +;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY +;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, +;; 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.15 2005-02-27 12:37:45 espen Exp $ +;; $Id: gdk.lisp,v 1.26 2006-04-25 13:37:28 espen Exp $ (in-package "GDK") @@ -130,12 +135,6 @@ (defbinding screen-height () int) (defbinding screen-width-mm () int) (defbinding screen-height-mm () int) -(defun %grab-time (time-or-event) - (etypecase time-or-event - (null 0) - (timed-event (event-time time-or-event)) - (integer time-or-event))) - (defbinding pointer-grab (window &key owner-events events confine-to cursor time) grab-status (window window) @@ -143,12 +142,12 @@ (defbinding pointer-grab (events event-mask) (confine-to (or null window)) (cursor (or null cursor)) - ((%grab-time time) (unsigned 32))) + ((or time 0) (unsigned 32))) (defbinding (pointer-ungrab "gdk_display_pointer_ungrab") - (&optional (display (display-get-default)) time) nil + (&optional time (display (display-get-default))) nil (display display) - ((%grab-time time) (unsigned 32))) + ((or time 0) (unsigned 32))) (defbinding (pointer-is-grabbed-p "gdk_display_pointer_is_grabbed") (&optional (display (display-get-default))) boolean) @@ -156,12 +155,12 @@ (defbinding (pointer-is-grabbed-p "gdk_display_pointer_is_grabbed") (defbinding keyboard-grab (window &key owner-events time) grab-status (window window) (owner-events boolean) - ((%grab-time time) (unsigned 32))) + ((or time 0) (unsigned 32))) (defbinding (keyboard-ungrab "gdk_display_keyboard_ungrab") - (&optional (display (display-get-default)) time) nil + (&optional time (display (display-get-default))) nil (display display) - ((%grab-time time) (unsigned 32))) + ((or time 0) (unsigned 32))) @@ -423,14 +422,12 @@ (defbinding rgb-init () nil) ;;; Cursor -(defmethod initialize-instance ((cursor cursor) &key type mask fg bg - (x 0) (y 0) (display (display-get-default))) - (setf - (slot-value cursor 'location) - (etypecase type - (keyword (%cursor-new-for-display display type)) - (pixbuf (%cursor-new-from-pixbuf display type x y)) - (pixmap (%cursor-new-from-pixmap type mask fg bg x y))))) +(defmethod allocate-foreign ((cursor cursor) &key type mask fg bg + (x 0) (y 0) (display (display-get-default))) + (etypecase type + (keyword (%cursor-new-for-display display type)) + (pixbuf (%cursor-new-from-pixbuf display type x y)) + (pixmap (%cursor-new-from-pixmap type mask fg bg x y)))) (defbinding %cursor-new-for-display () pointer @@ -506,13 +503,24 @@ (defun pixmap-create (source &key color window colormap) ;;; Color +(defbinding %color-copy () pointer + (location pointer)) + +(defmethod allocate-foreign ((color color) &rest initargs) + (declare (ignore color initargs)) + ;; Color structs are allocated as memory chunks by gdk, and since + ;; there is no gdk_color_new we have to use this hack to get a new + ;; color chunk + (with-allocated-memory (location #.(foreign-size (find-class 'color))) + (%color-copy location))) + (defun %scale-value (value) (etypecase value (integer value) (float (truncate (* value 65535))))) (defmethod initialize-instance ((color color) &rest initargs - &key red green blue) + &key (red 0.0) (green 0.0) (blue 0.0)) (declare (ignore initargs)) (call-next-method) (with-slots ((%red red) (%green green) (%blue blue)) color @@ -521,15 +529,25 @@ (defmethod initialize-instance ((color color) &rest initargs %green (%scale-value green) %blue (%scale-value blue)))) +(defbinding %color-parse () boolean + (spec string) + (color color :return)) + +(defun color-parse (spec &optional (color (make-instance 'color))) + (multiple-value-bind (succeeded-p color) (%color-parse spec color) + (if succeeded-p + color + (error "Parsing color specification ~S failed." spec)))) + (defun ensure-color (color) (etypecase color (null nil) (color color) + (string (color-parse color)) (vector - (make-instance - 'color :red (svref color 0) :green (svref color 1) - :blue (svref color 2))))) - + (make-instance 'color + :red (svref color 0) :green (svref color 1) :blue (svref color 2))))) + ;;; Drawable @@ -691,9 +709,15 @@ (defbinding drawable-copy-to-image (defbinding keyval-name () string (keyval unsigned-int)) -(defbinding keyval-from-name () unsigned-int +(defbinding %keyval-from-name () unsigned-int (name string)) +(defun keyval-from-name (name) + "Returns the keysym value for the given key name or NIL if it is not a valid name." + (let ((keyval (%keyval-from-name name))) + (unless (zerop keyval) + keyval))) + (defbinding keyval-to-upper () unsigned-int (keyval unsigned-int)) @@ -706,3 +730,72 @@ (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 + +#+gtk2.8 +(progn + (defbinding cairo-create () cairo:context + (drawable drawable)) + + (defmacro with-cairo-context ((cr drawable) &body body) + `(let ((,cr (cairo-create ,drawable))) + (unwind-protect + (progn ,@body) + (unreference-foreign 'cairo:context (foreign-location ,cr)) + (invalidate-instance ,cr)))) + + (defbinding cairo-set-source-color () nil + (cr cairo:context) + (color color)) + + (defbinding cairo-set-source-pixbuf () nil + (cr cairo:context) + (pixbuf pixbuf) + (x double-float) + (y double-float)) + + (defbinding cairo-rectangle () nil + (cr cairo:context) + (rectangle rectangle)) + +;; (defbinding cairo-region () nil +;; (cr cairo:context) +;; (region region)) +) + + +;;; Multi-threading support + +#+sbcl +(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) + (cond + ((zerop recursive-level) + (when flush-p + (display-flush)) + (sb-thread:release-mutex *global-lock*)) + (t (decf recursive-level))))) + + (define-callback %enter-fn nil () + (threads-enter)) + + (define-callback %leave-fn nil () + (threads-leave)) + + (defbinding threads-set-lock-functions (&optional) nil + (%enter-fn callback) + (%leave-fn callback)) + + (defmacro with-global-lock (&body body) + `(progn + (threads-enter) + (unwind-protect + (progn ,@body) + (threads-leave t)))))