Skip to content
Newer
Older
100644 782 lines (669 sloc) 27.7 KB
3cb03ba Initial check-in
Mike McDonald authored
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 1998,1999,2000 by Michael McDonald (mikemac@mikemac.com)
c462d4a Added copyright notice to reflect modifications.
CVS pserver daemon authored
4 ;;; (c) copyright 2000 by
5 ;;; Robert Strandh (strandh@labri.u-bordeaux.fr)
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
6 ;;; (c) copyright 2001,2002 by Tim Moore (moore@bricoworks.com)
3cb03ba Initial check-in
Mike McDonald authored
7
8 ;;; This library is free software; you can redistribute it and/or
9 ;;; modify it under the terms of the GNU Library General Public
10 ;;; License as published by the Free Software Foundation; either
11 ;;; version 2 of the License, or (at your option) any later version.
12 ;;;
13 ;;; This library is distributed in the hope that it will be useful,
14 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
15 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16 ;;; Library General Public License for more details.
17 ;;;
18 ;;; You should have received a copy of the GNU Library General Public
19 ;;; License along with this library; if not, write to the
20 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
21 ;;; Boston, MA 02111-1307 USA.
22
95dff8a make all of the package names passed to in-package be lowercase keywo…
Mike McDonald authored
23 (in-package :clim-internals)
3cb03ba Initial check-in
Mike McDonald authored
24
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
25 ;;; X returns #\Return and #\Backspace where we want to see #\Newline
26 ;;; and #\Delete at the stream-read-char level. Dunno if this is the
27 ;;; right place to do the transformation...
28
4d788f9 Converting #\Backspace to #\Delete is silly, so don't do that. CL has a
Andy Hefner authored
29 ;; Why exactly do we want to see #\Delete instead of #\Backspace?
32e2763 Improved (fixed) support for keystroke accelerators
Andy Hefner authored
30 ;; There is a separate Delete key, unless your keyboard is strange. --Hefner
4d788f9 Converting #\Backspace to #\Delete is silly, so don't do that. CL has a
Andy Hefner authored
31
e1ad80e Plausable implementation of presentation-single-box
Timothy Moore authored
32 (defconstant +read-char-map+ '((#\Return . #\Newline)
33 #+nil (#\Backspace . #\Delete)))
34
65f361f Several changes on the road to real input editing. Make
Timothy Moore authored
35 (defvar *abort-gestures* '(:abort))
36
37 (defvar *accelerator-gestures* nil)
38
39 (define-condition abort-gesture (condition)
40 ((event :reader %abort-gesture-event :initarg :event)))
41
42 (defmethod abort-gesture-event ((condition abort-gesture))
43 (%abort-gesture-event condition))
44
45 (define-condition accelerator-gesture (condition)
46 ((event :reader %accelerator-gesture-event :initarg :event)
47 (numeric-argument :reader %accelerator-gesture-numeric-argument
48 :initarg :numeric-argument
49 :initform 1)))
50
51 (defmethod accelerator-gesture-event ((condition accelerator-gesture))
52 (%accelerator-gesture-event condition))
53
54 (defmethod accelerator-gesture-numeric-argument
55 ((condition accelerator-gesture))
56 (%accelerator-gesture-numeric-argument condition))
57
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
58 (defun char-for-read (char)
59 (let ((new-char (cdr (assoc char +read-char-map+))))
60 (or new-char char)))
61
62 (defun unmap-char-for-read (char)
63 (let ((new-char (car (rassoc char +read-char-map+))))
64 (or new-char char)))
65
66 ;;; Streams are subclasses of standard-sheet-input-mixin regardless of
67 ;;; whether or not we are multiprocessing. In single-process mode the
68 ;;; blocking calls to stream-read-char, stream-read-gesture are what
69 ;;; cause process-next-event to be called. It's most convenient to
70 ;;; let process-next-event queue up events for the stream and then see
71 ;;; what we've got after it returns.
72
73 (defclass standard-input-stream (fundamental-character-input-stream
74 standard-sheet-input-mixin)
3cb03ba Initial check-in
Mike McDonald authored
75 ((unread-chars :initform nil
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
76 :accessor stream-unread-chars)))
3cb03ba Initial check-in
Mike McDonald authored
77
78 (defmethod stream-read-char ((pane standard-input-stream))
79 (if (stream-unread-chars pane)
80 (pop (stream-unread-chars pane))
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
81 ;XXX
82 (flet ((do-one-event (event)
83 (if (and (typep event 'key-press-event)
4bfd8c4 Handle key events for modifier keys in order to keep track of modifier
Timothy Moore authored
84 (keyboard-event-character event))
85 (let ((char (char-for-read (keyboard-event-character
86 event))))
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
87 (stream-write-char pane char)
88 (return-from stream-read-char char))
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
89 (handle-event (event-sheet event) event))))
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
90 (let* ((port (port pane))
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
91 (queue (stream-input-buffer pane)))
f5137b6 Implement command-enabled and (setf command-enabled). This includes a
Timothy Moore authored
92 (declare (ignorable port))
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
93 (loop
bbadb18 Fix various problems found by Robert.
Timothy Moore authored
94 (let ((event (event-queue-read-no-hang queue)))
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
95 (cond (event
96 (do-one-event event))
97 (*multiprocessing-p*
98 (event-queue-listen-or-wait queue))
99 (t (process-next-event port)))))))))
3cb03ba Initial check-in
Mike McDonald authored
100
101 (defmethod stream-unread-char ((pane standard-input-stream) char)
102 (push char (stream-unread-chars pane)))
103
104 (defmethod stream-read-char-no-hang ((pane standard-input-stream))
105 (if (stream-unread-chars pane)
106 (pop (stream-unread-chars pane))
107 (loop for event = (event-read-no-hang pane)
108 if (null event)
109 return nil
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
110 if (and (typep event 'key-press-event)
4bfd8c4 Handle key events for modifier keys in order to keep track of modifier
Timothy Moore authored
111 (keyboard-event-character event))
112 return (char-for-read (keyboard-event-character event))
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
113 else
114 do (handle-event (event-sheet event) event))))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
115
fce60ba Patches from dtc for Scieneer Common Lisp, and a few other fixes too.
Timothy Moore authored
116 (defmethod stream-clear-input ((pane standard-input-stream))
117 (setf (stream-unread-chars pane) nil)
118 (loop for event = (event-read-no-hang pane)
119 if (null event)
120 return nil
121 else
122 do (handle-event (event-sheet event) event))
123 nil)
124
c10940a Really Fix dead keys.
Troels Henriksen authored
125 (defclass dead-key-merging-mixin ()
126 ((state :initform *dead-key-table*)
127 (last-deadie-gesture) ; For avoiding name clash with standard-extended-input-stream
128 (last-state))
129 (:documentation "A mixin class for extended input streams that
130 takes care of handling dead keys. This is done by still passing
131 every gesture on, but accenting the final one as per the dead
132 keys read."))
133
134 (defmethod stream-read-gesture :around
135 ((stream dead-key-merging-mixin)
136 &key timeout peek-p
137 (input-wait-test *input-wait-test*)
138 (input-wait-handler *input-wait-handler*)
139 (pointer-button-press-handler
140 *pointer-button-press-handler*))
141 (with-slots (state last-deadie-gesture last-state) stream
142 (handler-case
143 (loop with start-time = (get-internal-real-time)
144 with end-time = start-time
08a1532 Removed some code duplication in dead key handling.
Troels Henriksen authored
145 do (multiple-value-bind (gesture reason)
146 (call-next-method stream
147 :timeout (when timeout
148 (- timeout (/ (- end-time start-time)
149 internal-time-units-per-second)))
150 :peek-p peek-p
151 :input-wait-test input-wait-test
152 :input-wait-handler input-wait-handler
153 :pointer-button-press-handler
154 pointer-button-press-handler)
155 (when (null gesture)
156 (return (values nil reason)))
157 (setf end-time (get-internal-real-time)
158 last-deadie-gesture gesture
159 last-state state)
160 (merging-dead-keys (gesture state)
161 (return gesture))))
c10940a Really Fix dead keys.
Troels Henriksen authored
162 ;; Policy decision: an abort cancels the current composition.
163 (abort-gesture (c)
164 (setf state *dead-key-table*)
165 (signal c)))))
166
167 (defmethod stream-unread-gesture :around ((stream dead-key-merging-mixin) gesture)
168 (if (typep gesture '(or keyboard-event character))
169 (with-slots (state last-deadie-gesture last-state) stream
170 (setf state last-state)
171 (call-next-method stream last-deadie-gesture))
172 (call-next-method)))
173
6350fb6 Many more generic function defgenerics in decls.lisp
Christophe Rhodes authored
174 (defclass standard-extended-input-stream (extended-input-stream
175 ;; FIXME: is this still needed?
c10940a Really Fix dead keys.
Troels Henriksen authored
176 standard-sheet-input-mixin
177 dead-key-merging-mixin)
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
178 ((pointer)
b1aa61d Save the last character returned by stream-read-gesture for unreading
Timothy Moore authored
179 (cursor :initarg :text-cursor)
180 (last-gesture :accessor last-gesture :initform nil
181 :documentation "Holds the last gesture returned by
182 stream-read-gesture (not peek-p), untransformed, so it can easily be
183 unread.")))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
184
185 (defvar *input-wait-test* nil)
186 (defvar *input-wait-handler* nil)
187 (defvar *pointer-button-press-handler* nil)
188
f2e6b6a Checkin to get context sensitive input working with multi-threaded
Timothy Moore authored
189 (defmacro with-input-focus ((stream) &body body)
190 (when (eq stream t)
191 (setq stream '*standard-input*))
192 (let ((old-stream (gensym "OLD-STREAM")))
193 `(let ((,old-stream (stream-set-input-focus ,stream)))
0829560 New click-to-focus policy for text-editor gadgets and panes, implemented
Christophe Rhodes authored
194 (unwind-protect (locally ,@body)
195 (when ,old-stream
196 (stream-set-input-focus ,old-stream))))))
f2e6b6a Checkin to get context sensitive input working with multi-threaded
Timothy Moore authored
197
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
198 (defun read-gesture (&key
199 (stream *standard-input*)
200 timeout
201 peek-p
202 (input-wait-test *input-wait-test*)
203 (input-wait-handler *input-wait-handler*)
204 (pointer-button-press-handler
205 *pointer-button-press-handler*))
206 (stream-read-gesture stream
207 :timeout timeout
208 :peek-p peek-p
209 :input-wait-test input-wait-test
210 :input-wait-handler input-wait-handler
211 :pointer-button-press-handler
212 pointer-button-press-handler))
213
214
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
215 ;;; Do streams care about any other events?
216 (defun handle-non-stream-event (buffer)
9499c2d Editable text fields. Support for the OR presentation type. Added
Timothy Moore authored
217 (let* ((event (event-queue-peek buffer))
54d758e Don't try to get the sheet of NIL. Patch from Juliusz Chroboczek.
Christophe Rhodes authored
218 (sheet (and event (event-sheet event))))
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
219 (if (and event
cbd1f1e Change policy from "gadgets eat all events" to "active gadgets eat all
Troels Henriksen authored
220 (or (and (gadgetp sheet)
221 (gadget-active-p sheet))
9499c2d Editable text fields. Support for the OR presentation type. Added
Timothy Moore authored
222 (not (and (typep sheet 'clim-stream-pane)
223 (or (typep event 'key-press-event)
224 (typep event 'pointer-button-press-event))))))
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
225 (progn
226 (event-queue-read buffer) ;eat it
227 (handle-event (event-sheet event) event)
228 t)
229 nil)))
230
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
231 (defun pop-gesture (buffer peek-p)
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
232 (if peek-p
233 (event-queue-peek buffer)
234 (event-queue-read-no-hang buffer)))
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
235
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
236
237 (defun repush-gesture (gesture buffer)
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
238 (event-queue-prepend buffer gesture))
ab48133 unify the sheet-event-queue and the input buffer
Mike McDonald authored
239
240 (defmethod convert-to-gesture ((ev event))
241 nil)
242
243 (defmethod convert-to-gesture ((ev character))
244 ev)
245
246 (defmethod convert-to-gesture ((ev symbol))
247 ev)
248
249 (defmethod convert-to-gesture ((ev key-press-event))
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
250 (let ((modifiers (event-modifier-state ev))
4bfd8c4 Handle key events for modifier keys in order to keep track of modifier
Timothy Moore authored
251 (event ev)
252 (char nil))
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
253 (when (or (zerop modifiers)
254 (eql modifiers +shift-key+))
4bfd8c4 Handle key events for modifier keys in order to keep track of modifier
Timothy Moore authored
255 (setq char (keyboard-event-character ev)))
256 (if char
257 (char-for-read char)
258 event)))
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
259
260 (defmethod convert-to-gesture ((ev pointer-button-press-event))
261 ev)
262
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
263 (defmethod stream-read-gesture ((stream standard-extended-input-stream)
264 &key timeout peek-p
265 (input-wait-test *input-wait-test*)
266 (input-wait-handler *input-wait-handler*)
267 (pointer-button-press-handler
268 *pointer-button-press-handler*))
269 (with-encapsulating-stream (estream stream)
270 (let ((*input-wait-test* input-wait-test)
271 (*input-wait-handler* input-wait-handler)
272 (*pointer-button-press-handler* pointer-button-press-handler)
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
273 (buffer (stream-input-buffer stream)))
274 (tagbody
275 ;; Wait for input... or not
276 ;; XXX decay timeout.
277 wait-for-char
f2e6b6a Checkin to get context sensitive input working with multi-threaded
Timothy Moore authored
278 (multiple-value-bind (available reason)
279 (stream-input-wait estream
280 :timeout timeout
281 :input-wait-test input-wait-test)
282 (unless available
283 (case reason
284 (:timeout
285 (return-from stream-read-gesture (values nil
286 :timeout)))
287 (:input-wait-test
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
288 ;; input-wait-handler might leave the event for us. This is
289 ;; actually quite messy; I'd like to confine handle-event to
290 ;; stream-input-wait, but we can't loop back to it because the
291 ;; input handler will continue to decline to read the event :(
292 (let ((event (event-queue-peek buffer)))
293 (when input-wait-handler
294 (funcall input-wait-handler stream))
295 (let ((current-event (event-queue-peek buffer)))
296 (when (or (not current-event)
297 (not (eq event current-event)))
298 ;; If there's a new event input-wait-test needs to take a
299 ;; look at it.
300 (go wait-for-char)))))
301 (t (go wait-for-char)))))
302 ;; An event should be in the stream buffer now.
303 (when (handle-non-stream-event buffer)
304 (go wait-for-char))
b1aa61d Save the last character returned by stream-read-gesture for unreading
Timothy Moore authored
305 (let* ((raw-gesture (pop-gesture buffer peek-p))
306 (gesture (convert-to-gesture raw-gesture)))
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
307 ;; Sometimes key press events get generated with a key code for
308 ;; which there is no keysym. This seems to happen on my machine
309 ;; when keys are hit rapidly in succession. I'm not sure if this is
310 ;; a hardware problem with my keyboard, and this case is probably
311 ;; better handled in the backend, but for now the case below handles
312 ;; the problem. -- moore
313 (cond ((null gesture)
314 (go wait-for-char))
0829560 New click-to-focus policy for text-editor gadgets and panes, implemented
Christophe Rhodes authored
315 ((and pointer-button-press-handler
316 (typep gesture 'pointer-button-press-event))
317 (funcall pointer-button-press-handler stream gesture))
65f361f Several changes on the road to real input editing. Make
Timothy Moore authored
318 ((loop for gesture-name in *abort-gestures*
319 thereis (event-matches-gesture-name-p gesture
320 gesture-name))
321 (signal 'abort-gesture :event gesture))
322 ((loop for gesture-name in *accelerator-gestures*
323 thereis (event-matches-gesture-name-p gesture
324 gesture-name))
325 (signal 'accelerator-gesture :event gesture))
b1aa61d Save the last character returned by stream-read-gesture for unreading
Timothy Moore authored
326 (t (setf (last-gesture stream) raw-gesture)
327 (return-from stream-read-gesture gesture))))
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
328 (go wait-for-char)))))
f2e6b6a Checkin to get context sensitive input working with multi-threaded
Timothy Moore authored
329
330
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
331 (defmethod stream-input-wait ((stream standard-extended-input-stream)
332 &key timeout input-wait-test)
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
333 (block exit
334 (let* ((buffer (stream-input-buffer stream))
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
335 (port (port stream)))
f5137b6 Implement command-enabled and (setf command-enabled). This includes a
Timothy Moore authored
336 (declare (ignorable port))
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
337 ;; Loop if not multiprocessing or if input-wait-test returns nil
338 ;; XXX need to decay timeout on multiple trips through the loop
339 (tagbody
340 check-buffer
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
341 (let ((event (event-queue-peek buffer)))
342 (when event
343 (when (and input-wait-test (funcall input-wait-test stream))
344 (return-from exit (values nil :input-wait-test)))
345 (if (handle-non-stream-event buffer)
346 (go check-buffer)
347 (return-from exit t))))
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
348 ;; Event queue has been drained, time to block waiting for new events.
4f2cc1a Changed implementation of low-level streams code once again. This
Timothy Moore authored
349 (if *multiprocessing-p*
350 (unless (event-queue-listen-or-wait buffer :timeout timeout)
351 (return-from exit (values nil :timeout)))
352 (multiple-value-bind (result reason)
353 (process-next-event port :timeout timeout)
354 (unless result
355 (return-from exit (values nil reason)))))
356 (go check-buffer)))))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
357
358
359 (defun unread-gesture (gesture &key (stream *standard-input*))
360 (stream-unread-gesture stream gesture))
361
362 (defmethod stream-unread-gesture ((stream standard-extended-input-stream)
363 gesture)
b1aa61d Save the last character returned by stream-read-gesture for unreading
Timothy Moore authored
364 (declare (ignore gesture))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
365 (with-encapsulating-stream (estream stream)
b1aa61d Save the last character returned by stream-read-gesture for unreading
Timothy Moore authored
366 (let ((gesture (last-gesture stream)))
367 (when gesture
368 (setf (last-gesture stream) nil)
369 (repush-gesture gesture (stream-input-buffer estream))))))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
370
371 ;;; Standard stream methods on standard-extended-input-stream. Ignore any
372 ;;; pointer gestures in the input buffer.
d015fe5 Fixed presentation highlighting to do the right thing in the
Timothy Moore authored
373 ;;;
374 ;;; Is stream-read-gesture allowed to return :eof?
65f361f Several changes on the road to real input editing. Make
Timothy Moore authored
375
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
376 (defmethod stream-read-char ((stream standard-extended-input-stream))
377 (with-encapsulating-stream (estream stream)
d015fe5 Fixed presentation highlighting to do the right thing in the
Timothy Moore authored
378 (loop
379 with char and reason
380 do (setf (values char reason) (stream-read-gesture estream))
381 until (or (characterp char) (eq reason :eof))
382 finally (return (if (eq reason :eof)
383 reason
384 (char-for-read char))))))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
385
386 (defmethod stream-read-char-no-hang ((stream standard-extended-input-stream))
387 (with-encapsulating-stream (estream stream)
d015fe5 Fixed presentation highlighting to do the right thing in the
Timothy Moore authored
388 (loop
389 with char and reason
390 do (setf (values char reason) (stream-read-gesture estream :timeout 0))
391 until (or (characterp char) (eq reason :timeout) (eq reason :eof) )
392 finally (return (cond ((eq reason :timeout)
393 nil)
394 ((eq reason :eof)
395 :eof)
396 (t (char-for-read char)))))))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
397
398 (defmethod stream-unread-char ((stream standard-extended-input-stream)
399 char)
400 (with-encapsulating-stream (estream stream)
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
401 (stream-unread-gesture estream (unmap-char-for-read char))))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
402
403 (defmethod stream-peek-char ((stream standard-extended-input-stream))
404 (with-encapsulating-stream (estream stream)
d015fe5 Fixed presentation highlighting to do the right thing in the
Timothy Moore authored
405 (loop
406 with char and reason
407 do (setf (values char reason) (stream-read-gesture estream :peek-p t))
408 until (or (characterp char) (eq reason :eof))
409 do (stream-read-gesture estream) ; consume pointer gesture
410 finally (return (if (eq reason :eof)
411 reason
412 (char-for-read char))))))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
413
414 (defmethod stream-listen ((stream standard-extended-input-stream))
415 (with-encapsulating-stream (estream stream)
d015fe5 Fixed presentation highlighting to do the right thing in the
Timothy Moore authored
416 (loop
417 with char and reason
418 do (setf (values char reason) (stream-read-gesture estream
419 :timeout 0
420 :peek-p t))
421 until (or (characterp char) (eq reason :eof) (eq reason :timeout))
422 do (stream-read-gesture estream) ; consume pointer gesture
423 finally (return (characterp char)))))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
424
fce60ba Patches from dtc for Scieneer Common Lisp, and a few other fixes too.
Timothy Moore authored
425 (defmethod stream-clear-input ((stream standard-extended-input-stream))
426 (with-encapsulating-stream (estream stream)
427 (loop
428 with char and reason
429 do (setf (values char reason) (stream-read-gesture estream
430 :timeout 0
431 :peek-p t))
432 until (or (eq reason :eof) (eq reason :timeout))
433 do (stream-read-gesture estream) ; consume pointer gesture
434 ))
435 nil)
436
65f361f Several changes on the road to real input editing. Make
Timothy Moore authored
437 ;;; stream-read-line returns a second value of t if terminated by eof.
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
438 (defmethod stream-read-line ((stream standard-extended-input-stream))
439 (with-encapsulating-stream (estream stream)
440 (let ((result (make-array 1
a98e02f Fixed a typo in stream-read-line; the value of the :element-type was not
Robert Strandh authored
441 :element-type 'character
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
442 :adjustable t
443 :fill-pointer 0)))
444 (loop for char = (stream-read-char estream)
65f361f Several changes on the road to real input editing. Make
Timothy Moore authored
445 while (and (characterp char) (not (char= char #\Newline)))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
446 do (vector-push-extend char result)
65f361f Several changes on the road to real input editing. Make
Timothy Moore authored
447 finally (return (values (subseq result 0)
448 (not (characterp char))))))))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
449
f1abcc7 3 sets of additions/changes/fixes:
Timothy Moore authored
450 ;;; stream-read-gesture on string strings. Needed so
451 ;;; accept-from-string "just works"
452
d1685a4 Hack around lack of string stream class in CMUCL/SBCL
Timothy Moore authored
453 ;;; XXX Evil hack because "string-stream" isn't the superclass of
454 ;;; string streams in CMUCL/SBCL...
455
456 (eval-when (:compile-toplevel :load-toplevel :execute)
457 (defvar *string-input-stream-class* (with-input-from-string (s "foo")
458 (class-name (class-of s)))))
459
460 (defmethod stream-read-gesture ((stream #.*string-input-stream-class*)
f1abcc7 3 sets of additions/changes/fixes:
Timothy Moore authored
461 &key peek-p
462 &allow-other-keys)
463 (let ((char (if peek-p
464 (peek-char nil stream nil nil)
465 (read-char stream nil nil))))
466 (if char
467 char
468 (values nil :eof))))
469
ae775c2 fix use of string-stream that I didn't catch.
Timothy Moore authored
470 (defmethod stream-unread-gesture ((stream #.*string-input-stream-class*)
471 gesture)
f1abcc7 3 sets of additions/changes/fixes:
Timothy Moore authored
472 (unread-char gesture stream))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
473 ;;; Gestures
474
475 (defparameter *gesture-names* (make-hash-table))
476
477 (defmacro define-gesture-name (name type gesture-spec &key (unique t))
478 `(add-gesture-name ',name ',type ',gesture-spec ,@(and unique
479 `(:unique ',unique))))
480
f30c8e3 Added implementation of `delete-gesture-name'.
Troels Henriksen authored
481 (defun delete-gesture-name (name)
482 "Delete the gesture named by the symbol `name' from the list of
483 known gestures."
484 (remhash name *gesture-names*))
485
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
486 ;;; XXX perhaps this should be in the backend somewhere?
487 (defconstant +name-to-char+ '((:newline . #\newline)
488 (:linefeed . #\linefeed)
489 (:return . #\return)
490 (:tab . #\tab)
491 (:backspace . #\backspace)
492 (:page . #\page)
493 (:rubout . #\rubout)))
494
32e2763 Improved (fixed) support for keystroke accelerators
Andy Hefner authored
495 (defun realize-gesture-spec (type gesture-spec)
c23a5b0 snapshot of scigraph for sbcl
Timothy Moore authored
496 ;; Some CLIM code (scigraph) assumes that gesture-spec can be a symbol.
497 (unless (listp gesture-spec)
498 (setq gesture-spec (list gesture-spec)))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
499 (destructuring-bind (device-name . modifiers)
500 gesture-spec
501 (let* ((modifier-state (apply #'make-modifier-state modifiers)))
502 (cond ((and (eq type :keyboard)
503 (symbolp device-name))
32e2763 Improved (fixed) support for keystroke accelerators
Andy Hefner authored
504 (setq device-name (or (cdr (assoc device-name +name-to-char+))
505 device-name)))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
506 ((and (member type '(:pointer-button
507 :pointer-button-press
508 :pointer-button-release)
509 :test #'eq))
510 (let ((real-device-name
511 (case device-name
32e2763 Improved (fixed) support for keystroke accelerators
Andy Hefner authored
512 (:left +pointer-left-button+)
513 (:middle +pointer-middle-button+)
514 (:right +pointer-right-button+)
515 (:wheel-up +pointer-wheel-up+)
516 (:wheel-down +pointer-wheel-down+)
44db449 Fixed up a couple erroneous calls to ERROR. (~S missing argument)
Andy Hefner authored
517 (t (error "~S is not a known button" device-name)))))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
518 (setq device-name real-device-name))))
32e2763 Improved (fixed) support for keystroke accelerators
Andy Hefner authored
519 (values type device-name modifier-state))))
520
521 (defun add-gesture-name (name type gesture-spec &key unique)
522 (let ((gesture-entry (multiple-value-list (realize-gesture-spec type gesture-spec))))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
523 (if unique
524 (setf (gethash name *gesture-names*) (list gesture-entry))
32e2763 Improved (fixed) support for keystroke accelerators
Andy Hefner authored
525 (push gesture-entry (gethash name *gesture-names*)))))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
526
6f5647d Accepting-values. It's ugly and has some cursor glitches but
Timothy Moore authored
527 (defgeneric character-gesture-name (name))
528
529 (defmethod character-gesture-name ((name character))
530 name)
531
532 (defmethod character-gesture-name ((name symbol))
533 (let ((entry (car (gethash name *gesture-names*))))
534 (if entry
535 (destructuring-bind (type device-name modifier-state)
536 entry
537 (if (and (eq type :keyboard)
538 (eql modifier-state 0))
539 device-name
540 nil))
541 nil)))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
542
543 (defgeneric %event-matches-gesture (event type device-name modifier-state))
544
545 (defmethod %event-matches-gesture (event type device-name modifier-state)
536ebe3 clean up a bunch of ACL compiler warnings
Mike McDonald authored
546 (declare (ignore event type device-name modifier-state))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
547 nil)
548
549 (defmethod %event-matches-gesture ((event key-press-event)
550 (type (eql :keyboard))
551 device-name
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
552 modifier-state)
32e2763 Improved (fixed) support for keystroke accelerators
Andy Hefner authored
553 (let ((character (keyboard-event-character event))
554 (name (keyboard-event-key-name event)))
555 (and (if character
556 (eql character device-name)
557 (eql name device-name))
558 (eql (event-modifier-state event) modifier-state))))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
559
560 (defmethod %event-matches-gesture ((event pointer-button-press-event)
561 type
562 device-name
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
563 modifier-state)
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
564 (and (or (eql type :pointer-button-press)
565 (eql type :pointer-button))
566 (eql (pointer-event-button event) device-name)
567 (eql (event-modifier-state event) modifier-state)))
568
569 (defmethod %event-matches-gesture ((event pointer-button-release-event)
570 type
571 device-name
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
572 modifier-state)
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
573 (and (or (eql type :pointer-button-release)
574 (eql type :pointer-button))
575 (eql (pointer-event-button event) device-name)
576 (eql (event-modifier-state event) modifier-state)))
577
578 (defmethod %event-matches-gesture ((event pointer-button-event)
579 type
580 device-name
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
581 modifier-state)
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
582 (and (or (eql type :pointer-button-press)
583 (eql type :pointer-button-release)
584 (eql type :pointer-button))
585 (eql (pointer-event-button event) device-name)
586 (eql (event-modifier-state event) modifier-state)))
587
588 ;;; Because gesture objects are either characters or event objects, support
589 ;;; characters here too.
590
591 (defmethod %event-matches-gesture ((event character)
592 (type (eql :keyboard))
593 device-name
594 modifier-state)
595 (and (eql event device-name)
596 (eql modifier-state 0)))
597
598 (defun event-matches-gesture-name-p (event gesture-name)
32e2763 Improved (fixed) support for keystroke accelerators
Andy Hefner authored
599 ;; Just to be nice, we special-case literal characters here.
600 ;; We also special-case literal 'physical' gesture specs of
601 ;; the form (type device-name modifier-state).
602 ;; The CLIM spec requires neither of these things.
603 (let ((gesture-entry
604 (typecase gesture-name
605 (character (list (multiple-value-list (realize-gesture-spec :keyboard gesture-name))))
606 (cons (list gesture-name)) ;; Literal physical gesture
607 (t (gethash gesture-name *gesture-names*)))))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
608 (loop for (type device-name modifier-state) in gesture-entry
609 do (when (%event-matches-gesture event
610 type
611 device-name
612 modifier-state)
613 (return-from event-matches-gesture-name-p t))
614 finally (return nil))))
615
616 (defun modifier-state-matches-gesture-name-p (modifier-state gesture-name)
536ebe3 clean up a bunch of ACL compiler warnings
Mike McDonald authored
617 (loop for (nil nil gesture-state) in (gethash gesture-name
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
618 *gesture-names*)
cd91ff5 Make a global choice, based on multiprocessing or not, whether events
Timothy Moore authored
619 do (when (eql gesture-state modifier-state)
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
620 (return-from modifier-state-matches-gesture-name-p t))
621 finally (return nil)))
622
623
624 (defun make-modifier-state (&rest modifiers)
625 (loop for result = 0 then (logior (case modifier
626 (:shift +shift-key+)
627 (:control +control-key+)
628 (:meta +meta-key+)
629 (:super +super-key+)
630 (:hyper +hyper-key+)
44db449 Fixed up a couple erroneous calls to ERROR. (~S missing argument)
Andy Hefner authored
631 (t (error "~S is not a known modifier" modifier)))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
632 result)
633 for modifier in modifiers
634 finally (return result)))
635
636 ;;; Standard gesture names
637
638 (define-gesture-name :abort :keyboard (#\c :control))
639 (define-gesture-name :clear-input :keyboard (#\u :control))
640 (define-gesture-name :complete :keyboard (:tab))
641 (define-gesture-name :help :keyboard (#\/ :control))
e0c0898 Uncommented menu-choose.lisp from the system definition. I'm using it
Timothy Moore authored
642 (define-gesture-name :possibilities :keyboard (#\? :control))
a6b9207 Implement extended input streams, stub of input editing streams and e…
Timothy Moore authored
643
644 (define-gesture-name :select :pointer-button-press (:left))
645 (define-gesture-name :describe :pointer-button-press (:middle))
646 (define-gesture-name :menu :pointer-button-press (:right))
647 (define-gesture-name :edit :pointer-button-press (:left :meta))
648 (define-gesture-name :delete :pointer-button-press (:middle :shift))
649
650 ;;; Define so we have a gesture for #\newline that we can use in
651 ;;; *standard-activation-gestures*
652
2b1b331 added support for :return as an activation gesture, renamed newline t…
Mike McDonald authored
653 (define-gesture-name :newline :keyboard (#\newline))
654 (define-gesture-name :return :keyboard (#\return))
65f361f Several changes on the road to real input editing. Make
Timothy Moore authored
655
f8e674e Major new functionality: command processing with completion. Check
Timothy Moore authored
656 ;;; The standard delimiter
657
658 (define-gesture-name command-delimiter :keyboard (#\space))
659
65f361f Several changes on the road to real input editing. Make
Timothy Moore authored
660 ;;; Extension: support for handling abort gestures that appears to be
661 ;;; in real CLIM
662
663 ;;; From the hyperspec, more or less
664
665 (defun invoke-condition-restart (c)
666 (let ((restarts (compute-restarts c)))
667 (loop for i from 0
668 for restart in restarts
669 do (format t "~&~D: ~A~%" i restart))
670 (loop with n = nil
671 and k = (length restarts)
672 until (and (integerp n) (>= n 0) (< n k))
673 do (progn
674 (format t "~&Option: ")
675 (setq n (read))
676 (fresh-line))
677 finally
678 #-cmu (invoke-restart (nth n restarts))
679 #+cmu (funcall (conditions::restart-function (nth n restarts))))))
680
681 (defmacro catch-abort-gestures (format-args &body body)
682 `(restart-case
683 (handler-bind ((abort-gesture #'invoke-condition-restart))
684 ,@body)
685 (nil ()
686 :report (lambda (s) (format s ,@format-args))
687 :test (lambda (c) (typep c 'abort-gesture))
e0c0898 Uncommented menu-choose.lisp from the system definition. I'm using it
Timothy Moore authored
688 nil)))
689
690 ;;; 22.4 The Pointer Protocol
691 ;;;
692 ;;; Implemented by the back end. Sort of.
693
e66399d Rearrange pointer class hierarchy a little, according to mail message
Christophe Rhodes authored
694 ;;; FIXME: I think the standard-pointer should absorb some of the
695 ;;; common methods that are currently entirely provided by the
696 ;;; backends.
697
698 (defclass standard-pointer (pointer)
7b420eb Fixed destination highlighting for drag-and-drop translators. Added d…
Timothy Moore authored
699 ((port :reader port :initarg :port)
700 (state-lock :reader state-lock :initform (make-lock "pointer lock"))
701 (button-state :initform 0 )
702 (modifier-state :initform 0)))
e66399d Rearrange pointer class hierarchy a little, according to mail message
Christophe Rhodes authored
703
e0c0898 Uncommented menu-choose.lisp from the system definition. I'm using it
Timothy Moore authored
704 (defgeneric pointer-sheet (pointer))
705
706 (defmethod pointer-sheet ((pointer pointer))
707 (port-pointer-sheet (port pointer)))
708
709 (defgeneric (setf pointer-sheet) (sheet pointer))
710
711 (defgeneric pointer-button-state (pointer))
712
713 (defgeneric pointer-modifier-state (pointer))
714
715 (defgeneric pointer-position (pointer))
716
717 (defgeneric* (setf pointer-position) (x y pointer))
718
14d76c2 Changes to turn off, and then turn on again, presentation highlighting
Timothy Moore authored
719 (defgeneric synthesize-pointer-motion-event (pointer)
720 (:documentation "Create a CLIM pointer motion event based on the
721 current pointer state."))
722
e0c0898 Uncommented menu-choose.lisp from the system definition. I'm using it
Timothy Moore authored
723 (defgeneric pointer-cursor (pointer))
724
725 (defgeneric (setf pointer-cursor) (cursor pointer))
726
727 ;;; Should this go in sheets.lisp? That comes before events and ports...
728
729 (defmethod handle-event :before ((sheet mirrored-sheet-mixin)
730 (event pointer-enter-event))
731 (setf (port-pointer-sheet (port sheet)) sheet))
732
733 (defmethod handle-event :before ((sheet mirrored-sheet-mixin)
734 (event pointer-exit-event))
735 (with-accessors ((port-pointer-sheet port-pointer-sheet))
736 (port sheet)
737 (when (eq port-pointer-sheet sheet)
7b420eb Fixed destination highlighting for drag-and-drop translators. Added d…
Timothy Moore authored
738
e0c0898 Uncommented menu-choose.lisp from the system definition. I'm using it
Timothy Moore authored
739 (setq port-pointer-sheet nil))))
61895ee Added and enabled pointer motion hints for stream panes. This seems
Timothy Moore authored
740
7b420eb Fixed destination highlighting for drag-and-drop translators. Added d…
Timothy Moore authored
741 (defmethod pointer-button-state ((pointer standard-pointer))
742 (with-lock-held ((state-lock pointer))
743 (slot-value pointer 'button-state)))
744
745 (defmethod pointer-modifier-state ((pointer standard-pointer))
746 (with-lock-held ((state-lock pointer))
747 (slot-value pointer 'modifier-state)))
748
749 (defmethod pointer-update-state
750 ((pointer standard-pointer) (event keyboard-event))
751 (with-lock-held ((state-lock pointer))
752 (setf (slot-value pointer 'modifier-state) (event-modifier-state event))))
753
754 (defmethod pointer-update-state
755 ((pointer standard-pointer) (event pointer-button-press-event))
756 (with-lock-held ((state-lock pointer))
757 (setf (slot-value pointer 'button-state)
758 (logior (slot-value pointer 'button-state)
759 (pointer-event-button event)))))
760
761 (defmethod pointer-update-state
762 ((pointer standard-pointer) (event pointer-button-release-event))
763 (with-lock-held ((state-lock pointer))
764 (setf (slot-value pointer 'button-state)
765 (logandc2 (slot-value pointer 'button-state)
766 (pointer-event-button event)))))
767
61895ee Added and enabled pointer motion hints for stream panes. This seems
Timothy Moore authored
768 (defmethod stream-pointer-position ((stream standard-extended-input-stream)
769 &key (pointer
770 (port-pointer (port stream))))
771 (multiple-value-bind (x y)
772 (pointer-position pointer)
773 (let ((pointer-sheet (port-pointer-sheet (port stream))))
774 (if (eq stream pointer-sheet)
775 (values x y)
776 ;; Is this right?
777 (multiple-value-bind (native-x native-y)
778 (transform-position (sheet-native-transformation stream) x y)
779 (untransform-position (sheet-native-transformation pointer-sheet)
780 native-x
781 native-y))))))
Something went wrong with that request. Please try again.