X-Git-Url: https://git.distorted.org.uk/~mdw/clg/blobdiff_plain/628fd576ba4f6e93fbdc993e536ec8252d2a62ab..57e4839d54020363a38e0872abefafc63697beeb:/gdk/gdk.lisp diff --git a/gdk/gdk.lisp b/gdk/gdk.lisp index 8fffdb6..c17ab6a 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-2006 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.13 2005-01-30 15:08:03 espen Exp $ +;; $Id: gdk.lisp,v 1.28 2006-04-25 22:27:13 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,46 @@ (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 keyboard-grab () int +(defbinding (pointer-is-grabbed-p "gdk_display_pointer_is_grabbed") + (&optional (display (display-get-default))) boolean + (display display)) + +(defbinding keyboard-grab (window &key owner-events time) grab-status (window window) (owner-events boolean) - (time (unsigned 32))) - -(defbinding keyboard-ungrab () nil - (time (unsigned 32))) - -(defbinding (pointer-is-grabbed-p "gdk_pointer_is_grabbed") () boolean) + ((or time 0) (unsigned 32))) -(defbinding screen-width () int) -(defbinding screen-height () int) +(defbinding (keyboard-ungrab "gdk_display_keyboard_ungrab") + (&optional time (display (display-get-default))) nil + (display display) + ((or time 0) (unsigned 32))) -(defbinding screen-width-mm () int) -(defbinding screen-height-mm () int) -(defbinding flush () nil) -(defbinding beep () nil) (defbinding atom-intern (atom-name &optional only-if-exists) atom ((string atom-name) string) @@ -303,7 +341,7 @@ (root-y int) (timestamp unsigned-int)) -;; komplett så langt +;; (defbinding window-set-user-data () nil (window window) @@ -385,15 +423,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) @@ -417,14 +460,6 @@ (defbinding %cursor-unref () nil (location pointer)) -(defmethod reference-foreign ((class (eql (find-class 'cursor))) location) - (declare (ignore class)) - (%cursor-ref location)) - -(defmethod unreference-foreign ((class (eql (find-class 'cursor))) location) - (declare (ignore class)) - (%cursor-unref location)) - ;;; Pixmaps @@ -439,7 +474,7 @@ (colormap (or null colormap)) (mask bitmap :out) (color (or null color)) - (filename string)) + (filename pathname)) (defbinding %pixmap-colormap-create-from-xpm-d () pixmap (window (or null window)) @@ -456,26 +491,32 @@ (multiple-value-bind (pixmap mask) (etypecase source ((or string pathname) - (%pixmap-colormap-create-from-xpm - window colormap color (namestring (truename source)))) + (%pixmap-colormap-create-from-xpm window colormap color source)) ((vector string) (%pixmap-colormap-create-from-xpm-d window colormap color source))) -;; (unreference-instance pixmap) -;; (unreference-instance mask) (values pixmap mask)))) ;;; 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-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) - (declare (ignore initargs)) +(defmethod initialize-instance ((color color) &key (red 0.0) (green 0.0) (blue 0.0)) (call-next-method) (with-slots ((%red red) (%green green) (%blue blue)) color (setf @@ -483,18 +524,29 @@ %green (%scale-value green) %blue (%scale-value blue)))) +(defbinding %color-parse () boolean + (spec string) + (color color :in/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 +;;; Drawable -- all the draw- functions are dprecated and will be +;;; removed, use cairo for drawing instead. (defbinding drawable-get-size () nil (drawable drawable) @@ -526,20 +578,11 @@ (points pointer) (n-points int)) -;; (defun draw-points (drawable gc &rest points) - -;; ) - (defbinding draw-line () nil (drawable drawable) (gc gc) (x1 int) (y1 int) (x2 int) (y2 int)) -;; (defbinding draw-lines (drawable gc &rest points) nil -;; (drawable drawable) (gc gc) -;; (points (vector point)) -;; ((length points) int)) - (defbinding draw-pixbuf (drawable gc pixbuf src-x src-y dest-x dest-y &optional width height (dither :none) (x-dither 0) (y-dither 0)) nil @@ -551,11 +594,6 @@ (dither rgb-dither) (x-dither int) (y-dither int)) -;; (defbinding draw-segments (drawable gc &rest points) nil -;; (drawable drawable) (gc gc) -;; (segments (vector segments)) -;; ((length segments) int)) - (defbinding draw-rectangle () nil (drawable drawable) (gc gc) (filled boolean) @@ -569,35 +607,6 @@ (width int) (height int) (angle1 int) (angle2 int)) -;; (defbinding draw-polygon (drawable gc &rest points) nil -;; (drawable drawable) (gc gc) -;; (points (vector point)) -;; ((length points) int)) - -;; (defbinding draw-trapezoid (drawable gc &rest points) nil -;; (drawable drawable) (gc gc) -;; (points (vector point)) -;; ((length points) int)) - -;; (defbinding %draw-layout-line () nil -;; (drawable drawable) (gc gc) -;; (font pango:font) -;; (x int) (y int) -;; (line pango:layout-line)) - -;; (defbinding %draw-layout-line-with-colors () nil -;; (drawable drawable) (gc gc) -;; (font pango:font) -;; (x int) (y int) -;; (line pango:layout-line) -;; (foreground (or null color)) -;; (background (or null color))) - -;; (defun draw-layout-line (drawable gc font x y line &optional foreground background) -;; (if (or foreground background) -;; (%draw-layout-line-with-colors drawable gc font x y line foreground background) -;; (%draw-layout-line drawable gc font x y line))) - (defbinding %draw-layout () nil (drawable drawable) (gc gc) (font pango:font) @@ -653,9 +662,15 @@ (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)) @@ -668,3 +683,72 @@ (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") +(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) + (invalidate-instance ,cr t)))) + + (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 + ,@body + (threads-leave t)))))