event.lisp 11 KB
Newer Older
hatchond's avatar
hatchond committed
1
;;; -*- Mode: Lisp; Package: CLX-EXTENSIONS -*-
2
;;; $Id: event.lisp,v 1.9 2005/01/15 12:27:00 ihatchondo Exp $
hatchond's avatar
hatchond committed
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
;;;
;;; Add on for CLX to have some CLOS events.
;;; This file is part of Eclipse.
;;; Copyright (C) 2000, 2001, 2002 Iban HATCHONDO
;;; contact : hatchond@yahoo.fr
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation.
;;;
;;; This program 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 General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.

(declaim (optimize (speed 3)
Iban Hatchondo's avatar
Iban Hatchondo committed
23
		   (safety 0)
hatchond's avatar
hatchond committed
24
25
26
27
28
29
30
31
		   (debug 0)
		   (compilation-speed 0)))

(in-package :clx-extensions)

;;;; Creation of all event's classes
;;; Standard generic class for all event

32
33
(eval-when (:compile-toplevel :load-toplevel :execute)

hatchond's avatar
hatchond committed
34
35
36
37
38
39
40
41
42
43
(defclass event ()
  ((event-window :initarg :event-window :reader event-event-window)
   (send-event-p :initform nil
		 :initarg :send-event-p
		 :reader event-send-event-p)))

;;; Mixin

(defclass window-mixin ()
  ((window :initarg :window :initform nil :reader event-window)))
Iban Hatchondo's avatar
Iban Hatchondo committed
44

hatchond's avatar
hatchond committed
45
46
47
(defclass coordinates-mixin ()
  ((x :initarg :x :reader event-x)
   (y :initarg :y :reader event-y)))
Iban Hatchondo's avatar
Iban Hatchondo committed
48

hatchond's avatar
hatchond committed
49
50
51
(defclass size-mixin ()
  ((width :initarg :width :reader event-width)
   (height :initarg :height :reader event-height)))
Iban Hatchondo's avatar
Iban Hatchondo committed
52

hatchond's avatar
hatchond committed
53
54
55
56
(defclass root-mixin ()
  ((root :initarg :root :reader event-root)
   (root-x :initarg :root-x :reader event-root-x)
   (root-y :initarg :root-y :reader event-root-y)))
Iban Hatchondo's avatar
Iban Hatchondo committed
57

hatchond's avatar
hatchond committed
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
(defclass opcode-mixin () ;; for exopsure's
  ((drawable :initarg :drawable :reader event-drawable)
   (major :initarg :major :reader major)
   (minor :initarg :minor :reader minor)))

(defclass keyboard-pointer-event (event coordinates-mixin root-mixin)
  ((code :initarg :code :reader event-code)
   (state :initarg :state :reader event-state)
   (time :initarg :time :reader event-time)
   (child :initarg :child :reader event-child)
   (same-screen-p :initarg :same-screen-p :reader event-same-screen-p)))

(defclass in-out-window-event (event coordinates-mixin root-mixin)
  ((mode :initarg :mode :reader event-mode)
   (kind :initarg :kind :reader event-kind)
   (focus-p :initarg :focus-p :reader event-focus-p)
   (state :initarg :state :reader event-state)
   (time :initarg :time :reader event-time)
   (child :initarg :child :reader event-child)
   (same-screen-p :initarg :same-screen-p :reader event-same-screen-p)))

Iban Hatchondo's avatar
Iban Hatchondo committed
79
80
81
82
83
84
85
86
87
88
89
90
91
(defclass pointer-event (keyboard-pointer-event) ())
(defclass keyboard-event (keyboard-pointer-event) ())

;;; Keyboard and pointer events

(defclass button-press (pointer-event) ())
(defclass button-release (pointer-event) ())
(defclass motion-notify (pointer-event)
  ((hint-p :initarg :hint-p :reader event-hint-p)))

(defclass key-press (keyboard-event) ())
(defclass key-release (keyboard-event) ())

hatchond's avatar
hatchond committed
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
(defclass leave-notify (in-out-window-event) ())
(defclass enter-notify (in-out-window-event) ())

;;; Input focus events

(defclass input-focus-event (event)
  ((mode :initarg :mode :reader event-mode)
   (kind :initarg :kind :reader event-kind)))

(defclass focus-in (input-focus-event) ())
(defclass focus-out (input-focus-event) ())

;;; Keyboard and pointer state events

(defclass keymap-notify (event)
  ((keymap :initarg :keymap :reader event-keymap)))
Iban Hatchondo's avatar
Iban Hatchondo committed
108

hatchond's avatar
hatchond committed
109
110
111
112
113
114
115
116
117
(defclass mapping-notify (event)
  ((request :initarg :request :reader event-request)
   (start :initarg :start :reader event-start)
   (count :initarg :count :reader event-count)))

;;; Exposure events

(defclass exposure (event coordinates-mixin size-mixin)
  ((count :initarg :count :reader event-count)))
Iban Hatchondo's avatar
Iban Hatchondo committed
118

hatchond's avatar
hatchond committed
119
(defclass no-exposure (event opcode-mixin) ())
Iban Hatchondo's avatar
Iban Hatchondo committed
120

hatchond's avatar
hatchond committed
121
122
123
124
125
126
(defclass graphics-exposure  (exposure opcode-mixin) ())

;;; Window state events

(defclass circulate-notify (event window-mixin)
  ((place :initarg :place :reader event-window-place)))
Iban Hatchondo's avatar
Iban Hatchondo committed
127

hatchond's avatar
hatchond committed
128
129
130
(defclass configure-notify (event coordinates-mixin size-mixin window-mixin)
  ((border-width :initarg :border-width :reader event-border-width)
   (above-sibling :initarg :above-sibling :reader event-above-sibling)
Iban Hatchondo's avatar
Iban Hatchondo committed
131
132
133
134
   (override-redirect-p
     :initarg :override-redirect-p
     :reader event-override-redirect-p)))

hatchond's avatar
hatchond committed
135
136
137
(defclass create-notify (event coordinates-mixin size-mixin window-mixin)
  ((parent :initarg :parent :reader event-parent)
   (border-width :initarg :border-width :reader event-border-width)
Iban Hatchondo's avatar
Iban Hatchondo committed
138
139
140
141
   (override-redirect-p
     :initarg :override-redirect-p
     :reader event-override-redirect-p)))

hatchond's avatar
hatchond committed
142
(defclass map-notify (event window-mixin)
Iban Hatchondo's avatar
Iban Hatchondo committed
143
144
145
146
  ((override-redirect-p
     :initarg :override-redirect-p
     :reader event-override-redirect-p)))

hatchond's avatar
hatchond committed
147
148
(defclass reparent-notify (event coordinates-mixin window-mixin)
  ((parent :initarg :parent :reader event-parent)
Iban Hatchondo's avatar
Iban Hatchondo committed
149
150
151
152
   (override-redirect-p
     :initarg :override-redirect-p
     :reader event-override-redirect-p)))

hatchond's avatar
hatchond committed
153
154
(defclass unmap-notify (event window-mixin)
  ((configure-p :initarg :configure-p :reader event-configure-p)))
Iban Hatchondo's avatar
Iban Hatchondo committed
155

hatchond's avatar
hatchond committed
156
157
(defclass visibility-notify (event)
  ((state :initarg :state :reader event-state)))
Iban Hatchondo's avatar
Iban Hatchondo committed
158

hatchond's avatar
hatchond committed
159
(defclass destroy-notify (event window-mixin) ())
Iban Hatchondo's avatar
Iban Hatchondo committed
160

hatchond's avatar
hatchond committed
161
162
163
164
165
166
167
168
(defclass gravity-notify (event coordinates-mixin window-mixin) ())

;;; Structure control event

(defclass colormap-notify (event)
  ((colormap :initarg :colormap :reader event-colormap)
   (new-p :initarg :new-p :reader event-new-p)
   (installed-p :initarg :installed-p :reader event-installed-p)))
Iban Hatchondo's avatar
Iban Hatchondo committed
169

hatchond's avatar
hatchond committed
170
171
172
173
174
(defclass configure-request (event coordinates-mixin size-mixin window-mixin)
  ((border-width :initarg :border-width  :reader event-border-width)
   (stack-mode :initarg :stack-mode :reader event-stack-mode)
   (above-sibling :initarg :above-sibling :reader event-above-sibling)
   (value-mask :initarg :value-mask :reader event-value-mask)))
Iban Hatchondo's avatar
Iban Hatchondo committed
175

hatchond's avatar
hatchond committed
176
(defclass map-request (event window-mixin) ())
Iban Hatchondo's avatar
Iban Hatchondo committed
177

hatchond's avatar
hatchond committed
178
(defclass resize-request (event size-mixin window-mixin) ())
Iban Hatchondo's avatar
Iban Hatchondo committed
179

hatchond's avatar
hatchond committed
180
181
182
183
184
185
186
187
(defclass circulate-request (circulate-notify) ())

;;; Client communications events

(defclass client-message (event)
  ((type :initarg :type :reader event-type)
   (format :initarg :format :reader event-data-format)
   (data :initarg :data :reader event-data)))
Iban Hatchondo's avatar
Iban Hatchondo committed
188

hatchond's avatar
hatchond committed
189
190
191
192
(defclass property-notify (event)
  ((atom :initarg :atom :reader event-atom)
   (state :initarg :state :reader event-state)
   (time :initarg :time :reader event-time)))
Iban Hatchondo's avatar
Iban Hatchondo committed
193

hatchond's avatar
hatchond committed
194
195
196
(defclass selection-clear (event)
  ((selection :initarg :selection :reader event-selection)
   (time :initarg :time :reader event-time)))
Iban Hatchondo's avatar
Iban Hatchondo committed
197

hatchond's avatar
hatchond committed
198
199
200
(defclass selection-notify (selection-clear)
  ((target :initarg :target :reader event-target)
   (property :initarg :property :reader event-property)))
Iban Hatchondo's avatar
Iban Hatchondo committed
201

hatchond's avatar
hatchond committed
202
203
204
(defclass selection-request (selection-notify)
  ((requestor :initarg :requestor :reader event-requestor)))

205
206
) ;; End eval-when.

