X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/8f30d7da299d5330a6c5c362c46ac9a70941b785..dbde8d67774763c35e8b7e89ca309ea336e357ad:/gdk/gdk.lisp diff --git a/gdk/gdk.lisp b/gdk/gdk.lisp index 7e73511..92bba62 100644 --- a/gdk/gdk.lisp +++ b/gdk/gdk.lisp @@ -1,21 +1,26 @@ -;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 1999-2001 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.12 2004-12-20 00:32:15 espen Exp $ +;; $Id: gdk.lisp,v 1.27 2006-04-25 20:19:32 espen Exp $ (in-package "GDK") @@ -28,17 +33,8 @@ (nil null)) -;;; Display - -(defbinding (display-manager "gdk_display_manager_get") () display-manager) - - -(defbinding (display-set-default "gdk_display_manager_set_default_display") - (display) nil - ((display-manager) display-manager) - (display display)) -(defbinding display-get-default () display) +;;; Display (defbinding %display-open () display (display-name (or null string))) @@ -49,11 +45,66 @@ (display-set-default display)) display)) +(defbinding %display-get-n-screens () int + (display display)) + +(defbinding %display-get-screen () screen + (display display) + (screen-num int)) + +(defun display-screens (&optional (display (display-get-default))) + (loop + for i from 0 below (%display-get-n-screens display) + collect (%display-get-screen display i))) + +(defbinding display-get-default-screen + (&optional (display (display-get-default))) screen + (display display)) + +(defbinding display-beep (&optional (display (display-get-default))) nil + (display display)) + +(defbinding display-sync (&optional (display (display-get-default))) nil + (display display)) + +(defbinding display-flush (&optional (display (display-get-default))) nil + (display display)) + +(defbinding display-close (&optional (display (display-get-default))) nil + (display display)) + +(defbinding display-get-event + (&optional (display (display-get-default))) event + (display display)) + +(defbinding display-peek-event + (&optional (display (display-get-default))) event + (display display)) + +(defbinding display-put-event + (event &optional (display (display-get-default))) event + (display display) + (event event)) + (defbinding (display-connection-number "clg_gdk_connection_number") (&optional (display (display-get-default))) int (display display)) + +;;; Display manager + +(defbinding display-get-default () display) + +(defbinding (display-manager "gdk_display_manager_get") () display-manager) + +(defbinding (display-set-default "gdk_display_manager_set_default_display") + (display) nil + ((display-manager) display-manager) + (display display)) + + + ;;; Events (defbinding (events-pending-p "gdk_events_pending") () boolean) @@ -73,59 +124,52 @@ (defbinding set-show-events () nil (show-events boolean)) -;;; Misc - -(defbinding set-use-xshm () nil - (use-xshm boolean)) - (defbinding get-show-events () boolean) -(defbinding get-use-xshm () boolean) - -(defbinding get-display () string) - -; (defbinding time-get () (unsigned 32)) -; (defbinding timer-get () (unsigned 32)) +;;; Miscellaneous functions -; (defbinding timer-set () nil -; (milliseconds (unsigned 32))) - -; (defbinding timer-enable () nil) - -; (defbinding timer-disable () nil) +(defbinding screen-width () int) +(defbinding screen-height () int) -; input ... +(defbinding screen-width-mm () int) +(defbinding screen-height-mm () int) -(defbinding pointer-grab () int +(defbinding pointer-grab + (window &key owner-events events confine-to cursor time) grab-status (window window) (owner-events boolean) - (event-mask event-mask) + (events event-mask) (confine-to (or null window)) (cursor (or null cursor)) - (time (unsigned 32))) + ((or time 0) (unsigned 32))) -(defbinding pointer-ungrab () nil - (time (unsigned 32))) +(defbinding (pointer-ungrab "gdk_display_pointer_ungrab") + (&optional time (display (display-get-default))) nil + (display display) + ((or time 0) (unsigned 32))) + +(defbinding (pointer-is-grabbed-p "gdk_display_pointer_is_grabbed") + (&optional (display (display-get-default))) boolean) -(defbinding keyboard-grab () int +(defbinding keyboard-grab (window &key owner-events time) grab-status (window window) (owner-events boolean) - (time (unsigned 32))) + ((or time 0) (unsigned 32))) -(defbinding keyboard-ungrab () nil - (time (unsigned 32))) +(defbinding (keyboard-ungrab "gdk_display_keyboard_ungrab") + (&optional time (display (display-get-default))) nil + (display display) + ((or time 0) (unsigned 32))) -(defbinding (pointer-is-grabbed-p "gdk_pointer_is_grabbed") () boolean) -(defbinding screen-width () int) -(defbinding screen-height () int) -(defbinding screen-width-mm () int) -(defbinding screen-height-mm () int) +(defbinding atom-intern (atom-name &optional only-if-exists) atom + ((string atom-name) string) + (only-if-exists boolean)) -(defbinding flush () nil) -(defbinding beep () nil) +(defbinding atom-name () string + (atom atom)) @@ -378,15 +422,20 @@ ;;; 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 source mask fg bg + (x 0) (y 0) (display (display-get-default))) + (etypecase source + (keyword (%cursor-new-for-display display source)) + (pixbuf (%cursor-new-from-pixbuf display source x y)) + (pixmap (%cursor-new-from-pixmap source mask + (or fg (ensure-color #(0.0 0.0 0.0))) + (or bg (ensure-color #(1.0 1.0 1.0))) x y)) + (pathname (%cursor-new-from-pixbuf display (pixbuf-load source) x y)))) + +(defun ensure-cursor (cursor &rest args) + (if (typep cursor 'cursor) + cursor + (apply #'make-instance 'cursor :type cursor args))) (defbinding %cursor-new-for-display () pointer (display display) @@ -461,13 +510,24 @@ ;;; 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 @@ -476,15 +536,25 @@ %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 @@ -646,13 +716,19 @@ (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)) -(defbinding keyval-to-lower ()unsigned-int +(defbinding keyval-to-lower () unsigned-int (keyval unsigned-int)) (defbinding (keyval-is-upper-p "gdk_keyval_is_upper") () boolean @@ -661,3 +737,72 @@ (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)))))