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