-
Notifications
You must be signed in to change notification settings - Fork 2
/
events.lisp
1596 lines (1465 loc) · 61.9 KB
/
events.lisp
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
;;; -*- Mode:Lisp; Package:CLUEI; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-
;;;
;;; texas instruments incorporated
;;; p.o. box 149149
;;; austin, texas 78714-9149
;;;
;;; copyright (c)1987,1988,1989,1990 texas instruments incorporated.
;;;
;;; permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; texas instruments incorporated provides this software "as is" without
;;; express or implied warranty.
;;;
;;; to do:
;;;
;;; 1. hooks are in place to handle button mult-click and hold using 3 extra modifier state bits
;;; (:hold :click :double), but the interface isn't there yet.
;;;
;;; 2. add translation from symbolic mouse button names to actual mouse button/modifier specs.
;;; use the keysym translation facilities (define 5 keysyms for each of the mouse keys,
;;; and use define-keysym)
(in-package :cluei)
;; dynamically bound when making certain function calls for reasons
;; that are not yet completely clier to me.
(defvar $event$)
;; input processing
;;
;; rather than pass around event parameters in long plists,
;; parameters are stuffed into this structure. for any one event,
;; most slots are undefined, and these are initialized to nil.
;; event structures are kept on a resource and re-used.
;; the only reason event is a class and not a structure is because
;; we want to use with-slots.
(defclass event ()
((key)
;; display event was reported to
(display)
;; contact the event is directed to
(contact)
;; character from code and state
(character)
;; keysym from code and state
(keysym)
;; place for extension data
(xlib::plist :initform nil :type list)
;; the following are from the clx event
(above-sibling) ; used by :configure-notify :configure-request
(atom) ; used by :property-notify
(border-width) ; used by :create-notify :configure-notify :configure-request
(child) ; used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify
(code) ; used by :key-press :key-release :button-press :button-release
(colormap) ; used by :colormap-notify
(sequence) ; used by all except :keymap-notify
(configure-p) ; used by :unmap-notify
(count) ; used by :exposure :graphics-exposure :mapping-notify
(data) ; used by :client-message :timer
(drawable) ; used by :graphics-exposure :no-exposure
(event-window) ; used by :destroy-notify :unmap-notify :map-notify :reparent-notify
; :configure-notify :gravity-notify :circulate-notify
(focus-p) ; used by :enter-notify :leave-notify
(format) ; used by :client-message
(height) ; used by :exposure :graphics-exposure :create-notify :configure-notify
; :configure-request :resize-request
(hint-p) ; used by :motion-notify
(installed-p) ; used by :colormap-notify
(keymap) ; used by :keymap-notify
(kind) ; used by :enter-notify :leave-notify :focus-in :focus-out
(major) ; used by :graphics-exposure :no-exposure
(minor) ; used by :graphics-exposure :no-exposure
(mode) ; used by :enter-notify :leave-notify :focus-in :focus-out
(name) ; used by :timer
(new-p) ; used by :colormap-notify
(override-redirect-p) ; used by :create-notify :map-notify
; :reparent-notify :configure-notify
(parent) ; used by :create-notify :map-request :reparent-notify :configure-request
; :circulate-notify :circulate-request
(place) ; used by :circulate-notify :circulate-request
(property) ; used by :selection-request :selection-notify
(requestor) ; used by :selection-request
(root) ; used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify
(root-x) ; used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify
(root-y) ; used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify
(same-screen-p) ; used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify
(selection) ; used by :selection-clear :selection-request :selection-notify
(send-event-p) ; used by -all events-
(state) ; used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify
; :visibility-notify :property-notify
(target) ; used by :selection-request :selection-notify
(time) ; used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify :property-notify
; :selection-clear :selection-request :selection-notify
(type) ; used by :client-message
(width) ; used by :exposure :graphics-exposure :create-notify :configure-notify
; :configure-request :resize-request
(window) ; used by all events except :graphics-exposure :no-exposure :mapping-notify
(x) ; used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify :exposure
; :graphics-exposure :create-notify :reparent-notify
; :configure-notify :configure-request :gravity-notify
(y) ; used by :key-press :key-release :button-press :button-release
; :motion-notify :enter-notify :leave-notify :exposure
; :graphics-exposure :create-notify :reparent-notify
; :configure-notify :configure-request :gravity-notify
)
(:documentation "clue event structure, one slot for every event value. no methods."))
(defmethod print-object ((instance event) stream)
(progn
(write-string "#<event " stream)
(with-slots (key contact) instance
(princ key stream)
(when (typep contact 'contact)
(write-string " for " stream)
(princ (contact-name contact) stream)))
(write-char #\> stream)))
;;; process-next-event copies event data into an event structure. after the
;;; event is processed, its put back into *event-cache* to be re-used on the
;;; next event. this is done to reduce consing. care is taken to shield the
;;; application progammer from the actual event structure to prevent saving the
;;; event structure in application data structures. if an application did this,
;;; the event would be destructively modified on subsequent events.
(defvar *event-cache* nil)
(defun allocate-event ()
;; get an event structure, initializing all slots to nil
(let ((event (or (pop *event-cache*)
(make-instance 'event))))
(with-slots (key xlib:display contact character keysym plist code state time event-window
root drawable window child parent root-x root-y x y
width height border-width override-redirect-p same-screen-p
configure-p hint-p kind mode keymap focus-p count major minor
above-sibling place atom selection requestor target property
colormap new-p installed-p format type data name send-event-p
)
event
(setf key nil
xlib:display nil ; display event was reported to
contact nil ; contact the event is directed to
character nil ; character from code and state
keysym nil ; keysym from code and state
;; the following are from the clx event
code nil
state nil
time nil
event-window nil
root nil
drawable nil
window nil
child nil
parent nil
root-x nil
root-y nil
x nil
y nil
width nil
height nil
border-width nil
override-redirect-p nil
same-screen-p nil
configure-p nil
hint-p nil
kind nil
mode nil
keymap nil
focus-p nil
count nil
major nil
minor nil
above-sibling nil
place nil
atom nil
selection nil
requestor nil
target nil
property nil
colormap nil
new-p nil
installed-p nil
format nil
type nil
data nil
send-event-p nil
name nil
xlib::plist nil
))
event))
(defun deallocate-event (event)
;; return an event to the cache, where it can be re-used.
(push event *event-cache*))
;;-----------------------------------------------------------------------------
;; modes
;;; applications may find it necessary to establish a special input
;;; "mode" in which the user is temporarily required to direct input
;;; to one or more specific contacts. in such a mode, user input
;;; events directed to other contacts are not handled normally, but
;;; instead are either ignored or acknowledged with some kind of
;;; warning.
(deftype mode-type () '(member :non-exclusive :exclusive :spring-loaded))
(defparameter *remap-events* '(:key-press :key-release :button-press :button-release)
"these events are sent to the most recent :spring-loaded contact on the mode-stack.")
(defparameter *restrict-events*
'(:motion-notify :enter-notify :leave-notify)
"these 'user' events are sent to the restrict-action of the first
:exclusive contact on the mode-stack")
(defparameter *sensitive-events*
'(:key-press :key-release :button-press :button-release
:motion-notify :enter-notify :leave-notify
:focus-in)
"these 'user' events are ignored by an insensitive contact.")
;; other events (not in *remap-events* or *restrict-events*) are handled normally
;;; when dispatching *restrict-events*, if the mode-stack is non-nil,
;;; the event is restricted as follows. for each entry of the
;;; mode-stack, if the event is for the contact on the stack, or one of
;;; its descendents, it is dispatched. when a stack-entry with
;;; :exclusive or :spring-loaded mode-type is encountered, the search
;;; stops, and the event is sent to the restrict-action action of the
;;; mode contact with args. if there are no :exclusive or
;;; :spring-loaded contacts on the stack, the event is dispatched
;;; normally.
;;;
;;; when dispatching *remap-events*, if the mode-stack is non-nil, the
;;; event is sent (re-mapped) to the first :spring-loaded contact on the
;;; mode-stack. if there is no :spring-loaded contact, *remap-events*
;;; are handled like *restrict-events*
(defun add-mode (contact &optional (mode-type :non-exclusive) (action 'restrict) &rest args)
"push contact with (mode-type action . args) onto the mode-stack"
(declare (type contact contact)
(type mode-type mode-type)
(type symbol action)
(type list args))
(when (and (not (eq mode-type :non-exclusive))
(not (sensitive-p contact)))
(error "add-mode on insensitive contact ~s" contact))
(push (list* contact mode-type action (copy-list args))
(display-mode-stack (contact-display contact))))
(defun delete-mode (contact)
"pop contact (and everything above contact) off the mode-stack
returns t when found and removed, else nil"
(declare (type contact contact)
(values boolean))
(let* ((display (contact-display contact))
(mode-stack (display-mode-stack display)))
(when mode-stack
(do ((stack mode-stack (cdr stack)))
((endp stack)
;; if contact not found, check its children
;; this feature utilized when un-mapping the parent of a modal contact
(do ((stack mode-stack (cdr stack))
(found-p nil)
(result nil))
((endp stack)
(when found-p
(setf (display-mode-stack display) result)
t))
(when (ancestor-p contact (caar stack))
(setq found-p t
result stack))))
(when (eq contact (caar stack))
(setf (display-mode-stack display) (cdr stack))
(return t))))))
(defmacro with-mode ((contact &key (mode-type :exclusive)
(action 'ignore-action) args)
body-form &body cleanup-forms)
"while executing body-form, user events will only be delivered to contact
and its children. non-user events (e.g. exposure,property-notify, etc)
will be delivered normally. user events to other contacts will cause
the action action for contact's class to be invoked with args. the
primary contact method for the default action, ignore-action, beeps on
*remap-events*, and ignores all others.
with-mode executes body-form within an unwind-protect. with-mode
returns the value of its body-form, and executes cleanup-forms before
exiting. "
(let ((local-contact (gensym)))
`(let ((,local-contact ,contact))
(unwind-protect
(progn
(add-mode ,local-contact ,mode-type (function ,action) ,@args)
,body-form)
(delete-mode ,local-contact)
,@cleanup-forms))))
(defun contact-mode (contact)
"if contact is the descendent of a modal contact, return the modal contact, else nil."
(let ((modes (display-mode-stack (contact-display contact))))
(if modes ;; no mode stack means everything is in "on the stack"
(do ((p contact (contact-parent p)))
((null p) nil)
(dolist (mode modes)
(cond ((eq p (car mode))
(return-from contact-mode p))
((eq (cadr mode) :exclusive)
(return nil))))))))
(defun contact-super-mode (contact)
"if contact is the descendent of a modal contact, return the superior modal contact, else nil."
(let ((modes (cluei::display-mode-stack (contact-display contact))))
(if modes ;; no mode stack means everything is in "on the stack"
(do ((p contact (contact-parent p)))
((null p) nil)
(do ((mode modes (cdr mode))
(supermode nil))
((endp mode))
(when (eq p (caar mode))
(return-from contact-super-mode supermode))
(unless (eq (cadar mode) :non-exclusive)
(setq supermode (caar mode))))))))
(defmacro with-event-mode ((contact &rest translations) &body body)
"The given event translations are defined for the contact only
within the dynamic extent of the body. the translations are
processed before any other previously-defined instance or class
translations for contact."
(let ((previous-translations (gensym))
(new-translations (gensym))
(translation (gensym))
(previous (gensym))
(slot (gensym)))
`(let* ((,new-translations (list ,@translations))
(,slot (slot-value ,contact 'event-translations))
(,previous-translations
;; save any actions from previous instance translations for these event specs
(let (,previous-translations)
(dolist (,translation ,new-translations (nreverse ,previous-translations))
(when (assoc (first (parse-event-translation (first ,translation) (rest ,translation)))
,slot
:test #'equal)
(push ,translation ,previous-translations))))))
(unwind-protect
(progn
;; add modal translations
(dolist (,translation ,new-translations)
(apply #'add-event ,contact ,translation))
,@body)
;; delete modal translations and restore any previous ones
(dolist (,translation ,new-translations)
(let ((,previous (pop ,previous-translations)))
(if ,previous
(apply #'add-event ,contact ,previous)
(delete-event ,contact (first ,translation)))))))))
;;; :ctions
;; Retained temporarily for compatibility purposes
(defmacro defaction (name lambda-list &body body)
"define an action method. this macro is now obsolete. just use defmethod."
(let (qualifier self)
;; handle method qualifiers (:before or :after)
(when (atom lambda-list)
(setq qualifier (list lambda-list)
lambda-list (pop body)))
;; get the first specialized parameter in the lambda-list
(dolist (arg lambda-list)
(when (member arg lambda-list-keywords) (return nil))
(when (consp arg)
(setf self (first arg))))
`(progn
(compiler-let (($contact$ ',self)) ; hook for call-action
(defmethod ,name ,@qualifier ,lambda-list
,@body)))))
(defmacro using-event (&body body)
`(locally
(declare (special $event$))
,@body))
(defmacro processing-event-p ()
`(using-event (boundp '$event$)))
(defmacro with-event (slots &body body)
"used within an action method to access event slots."
`(using-event
(assert
(boundp '$event$) nil
"with-event used outside the dynamic extent of process-next-event.")
(with-slots ,slots $event$ ,@body)))
(defmacro call-action (action &rest args)
"used within defaction to call another action. this macro is now obsolete. replace
with a direct reference to the action function."
(declare (special $contact$))
(unless (boundp '$contact$)
(error "call-action used outside defaction."))
`(,action ,$contact$ ,@args))
(defun call-action-internal (contact action)
(if (consp action)
(apply (car action) contact (cdr action))
(funcall action contact)))
(defun add-before-action (display class action-name &rest args)
"call the action named action-name with arguments before every event
on display directed to a contact whose class is the same as
or superclass of the action class."
(setf (before-actions display)
(cons
(list* class action-name (copy-list args))
(delete-if #'(lambda (entry)
(and (eq class (first entry))
(eq action-name (second entry))))
(before-actions display)
:count 1)))
action-name)
(defun delete-before-action (display class action-name)
"remove a before event-handler from display"
(setf (before-actions display)
(delete-if #'(lambda (entry)
(and (eq class (first entry))
(eq action-name (second entry))))
(before-actions display)
:count 1))
action-name)
;;; built-in actions
(defmethod perform-callback ((contact basic-contact) name &rest args)
;; warning: duplicates apply-callback code, instead of (eval
;; (apply-callback...))
(let ((functions (callback-p contact name)))
(when functions
;; cons alert!!
(let ((args (copy-list args)))
(catch
;; abort-callback
(do* ((functions functions (rest functions))
(function (first functions) (first functions)))
((null (rest functions))
;; return value(s) of last callback function
(apply (first function) (nconc args (rest function))))
(setf args (nconc args (rest function)))
(apply (first function) args)
(setf args (nbutlast args (length (rest function))))))))))
(defmethod apply-action ((contact basic-contact) function &rest args)
(let ((*contact* contact))
(declare (special *contact*))
(apply function args)))
(defmethod eval-action ((contact basic-contact) &rest forms)
(let ((*contact* contact))
(declare (special *contact*))
(dolist (form forms)
(eval form))))
(defmethod trace-action ((event-contact basic-contact) &rest exceptions)
(let (value result
(name (contact-name event-contact)))
(with-event ((event-key key))
(unless (member event-key exceptions :test #'eq)
(format *trace-output* "~%~s on ~a:"
event-key name)
(dolist (slot-name '(above-sibling atom border-width character child code colormap configure-p
count drawable event-window focus-p format height hint-p installed-p keymap
keysym kind major minor mode name new-p override-redirect-p parent place
plist property requestor selection send-event-p state target type width
window x y))
(when (and (setf value (slot-value $event$ slot-name))
(not (eq value event-contact)))
(when (typep value 'contact) (setf value (contact-name value)))
(setf result (nconc result (list slot-name value)))))
(format *trace-output* "~{~<~%~20@t~1:; ~s ~s~>~^ ~}." result)))))
(defmethod describe-action ((event-contact basic-contact) &rest exceptions)
(with-event ((event-key key))
(unless (member event-key exceptions :test #'eq)
(format *trace-output* "~%~s on ~a:"
event-key (contact-name event-contact))
;; loop over slots in alphabetical order
(dolist (slot-name '(above-sibling atom border-width character child code colormap configure-p
count drawable event-window focus-p format height hint-p installed-p keymap keysym
kind major minor mode name new-p override-redirect-p parent place plist
property requestor selection send-event-p state target type width window x y))
(let ((value (slot-value $event$ slot-name)))
(when value
(when (typep value 'contact) (setf value (contact-name value)))
(format *trace-output* "~%~5t~20s~20s" slot-name value))))
(terpri *trace-output*))))
(defmethod ignore-action ((contact basic-contact))
;; beep on *remap-events* else ignore
(with-event (key display)
(when (member key *remap-events* :test #'eq)
(bell display))))
(defmethod throw-action ((contact basic-contact) tag &optional value)
(throw tag value))
;; Event Translations
(defmacro defevent (class event-spec &rest actions)
"Add an event binding to the event-translations property of class,
where it can be shared by all instances of class."
(let ((event-parse (parse-event-translation event-spec actions))
(canonical-event-spec (gensym)))
`(progn
;; generate compiler warnings for missing actions
;; Old TI code
;; ,@(mapcar #'(lambda (action)
;; (when (consp action) (setq action (first action)))
;; `(eval-when (compile)
;; (compiler:function-referenced
;; ',action ',(intern (format nil "defevent ~s ~s" class event-spec)))))
;; (rest event-parse))
(let ((,canonical-event-spec ',(first event-parse)))
(setf
;; Update class event translations
(class-name-event-translations ',class)
(cons
(cons ,canonical-event-spec ',(rest event-parse))
(delete ,canonical-event-spec
(class-name-event-translations ',class)
:key #'first :test #'equal :count 1))
;; Flush cached class event mask, event precedence list
(class-name-event-mask ',class)
nil
(class-name-event-precedence-list ',class)
nil)))))
(defmacro undefevent (class event-spec &rest actions)
"remove an event binding from the event-translations property of class."
(declare (ignore actions))
`(setf
;; update class event translations
(class-name-event-translations ',class)
(delete ',(first (parse-event-translation event-spec nil))
(class-name-event-translations ',class)
:key #'first :count 1 :test #'equal)
;; flush cached class event mask, event precedence list
(class-name-event-mask ',class)
nil
(class-name-event-precedence-list ',class)
nil))
(defmethod event-actions ((contact basic-contact) event-spec)
"return the list of actions for event-spec."
;; check instance translations
(let ((event-binding (car (parse-event-translation event-spec nil))))
(cdr
(or
;; instance translation?
(assoc event-binding
(slot-value contact 'event-translations)
:test #'equal)
;; class translation?
(dolist (class (class-name-event-precedence-list (class-name-of contact)))
(let ((actions (assoc event-binding
(class-name-event-translations class)
:test #'equal)))
(when actions
(return actions))))))))
(defmethod add-event ((contact basic-contact) event-spec &rest actions)
"add event-spec and actions to the event translations for contact."
;; compute canonical event translation.
(let ((translation (parse-event-translation event-spec (copy-list actions))))
(with-slots (event-mask event-translations) contact
;; translation for this event spec already exists?
(let ((previous (assoc (first translation) event-translations :test #'equal)))
(if previous
;; yes, modify it with the new actions.
(setf (rest previous) (rest translation))
;; no, add new translation.
(push translation event-translations)))
;; update window event mask, if necessary
(when (realized-p contact)
(let ((new-mask (event-translation-mask event-mask translation)))
(unless (= new-mask event-mask)
(setf (window-event-mask contact) (setf event-mask new-mask)))))))
(values))
(defmethod delete-event ((contact basic-contact) event-spec)
"remove any translation for event-spec from the event translations for contact."
;; compute a canonical event translation for the event spec
(let ((translation (parse-event-translation event-spec nil)))
(with-slots (event-mask event-translations) contact
;; remove any matching translation.
(setf event-translations
(delete (first translation) event-translations
:key #'first :count 1 :test #'equal))
;; update window event mask, if necessary
(when (realized-p contact)
(let ((old-bit (event-translation-mask 0 translation)))
;; don't change event mask if some other translation sets this bit
(when (zerop (logand (contact-event-translations-mask contact) old-bit))
;; only modify the event-mask bit for the event being deleted
(setf (window-event-mask contact)
(setf event-mask (logandc2 event-mask old-bit))))))))
(values))
;;;-----------------------------------------------------------------------------
;;; check/match functions
(defun encode-button-number (button)
(or (position button
#(:any :button-1 :button-2 :button-3 :button-4 :button-5))
(xlib::x-type-error
button 'button
"one of :any :button-1 :button-2 :button-3 :button-4 :button-5")))
;; alist associating modifier keys with modifier keysyms
(defvar *meta-modifier-alist*
`((:meta ,(xlib:keysym :left-meta)
,(xlib:keysym :right-meta))
(:super ,(xlib:keysym :left-super)
,(xlib:keysym :right-super))
(:hyper ,(xlib:keysym :left-hyper)
,(xlib:keysym :right-hyper))))
(defconstant meta-shift 16.) ;; where to shift meta-modifier keystates
(defconstant mod-1-shift (position :mod-1 xlib::+state-mask-vector+))
(defconstant button-0-shift (1- (position :button-1 xlib::+state-mask-vector+)))
(defun get-display-modifier-translate (display &optional update-p)
;; returns a table that translates meta-modifier bits
;; into mod1/mod2/mod3/mod4/mod5 modifier state bits.
(declare (type display display))
(or (and (not update-p) (display-modifier-translate display))
(let* ((mapping (xlib::get-display-modifier-mapping display))
(mod-length (length *meta-modifier-alist*))
(translate-length (ash 1 mod-length))
(display-translate (display-modifier-translate display))
(translate (or (and (>= (length display-translate) translate-length)
display-translate)
(make-array translate-length)))
(mod-vector (make-array mod-length)))
(declare (type simple-vector translate mod-vector))
(do* ((modifiers *meta-modifier-alist* (cdr modifiers))
(i 0 (1+ i))
(temp))
((endp modifiers))
(setf (aref mod-vector i)
(dolist (modifier (cdar modifiers) 0)
(when (setq temp (assoc modifier mapping :test #'eq))
(return (cdr temp))))))
(dotimes (i translate-length)
(let ((mask 0))
(dotimes (j mod-length)
(when (logbitp j i)
(setq mask (logior mask (aref mod-vector j)))))
(setf (aref translate i) mask)))
(setf (display-modifier-translate display) translate))))
(defun translate-meta-modifiers (state translate)
;; translate the meta/super/hyper modifiers in state to mod-1/mod-2/mod3/mod4/mod5 modifiers.
;; translate is the result from get-display-modifier-translate
(logior (ldb (byte meta-shift 0) state)
(aref translate (ash state (- meta-shift)))))
(defun encode-clue-modifier-mask (modifiers)
;; make a state-mask from modifiers
(declare (type (or mask16 state-mask-key (member :meta :super :hyper) list) modifiers))
(typecase modifiers
(fixnum (ldb (byte meta-shift 0) modifiers))
(cons (let ((mask 0))
(dolist (modifier modifiers)
(setf mask (logior mask (encode-clue-modifier-mask modifier))))
mask))
(otherwise
(let ((temp (position modifiers *meta-modifier-alist* :key #'car :test #'eq)))
(if temp
(ash 1 (+ temp meta-shift))
(xlib:make-state-mask modifiers))))))
(defun event-spec-match (display state select event-state)
(let ((translate (get-display-modifier-translate display)))
(setq state (translate-meta-modifiers state translate)
select (translate-meta-modifiers select translate)))
; the modifiers common to select and state must be down and
; the modifiers in select but not state must be up
(and (= (logand state select) (logand event-state select))
; when there are modifiers in state that aren't in select
(or (zerop (logandc2 state select))
; at least one of them must be down
(plusp (logand event-state (logandc2 state select)))))
; modifiers that aren't in state or select are ignored
)
#| ;; event-spec-match implements the following relationships:
.-------------------------------.
| event-state 4 4 4 4 4 4 4 4 4|
|4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
|4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
|4 4 .-------------------. 4 4 4|
|4 4 | select 1 1 1 1 1 | 4 4 4|
|4 4 | 1 1 1 1 1 1 1 1 1 | 4 4 4|
|4 4 | 1 .-----------. 1 | 4 4 4| this would look better in color
|4 4 | 1 | 2 2 2 2 2 | 1 | 4 4 4|
|4 4 | 1 | 2 2 2 2 2 | 1 | 4 4 4|
|4 4 | 1 | 2 2 2 2 2 | 1 | 4 4 4|
|4 4 `---+-----------+---' 4 4 4|
|4 4 4 4 | 3 3 3 3 3 | 4 4 4 4 4|
|4 4 4 4 | 3 3 3 3 3 | 4 4 4 4 4|
|4 4 4 4 | state 3 3 | 4 4 4 4 4|
|4 4 4 4 `-----------' 4 4 4 4 4|
|4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
|4 4 4 4 4 4 4 4 4 4 4 4 4 4 4 4|
`-------------------------------'
1. modifiers in select but not state ; must be up in the event
2. modifiers both in state and select ; must be down in the event
3. modifiers in state but not select ; if any, at least one must be down
4. modifiers in neither select or state ; are ignored
|#
(defun key-check (event-key &optional char state select)
;; returns the canonical form of the key (i.e. one that may speed up
;; the matching operation)
(declare (ignore event-key))
(unless (typep char '(or xlib:card16 character (member :any)))
(error "~a is not a character, xlib:card16 or :any." char))
(let*
((modifiers
(cond ((or (null state) (eq state :none)) 0)
((numberp state) state)
((eq state :any) (setf select 0))
(t (encode-clue-modifier-mask state))))
(mask
(cond ((null select) (if (characterp char) 0 modifiers))
((numberp select) select)
((eq select :same) modifiers)
((eq select :all) #xffff)
(t (encode-clue-modifier-mask select)))))
(list 'key-match char modifiers mask)))
(defun key-match (event spec-code spec-state spec-select)
;; returns t if event-spec matches event
(with-slots (xlib:display character state keysym) event
(and (event-spec-match xlib:display spec-state spec-select state)
(cond
((characterp spec-code) (eql spec-code character))
((eq spec-code :any) t)
(t (eql spec-code keysym))))))
(defun button-check (event-key &optional code state select)
(let*
((click-option
(when (consp state)
;; process state list for click type keys
(let* ((single (find :single-click state :test #'eq))
(double (find :double-click state :test #'eq))
(click (or single double)))
(when click
(assert (not (and single double)) ()
"can't specify both :single-click and :double-click.")
(setf state (remove click state)))
click)))
(button
(encode-button-number (or code :any)))
(modifiers
(cond ((or (null state) (eq state :none)) 0)
((numberp state) state)
((eq state :any) (setf select 0))
((eq state :single-click) (setf click-option state) 0)
((eq state :double-click) (setf click-option state) 0)
(t (encode-clue-modifier-mask state))))
(mask
(cond ((or (null select) (eq select :same)) modifiers)
((numberp select) select)
((eq select :all) #xffff)
(t (encode-clue-modifier-mask select))))
(predicate
(if (eq event-key :button-press)
'button-press-match
'button-release-match)))
(list* predicate button modifiers mask (when click-option (list click-option)))))
(defun button-press-mask (button state select &optional option)
(declare (ignore button state select))
(if option
#.(xlib:make-event-mask :button-press :button-release)
#.(xlib:make-event-mask :button-press)))
(defun button-release-mask (button state select &optional option)
(declare (ignore button state select))
(if option
#.(xlib:make-event-mask :button-press :button-release)
#.(xlib:make-event-mask :button-release)))
(defun button-press-match (event button state select &optional option)
(with-slots ((event-code code)
(event-state state)
display key plist time x y)
event
(let* ((code event-code)
(mask (ash 1 (+ code button-0-shift))))
(and
(or (zerop button) ; zero button means "any" button
(= button code))
(event-spec-match display state select
(logandc2 event-state mask)) ; clear state bit for current button
(case option
(:single-click
(= (click-lookahead display 1 2 time (logior event-state mask) x y) 2))
(:double-click
(= (click-lookahead display 1 4 time (logior event-state mask) x y) 4))
(otherwise t))))))
(defun button-release-match (event button state select &optional option)
(with-slots ((event-code code)
(event-state state)
key display plist time x y)
event
(let* ((code event-code)
(mask (ash 1 (+ code button-0-shift))))
(and
(or (zerop button) ; zero button means "any" button
(= button code))
(event-spec-match display state select (logandc2 event-state mask)) ; clear state bit for current button
(case option
(:single-click
(= (click-lookahead display 2 2 time event-state x y) 2))
(:double-click
(= (click-lookahead display 2 4 time event-state x y) 4))
(otherwise t))))))
(defconstant all-button-mask
(xlib:make-state-mask :button-1 :button-2 :button-3 :button-4 :button-5))
(defun motion-check (event-key &optional state select)
(declare (ignore event-key))
(let*
((modifiers
(cond ((or (null state) (eq state :none)) 0)
((numberp state) state)
((eq state :any) (setf select 0) all-button-mask)
(t (encode-clue-modifier-mask state))))
(mask
(cond ((or (null select) (eq select :same)) modifiers)
((numberp select) select)
((eq select :all) #xffff)
(t (encode-clue-modifier-mask select)))))
(list 'motion-match modifiers mask)))
(defun motion-match (event state select)
(with-slots (xlib:display) event
(or (eq state :any)
(event-spec-match xlib:display state select (slot-value event 'state)))))
(defun motion-event-mask (state select)
(if (= all-button-mask (logand (logior state select) all-button-mask))
#.(xlib:make-event-mask :button-motion)
(let ((mask (logand state select all-button-mask)))
(when (zerop mask)
(setq mask #.(xlib:make-event-mask :pointer-motion)))
mask)))
;;(eval-when (compile)
;; motion-event-mask makes the following assumption:
(eval-when (:compile-toplevel)
(assert (and (= (xlib:make-event-mask :button-1-motion) (xlib:make-state-mask :button-1))
(= (xlib:make-event-mask :button-2-motion) (xlib:make-state-mask :button-2))
(= (xlib:make-event-mask :button-3-motion) (xlib:make-state-mask :button-3))
(= (xlib:make-event-mask :button-4-motion) (xlib:make-state-mask :button-4))
(= (xlib:make-event-mask :button-5-motion) (xlib:make-state-mask :button-5)))
() "button event-mask is shifted relative to button state-mask"))
(defun enter-leave-check (event-key &rest kinds)
(dolist (kind kinds)
(unless (member kind '(:ancestor :virtual :inferior :nonlinear :nonlinear-virtual))
(error "~s isn't an enter/leave kind for ~s" kind (cons event-key kinds))))
(list 'enter-leave-match kinds))
(defun enter-leave-match (event kinds)
(member (slot-value event 'kind) kinds :test #'eq))
(setf (check-function :key-press) 'key-check)
(setf (check-function :key-release) 'key-check)
(setf (check-function :button-press) 'button-check)
(setf (check-function :button-release) 'button-check)
(setf (check-function :motion-notify) 'motion-check)
(setf (check-function :enter-notify) 'enter-leave-check)
(setf (check-function :leave-notify) 'enter-leave-check)
(defun key-up-check (event-key &rest parms)
(declare (ignore event-key))
;; convert (:up ...) to (:key-press ...)
(values (apply #'key-check :key-release parms)
:key-release))
(setf (check-function :up) #'key-up-check)
(defun client-message-check (event-key type &rest accessors)
(declare (ignore event-key))
(assert (typep type 'xlib:xatom) () "~s must be an x atom." type)
(do* ((accessors accessors (cddr accessors))
(function (first accessors) (first accessors))
(rest (rest accessors) (rest accessors)))
((null accessors))
(assert rest () "no value given for ~s accessor." function))
(values (list* 'client-message-match
(intern (string type) 'keyword)
accessors)
:client-message))
(defun client-message-match (event type &rest accessors)
(with-slots ((event-type type) (event-data data) (event-display contact-display)) event
;; bind display for use in accessor functions
(let ((*event-display* event-display))
(declare (special *event-display*))
(and (eq type event-type)
(do* ((accessors accessors (cddr accessors))
(function (first accessors) (first accessors))
(value (second accessors) (second accessors)))
((null accessors) t)
(unless (equal value (funcall function event-data))
(return nil)))))))
(setf (check-function :client-message) #'client-message-check)
(defun wm-protocol-check (event-key &rest accessors)
(apply 'client-message-check
:client-message :wm_protocols
'wm-message-protocol-atom event-key
accessors))
(setf (check-function :wm_take_focus) #'wm-protocol-check)
(setf (check-function :wm_save_yourself) #'wm-protocol-check)
(setf (check-function :wm_delete_window) #'wm-protocol-check)
(defun timer-check (event-key timer-name)
(declare (ignore event-key))
(assert (symbolp timer-name) ()
"~a is not a timer name symbol." timer-name)
(values
(list 'timer-match timer-name)
:timer))
(defun timer-match (event timer-name)
(with-slots (name) event
(eq timer-name name)))
(setf (check-function :timer) #'timer-check)
(defun property-check (event &optional property state)
(declare (ignore event))
(check-type property (or null xlib:xatom) "an xatom")
(check-type state (or null (member :new-value :deleted)) ":new-value or :deleted")
(cons
'property-match
(when property
(cons (intern (string property) :keyword)
(when state
(cons state nil))))))