X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/clg/blobdiff_plain/9adccb27da69b60d058aa37867d55ea20ecf97ca..57e4839d54020363a38e0872abefafc63697beeb:/gdk/gdkevents.lisp diff --git a/gdk/gdkevents.lisp b/gdk/gdkevents.lisp index 7b0b698..3d7331a 100644 --- a/gdk/gdkevents.lisp +++ b/gdk/gdkevents.lisp @@ -1,26 +1,62 @@ -;; Common Lisp bindings for GTK+ v2.0 -;; Copyright (C) 1999-2001 Espen S. Johnsen +;; Common Lisp bindings for GTK+ v2.x +;; Copyright 1999-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: gdkevents.lisp,v 1.5 2004-11-06 21:39:58 espen Exp $ +;; $Id: gdkevents.lisp,v 1.12 2006-04-26 09:20:20 espen Exp $ (in-package "GDK") -(defvar *event-classes* (make-hash-table)) +;;;; Metaclass for event classes + +(eval-when (:compile-toplevel :load-toplevel :execute) + (defvar *event-classes* (make-hash-table)) + + (defclass event-class (boxed-class) + ((event-type :reader event-class-type :initform nil))) + + (defmethod validate-superclass ((class event-class) (super standard-class)) + ;(subtypep (class-name super) 'event) + t) + + (defmethod shared-initialize ((class event-class) names &key name event-type) + (declare (ignore names)) + (register-type-alias (or name (class-name class)) 'event) + (call-next-method) + (when event-type + (setf (slot-value class 'event-type) (first event-type)) + (setf (gethash (first event-type) *event-classes*) class)))) + +(let ((reader (reader-function 'event-type))) + (defun %event-class (location) + (gethash (funcall reader location 0) *event-classes*))) + +(defmethod make-proxy-instance :around ((class event-class) location + &rest initargs) + (let ((class (%event-class location))) + (apply #'call-next-method class location initargs))) + + +;; The class event is the only class that actually exists in the +;; GObject class hierarchy (eval-when (:compile-toplevel :load-toplevel :execute) (defclass event (boxed) @@ -36,45 +72,18 @@ (defclass event (boxed) :allocation :alien :accessor event-send-event :initarg :send-event - :type (boolean 8)) - (%align :allocation :alien :offset 2 :type (unsigned 8))) + :type (bool 8))) (:metaclass boxed-class))) - (defmethod initialize-instance ((event event) &rest initargs) (declare (ignore initargs)) (call-next-method) (setf (slot-value event '%type) (event-class-type (class-of event)))) - -;;;; Metaclass for event classes - -(eval-when (:compile-toplevel :load-toplevel :execute) - (defclass event-class (boxed-class) - ((event-type :reader event-class-type))) - - (defmethod validate-superclass ((class event-class) (super standard-class)) - (subtypep (class-name super) 'event))) - - -(defmethod shared-initialize ((class event-class) names &key name type) - (call-next-method) - (setf (slot-value class 'event-type) (first type)) - (setf (gethash (first type) *event-classes*) class) - (let ((class-name (or name (class-name class)))) - (register-type class-name 'event))) - -(let ((reader (reader-function 'event-type))) - (defun %event-class (location) - (gethash (funcall reader location 0) *event-classes*))) - -(defmethod ensure-proxy-instance ((class event-class) location) - (declare (ignore class)) +(defmethod make-proxy-instance :around ((class (eql (find-class 'event))) location &rest initargs) (let ((class (%event-class location))) - (make-instance class :location location))) - + (apply #'call-next-method class location initargs))) -;;;; (defclass timed-event (event) ((time @@ -87,13 +96,13 @@ (defclass timed-event (event) (defclass delete-event (event) () (:metaclass event-class) - (:type :delete)) + (:event-type :delete)) (defclass destroy-event (event) () (:metaclass event-class) - (:type :destroy)) + (:event-type :destroy)) (defclass expose-event (event) ((x @@ -116,15 +125,20 @@ (defclass expose-event (event) :accessor event-height :initarg :height :type int) + (region + :allocation :alien + :accessor event-region + :initarg :region + :type pointer) (count :allocation :alien :accessor event-count :initarg :count :type int)) (:metaclass event-class) - (:type :expose)) + (:event-type :expose)) -(defclass motion-notify-event (timed-event) +(defclass input-event (timed-event) ((x :allocation :alien :accessor event-x @@ -135,13 +149,21 @@ (defclass motion-notify-event (timed-event) :accessor event-y :initarg :y :type double-float) + (axes + :allocation :alien + :accessor event-axes + :initarg :axes + :type pointer) ;double-float) (state :allocation :alien - :offset #.(size-of 'pointer) :accessor event-state :initarg :state - :type unsigned-int) - (is-hint + :type modifier-type)) + (:metaclass event-class)) + + +(defclass motion-notify-event (input-event) + ((is-hint :allocation :alien :accessor event-is-hint :initarg :is-hint @@ -164,26 +186,10 @@ (defclass motion-notify-event (timed-event) :initarg :root-y :type double-float)) (:metaclass event-class) - (:type :motion-notify)) + (:event-type :motion-notify)) -(defclass button-press-event (timed-event) - ((x - :allocation :alien - :accessor event-x - :initarg :x - :type double-float) - (y - :allocation :alien - :accessor event-y - :initarg :y - :type double-float) - (state - :allocation :alien - :offset #.(size-of 'pointer) - :accessor event-state - :initarg :state - :type modifier-type) - (button +(defclass button-event (input-event) + ((button :allocation :alien :accessor event-button :initarg :button @@ -203,48 +209,145 @@ (defclass button-press-event (timed-event) :accessor event-root-y :initarg :root-y :type double-float)) + (:metaclass event-class)) + +(defclass button-press-event (button-event) + () (:metaclass event-class) - (:type :button-press)) + (:event-type :button-press)) (defclass 2-button-press-event (button-press-event) () (:metaclass event-class) - (:type :2button-press)) + (:event-type :2button-press)) (defclass 3-button-press-event (button-press-event) () (:metaclass event-class) - (:type :3button-press)) + (:event-type :3button-press)) -(defclass button-release-event (button-press-event) +(defclass button-release-event (button-event) () (:metaclass event-class) - (:type :button-release)) + (:event-type :button-release)) + + +(defclass key-event (timed-event) + ((state + :allocation :alien + :accessor event-state + :initarg :state + :type modifier-type) + (keyval + :allocation :alien + :accessor event-keyval + :initarg :keyval + :type unsigned-int) + (length + :allocation :alien + :accessor event-length + :initarg :length + :type unsigned-int) + (string + :allocation :alien + :accessor event-string + :initarg :string + :type string) + (hardware-keycode + :allocation :alien + :accessor event-hardware-keycode + :initarg :hardware-keycode + :type (unsigned 16)) + (group + :allocation :alien + :accessor event-group + :initarg :group + :type (unsigned 8))) + (:metaclass event-class)) -(defclass key-press-event (event) +(defclass key-press-event (key-event) () (:metaclass event-class) - (:type :key-press)) + (:event-type :key-press)) -(defclass key-release-event (event) +(defclass key-release-event (key-event) () (:metaclass event-class) - (:type :key-release)) + (:event-type :key-release)) + + +(defclass crossing-event (event) + ((subwindow + :allocation :alien + :accessor event-subwindow + :initarg :subwindow + :type window) + (time + :allocation :alien + :accessor event-time + :initarg :time + :type (unsigned 32)) + (x + :allocation :alien + :accessor event-x + :initarg :x + :type double-float) + (y + :allocation :alien + :accessor event-y + :initarg :y + :type double-float) + (root-x + :allocation :alien + :accessor event-root-x + :initarg :root-x + :type double-float) + (root-y + :allocation :alien + :accessor event-root-y + :initarg :root-y + :type double-float) + (mode + :allocation :alien + :accessor event-mode + :initarg :mode + :type crossing-mode) + (detail + :allocation :alien + :accessor event-detail + :initarg :detail + :type notify-type) + (focus + :allocation :alien + :accessor event-focus + :initarg :focus + :type boolean) + (state + :allocation :alien + :accessor event-state + :initarg :state + :type unsigned-int)) + (:metaclass event-class)) + -(defclass enter-notify-event (event) +(defclass enter-notify-event (crossing-event) () (:metaclass event-class) - (:type :enter-notify)) + (:event-type :enter-notify)) -(defclass leave-notify-event (event) +(defclass leave-notify-event (crossing-event) () (:metaclass event-class) - (:type :leave-notify)) + (:event-type :leave-notify)) (defclass focus-change-event (event) - () + ((in + :allocation :alien + :accessor event-in + :initarg :in + :type (bool 16))) (:metaclass event-class) - (:type :focus-change)) + (:event-type :focus-change)) (defclass configure-event (event) ((x @@ -268,73 +371,95 @@ (defclass configure-event (event) :initarg :height :type int)) (:metaclass event-class) - (:type :configure)) + (:event-type :configure)) (defclass map-event (event) () (:metaclass event-class) - (:type :map)) + (:event-type :map)) (defclass unmap-event (event) () (:metaclass event-class) - (:type :unmap)) + (:event-type :unmap)) (defclass property-notify-event (event) () (:metaclass event-class) - (:type :property-notify)) + (:event-type :property-notify)) (defclass selection-clear-event (event) () (:metaclass event-class) - (:type :selection-clear)) + (:event-type :selection-clear)) (defclass selection-request-event (event) () (:metaclass event-class) - (:type :selection-request)) + (:event-type :selection-request)) (defclass selection-notify-event (event) () (:metaclass event-class) - (:type :selection-notify)) + (:event-type :selection-notify)) + +(defclass dnd-event (event) + ((context + :allocation :alien + :accessor event-contex + :initarg :context + :type drag-context) + (time + :allocation :alien + :accessor event-time + :initarg :time + :type (unsigned 32)) + (x-root + :allocation :alien + :accessor event-x-root + :initarg :x-root + :type short) + (y-root + :allocation :alien + :accessor event-y-root + :initarg :y-root + :type short)) + (:metaclass event-class)) -(defclass drag-enter-event (event) +(defclass drag-enter-event (dnd-event) () (:metaclass event-class) - (:type :drag-enter)) + (:event-type :drag-enter)) -(defclass drag-leave-event (event) +(defclass drag-leave-event (dnd-event) () (:metaclass event-class) - (:type :drag-leave)) + (:event-type :drag-leave)) -(defclass drag-motion-event (event) +(defclass drag-motion-event (dnd-event) () (:metaclass event-class) - (:type :drag-motion)) + (:event-type :drag-motion)) -(defclass drag-status-event (event) +(defclass drag-status-event (dnd-event) () (:metaclass event-class) - (:type :drag-status)) + (:event-type :drag-status)) -(defclass drag-start-event (event) +(defclass drot-start-event (dnd-event) () (:metaclass event-class) - (:type :drag-start)) + (:event-type :drop-start)) -(defclass drag-finished-event (event) +(defclass drop-finished-event (dnd-event) () (:metaclass event-class) - (:type :drag-finished)) + (:event-type :drop-finished)) (defclass client-event (event) () (:metaclass event-class) - ;(:type :client-event) - ) + (:event-type :client-event)) (defclass visibility-notify-event (event) ((state @@ -343,19 +468,95 @@ (defclass visibility-notify-event (event) :initarg :state :type visibility-state)) (:metaclass event-class) - (:type :visibility-notify)) + (:event-type :visibility-notify)) (defclass no-expose-event (event) () (:metaclass event-class) - (:type :no-expose)) + (:event-type :no-expose)) (defclass scroll-event (timed-event) + ((x + :allocation :alien + :accessor event-x + :initarg :x + :type double-float) + (y + :allocation :alien + :accessor event-y + :initarg :y + :type double-float) + (state + :allocation :alien + :accessor event-state + :initarg :state + :type modifier-type) + (direction + :allocation :alien + :accessor event-direction + :initarg :direction + :type scroll-direction) + (root-x + :allocation :alien + :accessor event-root-x + :initarg :root-x + :type double-float) + (root-y + :allocation :alien + :accessor event-root-y + :initarg :root-y + :type double-float)) + (:metaclass event-class) + (:event-type :scroll)) + +(defclass setting-event (event) + ((action + :allocation :alien + :accessor event-action + :initarg :action + :type setting-action) + (name + :allocation :alien + :accessor event-name + :initarg :name + :type string)) + (:metaclass event-class) + (:event-type :setting)) + +(defclass proximity-event (timed-event) + ((device + :allocation :alien + :accessor event-device + :initarg :device + :type device)) + (:metaclass event-class)) + +(defclass proximity-in-event (proximity-event) + () + (:metaclass event-class) + (:event-type :proximity-in)) + +(defclass proximity-out-event (proximity-event) () (:metaclass event-class) - (:type :scroll)) + (:event-type :proximity-out)) -(defclass setting-event (timed-event) +(defclass window-state-event (event) + ((change-mask + :allocation :alien + :accessor event-change-mask + :initarg :change-mask + :type window-state) + (new-window-state + :allocation :alien + :accessor event-new-window-state + :initarg :new-window-state + :type window-state)) + (:metaclass event-class) + (:event-type :window-state)) + +(defclass owner-change-event (event) () (:metaclass event-class) - (:type :setting)) + (:event-type :owner-change)) +