hatchond's avatar
hatchond committed
207
208
209
210
211
212
;;; We use resourcing in get-next-event.

(defparameter *events* (make-hash-table))

(defun initialize-event-table ()
  (loop for event-key across
hatchond's avatar
hatchond committed
213
214
215
216
	   (the (simple-array (or null keyword) (*)) xlib::*event-key-vector*)
	for symbol = (intern (symbol-name event-key))
	when (and event-key (find-class symbol nil)) do
	  (setf (gethash event-key *events*) (make-instance symbol))))
hatchond's avatar
hatchond committed
217
218
219

(initialize-event-table)

hatchond's avatar
hatchond committed
220
(defgeneric make-event (event-key &rest args)
Iban Hatchondo's avatar
Iban Hatchondo committed
221
222
223
  (:documentation "returns an new event of type given by event-key")
  (:method (event-key &rest args)
    (declare (ignore args))))
hatchond's avatar
hatchond committed
224
225

(defgeneric re-initialize-event (event-key &rest args)
Iban Hatchondo's avatar
Iban Hatchondo committed
226
227
228
  (:documentation "re-initialize the event of type given by event-key")
  (:method (event-key &rest args)
    (declare (ignore args))))
hatchond's avatar
hatchond committed
229

hatchond's avatar
hatchond committed
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
;;; Macro constructor

