/[mcclim]/mcclim/pointer-tracking.lisp
ViewVC logotype

Contents of /mcclim/pointer-tracking.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Fri Nov 28 23:28:45 2003 UTC (10 years, 4 months ago) by hefner1
Branch: MAIN
Changes since 1.7: +63 -57 lines
Implement :multiple-window option to tracking-pointer. Added a new backend
protocol to support this, through functions PORT-GRAB-POINTER and
PORT-UNGRAB-POINTER.

Using this, ensure that MENU-CHOOSE grabs the pointer and clicking anywhere
outside the menu will dismiss it (which previously only worked somewhat,
due to the lack of pointer grabbing).

Note the slight limitation that the CLX backend does not always accurately
report the window which the pointer is over during a grab.

Imported some symbols into CLIM-CLX package.

Changed the Help command to present available commands using the item
formatter.
1 ;;; -*- Mode: Lisp; Package: CLIM-INTERNALS -*-
2
3 ;;; (c) copyright 2002 by Alexey Dejneka (adejneka@comail.ru)
4
5 ;;; This library is free software; you can redistribute it and/or
6 ;;; modify it under the terms of the GNU Library General Public
7 ;;; License as published by the Free Software Foundation; either
8 ;;; version 2 of the License, or (at your option) any later version.
9 ;;;
10 ;;; This library is distributed in the hope that it will be useful,
11 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
12 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
13 ;;; Library General Public License for more details.
14 ;;;
15 ;;; You should have received a copy of the GNU Library General Public
16 ;;; License along with this library; if not, write to the
17 ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
18 ;;; Boston, MA 02111-1307 USA.
19
20 ;;; TODO:
21 ;;;
22 ;;; - Keyboard gestures.
23 ;;;
24 ;;; - Optimization
25 ;;;
26 ;;; - - too many repeated checks within a loop;
27 ;;;
28 ;;; - - remove invoke-tracking-pointer; remove unnecessary checks.
29
30 (in-package :clim-internals)
31
32 ;;; The Spec specifies the tracking-pointer clause arguments as, e.g.,
33 ;;; (&key presentation event x y), implying that the user must write
34 ;;; the &key keyword, but real code doesn't do that. Check if &key is in
35 ;;; the arg list and add it if it is not.
36 (eval-when (:compile-toplevel :load-toplevel :execute)
37 (defun fix-tracking-pointer-args (args)
38 (unless (member '&allow-other-keys args)
39 (setq args (append args '(&allow-other-keys))))
40 (if (eq (car args) '&key)
41 args
42 (cons '&key args))))
43
44
45 (defmacro tracking-pointer
46 ((sheet &rest args
47 &key pointer multiple-window transformp context-type
48 (highlight nil highlight-p))
49 &body body)
50 (declare (ignorable pointer transformp context-type highlight))
51 (when (eq sheet 't)
52 (setq sheet '*standard-output*))
53 (check-type sheet symbol)
54 (loop
55 with motion-events = (assoc :pointer-motion body)
56 for event-name in '(:pointer-motion
57 :presentation
58 :pointer-button-press
59 :presentation-button-press
60 :pointer-button-release
61 :presentation-button-release
62 :keyboard)
63 for (handler-args . handler-body) = (cdr (assoc event-name body))
64 for handler-name = (if handler-body
65 (gensym (symbol-name event-name))
66 nil)
67 when handler-body collect `(,handler-name ,(fix-tracking-pointer-args
68 handler-args)
69 ,@handler-body) into bindings
70 and collect `#',handler-name into handler-names
71 collect (if handler-name `#',handler-name nil) into handlers
72 finally
73 (return `(flet ,bindings
74 (declare (dynamic-extent ,@handler-names))
75 ,(if motion-events
76 `(letf (((sheet-motion-hints ,sheet) nil))
77 (invoke-tracking-pointer ,sheet ,@handlers ,@args))
78 `(invoke-tracking-pointer ,sheet ,@handlers ,@args))))))
79
80
81 (defun invoke-tracking-pointer
82 (sheet
83 pointer-motion-handler presentation-handler
84 pointer-button-press-handler presentation-button-press-handler
85 pointer-button-release-handler presentation-button-release-handler
86 keyboard-handler
87 &key pointer multiple-window transformp (context-type t)
88 (highlight nil highlight-p))
89 ;; (setq pointer (port-pointer (port sheet))) ; FIXME
90 (let ((port (port sheet))
91 (presentations-p (or presentation-handler
92 presentation-button-press-handler
93 presentation-button-release-handler)))
94 (unless highlight-p (setq highlight presentations-p))
95 (with-sheet-medium (medium sheet)
96 (unwind-protect
97 (with-method (distribute-event :around ((port (eql port)) event)
98 ;; XXX specialize on EVENT?
99 ;; :SUPER-AROUND?
100 (queue-event sheet event))
101 (when multiple-window
102 (port-grab-pointer (port medium) (or pointer (port-pointer port)) sheet))
103 (with-input-context (context-type :override t) ()
104 (loop
105 (let ((event (event-read sheet)))
106 (when (and (eq sheet (event-sheet event))
107 (typep event 'pointer-motion-event))
108 (queue-event sheet event)
109 (highlight-applicable-presentation (pane-frame sheet) sheet *input-context*))
110 (cond ((and (typep event 'pointer-event)
111 #+nil
112 (eq (pointer-event-pointer event)
113 pointer))
114 (let* ((x (pointer-event-x event))
115 (y (pointer-event-y event))
116 (window (event-sheet event))
117 (presentation (and presentations-p
118 (find-innermost-applicable-presentation
119 *input-context*
120 sheet ; XXX
121 x y
122 :modifier-state (event-modifier-state event)))))
123 (when (and highlight presentation)
124 (frame-highlight-at-position (pane-frame sheet) window x y))
125 ;; FIXME Convert X,Y to SHEET coordinates; user
126 ;; coordinates
127 (typecase event
128 (pointer-motion-event
129 (if (and presentation presentation-handler)
130 (funcall presentation-handler
131 :presentation presentation
132 :window window :x x :y y)
133 (maybe-funcall pointer-motion-handler
134 :window window :x x :y y)))
135 (pointer-button-press-event
136 (if (and presentation presentation-button-press-handler)
137 (funcall presentation-button-press-handler
138 :presentation presentation
139 :event event :x x :y y)
140 (maybe-funcall pointer-button-press-handler
141 :event event :x x :y y)))
142 (pointer-button-release-event
143 (if (and presentation presentation-button-release-handler)
144 (funcall presentation-button-release-handler
145 :presentation presentation
146 :event event :x x :y y)
147 (maybe-funcall pointer-button-release-handler
148 :event event :x x :y y))))))
149 ((typep event '(or keyboard-event character symbol))
150 (maybe-funcall keyboard-handler
151 :gesture event #|XXX|#))
152 (t (handle-event #|XXX|# (event-sheet event) event)))))))
153 ;; Cleanup
154 (when multiple-window
155 (port-ungrab-pointer (port medium) (or pointer (port-pointer port)) sheet))))))
156

  ViewVC Help
Powered by ViewVC 1.1.5