|
0
|
1 ;;!emacs
|
|
|
2 ;;
|
|
|
3 ;; FILE: hmouse-key.el
|
|
|
4 ;; SUMMARY: Load "hmouse-sh.el" or "hmouse-reg.el" for Smart Key bindings.
|
|
|
5 ;; USAGE: GNU Emacs Lisp Library
|
|
|
6 ;; KEYWORDS: hypermedia, mouse
|
|
|
7 ;;
|
|
|
8 ;; AUTHOR: Bob Weiner
|
|
24
|
9 ;; ORG: InfoDock Associates
|
|
0
|
10 ;;
|
|
|
11 ;; ORIG-DATE: 30-May-94 at 00:11:57
|
|
24
|
12 ;; LAST-MOD: 21-Feb-97 at 18:03:12 by Bob Weiner
|
|
0
|
13 ;;
|
|
|
14 ;; This file is part of Hyperbole.
|
|
|
15 ;; Available for use and distribution under the same terms as GNU Emacs.
|
|
|
16 ;;
|
|
24
|
17 ;; Copyright (C) 1994-1995, 1997 Free Software Foundation, Inc.
|
|
0
|
18 ;; Developed with support from Motorola Inc.
|
|
|
19 ;;
|
|
|
20 ;; DESCRIPTION:
|
|
|
21 ;;
|
|
|
22 ;; Supports Epoch, Lucid Emacs, X, Sunview, NEXTSTEP, and Apollo DM
|
|
|
23 ;; window systems.
|
|
|
24 ;;
|
|
24
|
25 ;; `hmouse-shift-buttons' globally binds the Action and Assist Mouse Keys
|
|
0
|
26 ;; to either shifted or unshifted mouse buttons.
|
|
|
27 ;;
|
|
24
|
28 ;; `hmouse-toggle-bindings' may be bound to a key. It switches between
|
|
0
|
29 ;; the Hyperbole mouse bindings and previous mouse key bindings any time
|
|
24
|
30 ;; after `hmouse-shift-buttons' has been called.
|
|
0
|
31 ;;
|
|
|
32 ;; DESCRIP-END.
|
|
|
33
|
|
|
34 ;;; ************************************************************************
|
|
|
35 ;;; Other required Elisp libraries
|
|
|
36 ;;; ************************************************************************
|
|
|
37
|
|
|
38 (require 'hversion)
|
|
|
39 (require 'hmouse-drv)
|
|
|
40 (require 'h-skip-bytec "h-skip-bytec.lsp")
|
|
|
41
|
|
|
42 ;;; ************************************************************************
|
|
|
43 ;;; Public variables
|
|
|
44 ;;; ************************************************************************
|
|
|
45
|
|
24
|
46 (if (or hyperb:xemacs-p hyperb:emacs19-p)
|
|
|
47 ;; XEmacs and Emacs 19 pre-load their mouse libraries, so
|
|
|
48 ;; we shouldn't have to require them here.
|
|
|
49 nil
|
|
|
50 (eval (cdr (assoc hyperb:window-system
|
|
|
51 '(
|
|
|
52 ("xterm" . (require 'x-mouse)) ; X
|
|
|
53 ("epoch" . (require 'mouse)) ; UofI Epoch
|
|
|
54 ("next" . (load "eterm-fns" t)) ; NeXTstep
|
|
|
55 ("sun" . (require 'sun-fns)) ; SunView
|
|
|
56 ("apollo" . (require 'apollo)) ; Display Manager
|
|
|
57 )))))
|
|
0
|
58
|
|
|
59 ;;; ************************************************************************
|
|
|
60 ;;; Public functions
|
|
|
61 ;;; ************************************************************************
|
|
|
62
|
|
|
63 (defun hmouse-set-bindings (key-binding-list)
|
|
|
64 "Sets mouse keys used as Smart Keys to bindings in KEY-BINDING-LIST.
|
|
|
65 KEY-BINDING-LIST is the value returned by 'hmouse-get-bindings' prior to
|
|
|
66 Smart Key setup."
|
|
|
67 (cond
|
|
24
|
68 ;; Do nothing when running in batch mode.
|
|
|
69 (noninteractive)
|
|
0
|
70 ;;
|
|
|
71 ;; GNU Emacs 19, Lucid Emacs, XEmacs or InfoDock
|
|
24
|
72 ((or hyperb:xemacs-p hyperb:emacs19-p (equal hyperb:window-system "lemacs"))
|
|
0
|
73 (mapcar
|
|
|
74 (function
|
|
|
75 (lambda (key-and-binding)
|
|
|
76 (global-set-key (car key-and-binding) (cdr key-and-binding))))
|
|
|
77 key-binding-list))
|
|
|
78 ;;
|
|
|
79 ;; X
|
|
|
80 ((equal hyperb:window-system "xterm")
|
|
|
81 (mapcar
|
|
|
82 (function
|
|
|
83 (lambda (key-and-binding)
|
|
|
84 (define-key mouse-map (car key-and-binding) (cdr key-and-binding))))
|
|
|
85 key-binding-list))
|
|
|
86 ;;
|
|
|
87 ;; Epoch
|
|
|
88 ((equal hyperb:window-system "epoch")
|
|
|
89 (mapcar
|
|
|
90 (function
|
|
|
91 (lambda (key-and-binding)
|
|
|
92 (aset mouse::global-map (car key-and-binding)
|
|
|
93 (cdr key-and-binding))))
|
|
|
94 key-binding-list))
|
|
|
95 ;;
|
|
|
96 ;; SunView or NeXT
|
|
|
97 ((or (equal hyperb:window-system "next")
|
|
|
98 (equal hyperb:window-system "sun"))
|
|
|
99 (mapcar
|
|
|
100 (function
|
|
|
101 (lambda (key-and-binding)
|
|
|
102 (global-set-mouse (car key-and-binding) (cdr key-and-binding))))
|
|
|
103 key-binding-list))
|
|
|
104 ;;
|
|
|
105 ;; Apollo Display Manager
|
|
|
106 ((equal hyperb:window-system "apollo")
|
|
|
107 (if (string< emacs-version "18.58")
|
|
|
108 (mapcar
|
|
|
109 (function
|
|
|
110 (lambda (key-and-binding)
|
|
|
111 (global-set-key (car key-and-binding) (cdr key-and-binding))))
|
|
|
112 key-binding-list)
|
|
|
113 (mapcar
|
|
|
114 (function
|
|
|
115 (lambda (key-and-binding)
|
|
|
116 (define-key 'apollo-prefix (car key-and-binding)
|
|
|
117 (cdr key-and-binding))))
|
|
|
118 key-binding-list)))))
|
|
|
119
|
|
|
120 (defun hmouse-shift-buttons (&optional arg)
|
|
|
121 "Selects between shifted and unshifted Action and Assist mouse buttons.
|
|
|
122 With optional prefix ARG, use shifted buttons if ARG is positive or use
|
|
|
123 unshifted buttons otherwise. If ARG is nil, shifted buttons are used and
|
|
|
124 under InfoDock the middle button also acts as an Action Key."
|
|
|
125 (interactive "P")
|
|
|
126 (setq hmouse-shift-flag (if arg
|
|
|
127 (> (prefix-numeric-value arg) 0)
|
|
|
128 (not (and (boundp 'infodock-version)
|
|
|
129 infodock-version))))
|
|
|
130 (if hmouse-shift-flag
|
|
|
131 ;; Action Key = shift-middle mouse key. Assist Key = shift-right mouse
|
|
|
132 ;; key. Standard Hyperbole configuration.
|
|
|
133 (load "hmouse-sh")
|
|
|
134 ;; Action Key = middle mouse key; Assist Key = right mouse key
|
|
|
135 ;; InfoDock actually moves the Assist Key to the shift-right mouse key so
|
|
|
136 ;; that the right key can be used for popup menus.
|
|
|
137 (load "hmouse-reg"))
|
|
|
138 ;; Replace any original mouse bindings before moving Hyperbole bindings and
|
|
|
139 ;; then force reinitialization of hmouse-previous-bindings.
|
|
|
140 (if (and hmouse-bindings-flag hmouse-previous-bindings)
|
|
|
141 (hmouse-set-bindings hmouse-previous-bindings))
|
|
|
142 (setq hmouse-bindings-flag nil
|
|
|
143 hmouse-previous-bindings nil)
|
|
|
144 ;; Initialize Hyperbole mouse bindings.
|
|
|
145 (hmouse-setup)
|
|
|
146 (if (interactive-p)
|
|
|
147 (message "%s Action and Assist mouse buttons in use."
|
|
|
148 (if hmouse-shift-flag "Shifted" "Unshifted"))))
|
|
|
149
|
|
|
150 (defun hmouse-toggle-bindings ()
|
|
|
151 "Toggles between Smart Key mouse settings and their prior bindings."
|
|
|
152 (interactive)
|
|
|
153 (let ((key-binding-list (if hmouse-bindings-flag
|
|
|
154 hmouse-previous-bindings
|
|
|
155 hmouse-bindings))
|
|
|
156 (other-list-var (if hmouse-bindings-flag
|
|
|
157 'hmouse-bindings
|
|
|
158 'hmouse-previous-bindings)))
|
|
|
159 (if key-binding-list
|
|
|
160 (progn
|
|
|
161 (set other-list-var (hmouse-get-bindings))
|
|
|
162 (hmouse-set-bindings key-binding-list)
|
|
|
163 (message "%s mouse bindings in use."
|
|
|
164 (if (setq hmouse-bindings-flag (not hmouse-bindings-flag))
|
|
|
165 "Smart Key" "Personal")))
|
|
|
166 (error "(hmouse-toggle-bindings): Null %s." other-list-var))))
|
|
|
167
|
|
|
168 (defun hmouse-set-point-at (set-point-arg-list)
|
|
|
169 "Sets point to cursor position using SET-POINT-ARG-LIST and returns t.
|
|
|
170 If 'hmouse-set-point-command' is not bound to a function, this does nothing
|
|
|
171 and returns nil."
|
|
|
172 (if (fboundp hmouse-set-point-command)
|
|
|
173 (progn
|
|
|
174 (if (and (boundp 'drag-zone) drag-zone)
|
|
|
175 (progn (delete-zone drag-zone)
|
|
|
176 (setq drag-zone nil))
|
|
|
177 (and (boundp 'drag-button) drag-button
|
|
|
178 (progn (delete-button drag-button)
|
|
|
179 (setq drag-button nil))))
|
|
|
180 (or (if set-point-arg-list
|
|
|
181 (funcall hmouse-set-point-command set-point-arg-list)
|
|
|
182 (funcall hmouse-set-point-command))
|
|
|
183 t))))
|
|
|
184
|
|
|
185 ;;; ************************************************************************
|
|
|
186 ;;; Private functions
|
|
|
187 ;;; ************************************************************************
|
|
|
188
|
|
|
189 (if (fboundp 'bind-apollo-mouse-button)
|
|
|
190 (progn
|
|
|
191 (if (string< emacs-version "18.58")
|
|
|
192 (defun apollo-mouse-key-and-binding (mouse-button)
|
|
|
193 "Returns binding for an Apollo MOUSE-BUTTON (a string) or nil if none."
|
|
|
194 (interactive "sMouse Button: ")
|
|
|
195 (let ((numeric-code (cdr (assoc mouse-button *apollo-mouse-buttons*))))
|
|
|
196 (if (null numeric-code)
|
|
|
197 (error "(hmouse-key): %s is not a valid Apollo mouse key name."
|
|
|
198 mouse-button))
|
|
|
199 (if (stringp numeric-code)
|
|
|
200 (setq numeric-code
|
|
|
201 (cdr (assoc numeric-code *apollo-mouse-buttons*))))
|
|
|
202 (let ((key-sequence (concat "\M-*" (char-to-string numeric-code))))
|
|
|
203 (cons key-sequence (global-key-binding key-sequence)))))
|
|
|
204 (defun apollo-mouse-key-and-binding (mouse-button)
|
|
|
205 "Returns binding for an Apollo MOUSE-BUTTON (a string) or nil if none."
|
|
|
206 (interactive "sMouse Button: ")
|
|
|
207 (let ((numeric-code (cdr (assoc mouse-button *apollo-mouse-buttons*))))
|
|
|
208 (if (null numeric-code)
|
|
|
209 (error "(hmouse-key): %s is not a valid Apollo mouse key name."
|
|
|
210 mouse-button))
|
|
|
211 (if (stringp numeric-code)
|
|
|
212 (setq numeric-code
|
|
|
213 (cdr (assoc numeric-code *apollo-mouse-buttons*))))
|
|
|
214 (let ((key-sequence (char-to-string numeric-code)))
|
|
|
215 (cons key-sequence (lookup-key 'apollo-prefix key-sequence)))))
|
|
|
216 )
|
|
|
217 (defun apollo-mouse-move-point (&optional no-mark)
|
|
|
218 "Used so that pressing the left mouse button, moving the cursor, and
|
|
|
219 releasing the left mouse button leaves the mark set to the initial position
|
|
|
220 and the point set to the final position. Useful for easily marking regions
|
|
|
221 of text. If the left mouse button is pressed and released at the same place,
|
|
|
222 the mark is left at the original position of the character cursor.
|
|
|
223
|
|
|
224 Returns (x y) frame coordinates of point in columns and lines."
|
|
|
225 (interactive)
|
|
|
226 (let* ((opoint (point))
|
|
|
227 (owindow (selected-window))
|
|
|
228 (x (- (read-char) 8))
|
|
|
229 (y (- (read-char) 8))
|
|
|
230 (edges (window-edges))
|
|
|
231 (window nil))
|
|
|
232 (while (and (not (eq window (selected-window)))
|
|
|
233 (or (< y (nth 1 edges))
|
|
|
234 (>= y (nth 3 edges))
|
|
|
235 (< x (nth 0 edges))
|
|
|
236 (>= x (nth 2 edges))))
|
|
|
237 (setq window (next-window window))
|
|
|
238 (setq edges (window-edges window)))
|
|
|
239 (if (and window (not (eq window (selected-window))))
|
|
|
240 (progn
|
|
|
241 (if (and (not *apollo-mouse-move-point-allow-minibuffer-exit*)
|
|
|
242 (eq (selected-window) (minibuffer-window)))
|
|
|
243 (error "Cannot use mouse to leave minibuffer!"))
|
|
|
244 (if (eq window (minibuffer-window))
|
|
|
245 (error "Cannot use mouse to enter minibuffer!"))))
|
|
|
246 (if window (select-window window))
|
|
|
247 (move-to-window-line (- y (nth 1 edges)))
|
|
|
248 (let* ((width-1 (1- (window-width window)))
|
|
|
249 (wraps (/ (current-column) width-1))
|
|
|
250 (prompt-length (if (eq (selected-window) (minibuffer-window))
|
|
|
251 (minibuffer-prompt-length)
|
|
|
252 0)))
|
|
|
253 (move-to-column (+ (- x (nth 0 edges) prompt-length)
|
|
|
254 (* wraps width-1))))
|
|
|
255 (if no-mark
|
|
|
256 (progn (setq window (selected-window))
|
|
|
257 (if (eq owindow window)
|
|
|
258 (if (equal opoint (point))
|
|
|
259 (pop-mark))
|
|
|
260 (select-window owindow)
|
|
|
261 (pop-mark)
|
|
|
262 (select-window window)))
|
|
|
263 (set-mark-command nil))
|
|
|
264 ;; Return (x y) coords of point in column and frame line numbers.
|
|
|
265 (list x y)))
|
|
|
266 ))
|
|
|
267
|
|
|
268 (defun action-key-depress (&rest args)
|
|
|
269 (interactive)
|
|
|
270 (require 'hsite)
|
|
|
271 (setq action-key-depress-prev-point (point-marker)
|
|
|
272 action-key-depressed-flag t
|
|
|
273 action-key-depress-args (hmouse-set-point args)
|
|
|
274 action-key-depress-window (selected-window)
|
|
|
275 action-key-release-args nil
|
|
|
276 action-key-release-window nil
|
|
|
277 action-key-release-prev-point nil)
|
|
|
278 (if assist-key-depressed-flag
|
|
|
279 (or action-key-help-flag
|
|
|
280 (setq assist-key-help-flag t))))
|
|
|
281
|
|
|
282 (defun assist-key-depress (&rest args)
|
|
|
283 (interactive)
|
|
|
284 (require 'hsite)
|
|
|
285 (setq assist-key-depress-prev-point (point-marker)
|
|
|
286 assist-key-depressed-flag t
|
|
|
287 assist-key-depress-args (hmouse-set-point args)
|
|
|
288 assist-key-depress-window (selected-window)
|
|
|
289 assist-key-release-args nil
|
|
|
290 assist-key-release-window nil
|
|
|
291 assist-key-release-prev-point nil)
|
|
|
292 (if action-key-depressed-flag
|
|
|
293 (or assist-key-help-flag
|
|
|
294 (setq action-key-help-flag t)))
|
|
|
295 )
|
|
|
296
|
|
|
297 (defun action-key-depress-emacs19 (event)
|
|
|
298 (interactive "e")
|
|
|
299 (require 'hsite)
|
|
|
300 (action-key-depress event))
|
|
|
301
|
|
|
302 (defun assist-key-depress-emacs19 (event)
|
|
|
303 (interactive "e")
|
|
|
304 (require 'hsite)
|
|
|
305 (assist-key-depress event))
|
|
|
306
|
|
|
307 (defun action-mouse-key-emacs19 (event)
|
|
|
308 "Set point to the current mouse cursor position and execute 'action-key'.
|
|
|
309 EVENT will be passed to 'hmouse-function'."
|
|
|
310 (interactive "e")
|
|
|
311 (action-mouse-key (hmouse-key-release-args-emacs19 event)))
|
|
|
312
|
|
|
313 (defun assist-mouse-key-emacs19 (event)
|
|
|
314 "Set point to the current mouse cursor position and execute 'action-key'.
|
|
|
315 EVENT will be passed to 'hmouse-function'."
|
|
|
316 (interactive "e")
|
|
|
317 (assist-mouse-key (hmouse-key-release-args-emacs19 event)))
|
|
|
318
|
|
|
319 (defun hmouse-key-release-args-emacs19 (event)
|
|
|
320 (let ((ev-type-str (and (listp event) (symbol-name (car event)))))
|
|
|
321 (if (or (and ev-type-str
|
|
|
322 (string-match "\\(double\\|triple\\)-mouse" ev-type-str))
|
|
|
323 (not (= (length event) 3)))
|
|
|
324 event
|
|
|
325 ;; Remove depress coordinates and send only release coordinates.
|
|
|
326 (list (car event) (nth 2 event)))))
|
|
|
327
|
|
|
328 (defun hmouse-move-point-xemacs ()
|
|
|
329 (condition-case ()
|
|
|
330 (mouse-set-point current-mouse-event)
|
|
|
331 ;; Catch "not in a window" errors, e.g. on modeline
|
|
|
332 (error nil)))
|
|
|
333
|
|
|
334 (defun hmouse-move-point-eterm (arg-list)
|
|
|
335 (apply 'mouse-move-point arg-list))
|
|
|
336
|
|
|
337 ;;; ************************************************************************
|
|
|
338 ;;; Private variables
|
|
|
339 ;;; ************************************************************************
|
|
|
340
|
|
|
341 (defvar hmouse-bindings nil
|
|
|
342 "List of (key . binding) pairs for Smart Mouse Keys.")
|
|
|
343
|
|
|
344 (defvar hmouse-bindings-flag nil
|
|
|
345 "True if Smart Key mouse bindings are in use, else nil.")
|
|
|
346
|
|
|
347 (defvar hmouse-previous-bindings nil
|
|
|
348 "List of previous (key . binding) pairs for mouse keys used as Smart Keys.")
|
|
|
349
|
|
|
350 (provide 'hmouse-key)
|