(defmacro class-slots (class)
  #+allegro `(clos:class-slots ,class)
  #+clisp `(clos::class-slots ,class)
  #+cmu `(pcl::class-slots ,class)
  #+cormanlisp `(cl:class-slots ,class)
  #+lispworks `(hcl::class-slots ,class)
  #+lucid `(clos:class-slots ,class)
  #+sbcl `(sb-pcl::class-slots ,class))

(defmacro slot-initargs (slot)
  #+(and allegro (not (version>= 6))) `(clos::slotd-initargs ,slot)
  #+(and allegro (version>= 6)) `(clos:slot-definition-initargs ,slot)
  #+clisp `(clos::slotdef-initargs ,slot)
  #+cmu `(slot-value ,slot 'pcl::initargs)
  #+cormanlisp `(getf ,slot :initargs)
  #+lispworks `(hcl::slot-definition-initargs ,slot)
  #+lucid `(clos:slot-definition-initargs ,slot)
  #+sbcl `(slot-value ,slot 'sb-pcl::initargs))

251
252
253
254
255
(defmacro finalize-inheritance (class)
  #+sbcl `(sb-mop:finalize-inheritance ,class)
  #+cmu `(pcl:finalize-inheritance ,class)
  #+clisp `(clos:finalize-inheritance ,class))

hatchond's avatar
hatchond committed
256
(defmacro class-initargs (class)
257
258
259
  `(progn 
     (finalize-inheritance ,class)
     (loop for slot in (class-slots ,class) collect (car (slot-initargs slot)))))
hatchond's avatar
hatchond committed
260
261

(macrolet ((define-make-event-function ()
Iban Hatchondo's avatar
Iban Hatchondo committed
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
  (flet ((make-initarg-key-value-pair (initargs)
	   (loop for k in initargs collect k collect (intern (symbol-name k))))
	 (make-arg-list (event-key initargs)
	   `((,(gensym) (eql ,event-key))
	     &key ,@(mapcar #'(lambda (k) (intern (symbol-name k))) initargs)
	     &allow-other-keys)))
    `(progn
       ,@(loop for event-key across xlib::*event-key-vector*
	       for class = (find-class (intern (symbol-name event-key)) nil)
	       for initargs = (when class (class-initargs class))
	       when class
	       collect
	       `(defmethod make-event ,(make-arg-list event-key initargs)
		  (make-instance ',(intern (symbol-name event-key))
		      ,@(make-initarg-key-value-pair initargs)))
	       and collect
	       `(defmethod re-initialize-event
		    ,(make-arg-list event-key initargs)
		  (reinitialize-instance (gethash ,event-key *events*)
		      ,@(make-initarg-key-value-pair initargs))))))))
hatchond's avatar
hatchond committed
282
283
284
285
286
  (define-make-event-function))

;;;; New event-processing function

(defun clos-event-handler (&rest event-slots &key event-key &allow-other-keys)
hatchond's avatar
hatchond committed
287
288
289
  "This display event handler returns an event object of type given by 
   EVENT-KEY. It use only one instance of each event type, by reinitializing 
   them each time it receive an event. Returns nil if no object can be found."
hatchond's avatar
hatchond committed
290
291
292
  (apply #'re-initialize-event event-key event-slots))

(defun get-next-event (display &key timeout peek-p discard-p (force-output-p t))
hatchond's avatar
hatchond committed
293
294
295
296
297
298
299
300
301
302
  "If force-output-p is true, first invokes display-force-output. Invokes 
   clos-event-handler on the first queued event, and returns event object.
   If such an object can not be found (i.e.: does not have a corresponding 
   class) invokes clos-event-handler on the next queued event and so on.
   If peek-p is true, then the event is not removed from the queue.  
   If discard-p is true, then events for which event-clos-handler returns nil
   (i.e.: event who do not have a corresponding class) are removed from the 
   queue, otherwise they are left in place.
   Hangs until non-nil is generated for some event, or for the specified 
   timeout (in seconds, if given); Returns nil on timeout."
hatchond's avatar
hatchond committed
303
304
305
  (xlib:process-event display :handler #'clos-event-handler
		      :timeout timeout :peek-p peek-p
		      :discard-p discard-p :force-output-p force-output-p))