Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hmouse-key.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children 4103f0995bd7
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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)