Mercurial > hg > xemacs-beta

comparison lisp/hyperbole/hmouse-drv.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-drv.el
4 ;; SUMMARY: Smart Key/Mouse driver functions.
5 ;; USAGE: GNU Emacs Lisp Library
6 ;; KEYWORDS: hypermedia, mouse
7 ;;
8 ;; AUTHOR: Bob Weiner
9 ;; ORIG-DATE: 04-Feb-90
10 ;; LAST-MOD: 1-Nov-95 at 21:44:52 by Bob Weiner
11 ;;
12 ;; This file is part of Hyperbole.
13 ;; Available for use and distribution under the same terms as GNU Emacs.
14 ;;
15 ;; Copyright (C) 1989-1995, Free Software Foundation, Inc.
16 ;; Developed with support from Motorola Inc.
17 ;;
18 ;; DESCRIPTION:
19 ;; DESCRIP-END.
20
21 ;;; ************************************************************************
22 ;;; Other required Elisp libraries
23 ;;; ************************************************************************
24
25 (require 'hypb)
26
27 ;;; ************************************************************************
28 ;;; Public variables
29 ;;; ************************************************************************
30
31 (defvar action-key-depress-window nil
32 "The last window in which the Action Key was depressed or nil.")
33 (defvar assist-key-depress-window nil
34 "The last window in which the Assist Key was depressed or nil.")
35 (defvar action-key-release-window nil
36 "The last window in which the Action Key was released or nil.")
37 (defvar assist-key-release-window nil
38 "The last window in which the Assist Key was released or nil.")
39
40 (defvar action-key-depress-prev-point nil
41 "Marker at point prior to last Action Key depress.
42 Note that this may be a buffer different than where the depress occurs.")
43 (defvar assist-key-depress-prev-point nil
44 "Marker at point prior to last Assist Key depress.
45 Note that this may be a buffer different than where the depress occurs.")
46 (defvar action-key-release-prev-point nil
47 "Marker at point prior to last Action Key release.
48 Note that this may be a buffer different than where the release occurs.")
49 (defvar assist-key-release-prev-point nil
50 "Marker at point prior to last Assist Key release.
51 Note that this may be a buffer different than where the release occurs.")
52
53 (defvar action-key-cancelled nil
54 "When non-nil, cancels last Action Key depress.")
55 (defvar assist-key-cancelled nil
56 "When non-nil, cancels last Assist Key depress.")
57
58 (defvar action-key-help-flag nil
59 "When non-nil, forces display of help for next Action Key release.")
60 (defvar assist-key-help-flag nil
61 "When non-nil, forces display of help for next Assist Key release.")
62
63 ;;; ************************************************************************
64 ;;; Hyperbole context-sensitive key driver functions
65 ;;; ************************************************************************
66
67 (defun action-mouse-key (&rest args)
68 "Set point to the current mouse cursor position and execute 'action-key'.
69 Any ARGS will be passed to 'hmouse-function'."
70 (interactive)
71 (require 'hsite)
72 ;; Make this a no-op if some local mouse key binding overrode the global
73 ;; action-key-depress command invocation.
74 (if action-key-depressed-flag
75 (let ((hkey-alist hmouse-alist))
76 (setq action-key-depressed-flag nil)
77 (cond (action-key-cancelled
78 (setq action-key-cancelled nil
79 assist-key-depressed-flag nil))
80 (assist-key-depressed-flag
81 (hmouse-function nil nil args))
82 ((action-mouse-key-help nil args))
83 (t (hmouse-function 'action-key nil args))))))
84
85 (defun assist-mouse-key (&rest args)
86 "Set point to the current mouse cursor position and execute 'assist-key'.
87 Any ARGS will be passed to 'hmouse-function'."
88 (interactive)
89 (require 'hsite)
90 ;; Make this a no-op if some local mouse key binding overrode the global
91 ;; assist-key-depress command invocation.
92 (if assist-key-depressed-flag
93 (let ((hkey-alist hmouse-alist))
94 (setq assist-key-depressed-flag nil)
95 (cond (assist-key-cancelled
96 (setq assist-key-cancelled nil
97 action-key-depressed-flag nil))
98 (action-key-depressed-flag
99 (hmouse-function nil t args))
100 ((action-mouse-key-help t args))
101 (t (hmouse-function 'assist-key t args))))))
102
103 (defun hmouse-function (func assist-flag set-point-arg-list)
104 "Executes FUNC for Action Key (Assist Key with ASSIST-FLAG non-nil) and sets point from SET-POINT-ARG-LIST.
105 FUNC may be nil in which case no function is called.
106 SET-POINT-ARG-LIST is passed to the call of the command bound to
107 'hmouse-set-point-command'. Returns nil if 'hmouse-set-point-command' variable
108 is not bound to a valid function."
109 (if (fboundp hmouse-set-point-command)
110 (let ((release-args (hmouse-set-point set-point-arg-list)))
111 (if assist-flag
112 (setq assist-key-release-window (selected-window)
113 assist-key-release-args release-args
114 assist-key-release-prev-point (point-marker))
115 (setq action-key-release-window (selected-window)
116 action-key-release-args release-args
117 action-key-release-prev-point (point-marker)))
118 (and (eq major-mode 'br-mode)
119 (setq action-mouse-key-prev-window
120 (if (br-in-view-window-p)
121 (save-window-excursion
122 (br-next-listing-window)
123 (selected-window))
124 (selected-window))))
125 (setq action-mouse-key-prefix-arg current-prefix-arg)
126 (if (null func)
127 nil
128 (funcall func)
129 (setq action-mouse-key-prev-window nil
130 action-mouse-key-prefix-arg nil))
131 t)))
132
133 (defun action-mouse-key-help (assist-flag args)
134 "If a Smart Key help flag is set and the other Smart Key is not down, shows help.
135 Takes two args: ASSIST-FLAG should be non-nil iff command applies to the Assist Key.
136 ARGS is a list of arguments passed to 'hmouse-function'.
137 Returns t if help is displayed, nil otherwise."
138 (let ((help-shown)
139 (other-key-released (not (if assist-flag
140 action-key-depressed-flag
141 assist-key-depressed-flag))))
142 (unwind-protect
143 (setq help-shown
144 (cond ((and action-key-help-flag other-key-released)
145 (setq action-key-help-flag nil)
146 (hmouse-function 'hkey-help assist-flag args)
147 t)
148 ((and assist-key-help-flag other-key-released)
149 (setq assist-key-help-flag nil)
150 (hmouse-function 'assist-key-help assist-flag args)
151 t)))
152 (if help-shown
153 ;; Then both Smart Keys have been released.
154 (progn (setq action-key-cancelled nil
155 assist-key-cancelled nil)
156 t)))))
157
158 (defun action-key ()
159 "Use one key to perform functions that vary by buffer.
160 Default function is given by 'action-key-default-function' variable.
161 Returns t unless 'action-key-default-function' variable is not bound to a valid
162 function."
163 (interactive)
164 (require 'hsite)
165 (or (hkey-execute nil)
166 (if (fboundp action-key-default-function)
167 (progn (funcall action-key-default-function)
168 t))))
169
170 (defun assist-key ()
171 "Use one assist-key to perform functions that vary by buffer.
172 Default function is given by 'assist-key-default-function' variable.
173 Returns non-nil unless 'assist-key-default-function' variable is not bound
174 to a valid function."
175 (interactive)
176 (require 'hsite)
177 (or (hkey-execute t)
178 (if (fboundp assist-key-default-function)
179 (progn (funcall assist-key-default-function)
180 t))))
181
182 (defun hkey-execute (assist-flag)
183 "Evaluate Action Key form (or Assist Key form with ASSIST-FLAG non-nil) for first non-nil predicate from 'hkey-alist'.
184 Non-nil ASSIST-FLAG means evaluate second form, otherwise evaluate first form.
185 Returns non-nil iff a non-nil predicate is found."
186 (let ((pred-forms hkey-alist)
187 (pred-form) (pred-t))
188 (while (and (null pred-t) (setq pred-form (car pred-forms)))
189 (if (setq pred-t (eval (car pred-form)))
190 (eval (if assist-flag (cdr (cdr pred-form)) (car (cdr pred-form))))
191 (setq pred-forms (cdr pred-forms))))
192 pred-t))
193
194 (defun hkey-help (&optional assist-flag)
195 "Display help for the Action Key command in current context.
196 With optional ASSIST-FLAG non-nil, display help for the Assist Key command.
197 Returns non-nil iff associated help documentation is found."
198 (interactive "P")
199 (require 'hsite)
200 (let ((pred-forms hkey-alist)
201 (pred-form) (pred-t) (call) (cmd-sym) (doc))
202 (while (and (null pred-t) (setq pred-form (car pred-forms)))
203 (or (setq pred-t (eval (car pred-form)))
204 (setq pred-forms (cdr pred-forms))))
205 (if pred-t
206 (setq call (if assist-flag (cdr (cdr pred-form))
207 (car (cdr pred-form)))
208 cmd-sym (car call))
209 (setq cmd-sym
210 (if assist-flag assist-key-default-function action-key-default-function)
211 call cmd-sym))
212 (setq hkey-help-msg
213 (if (and cmd-sym (symbolp cmd-sym))
214 (progn
215 (setq doc (documentation cmd-sym))
216 (let* ((condition (car pred-form))
217 (temp-buffer-show-hook
218 (function
219 (lambda (buf)
220 (set-buffer buf)
221 (setq buffer-read-only t)
222 (if (br-in-browser)
223 (save-excursion
224 (let ((owind (selected-window)))
225 (br-to-view-window)
226 (select-window (previous-window))
227 (display-buffer buf 'other-win)
228 (select-window owind)))
229 (display-buffer buf 'other-win)))))
230 (temp-buffer-show-function temp-buffer-show-hook))
231 (with-output-to-temp-buffer (hypb:help-buf-name "Smart")
232 (princ (format "A click of the %s Key"
233 (if assist-flag "Assist" "Action")))
234 (terpri)
235 (princ "WHEN ")
236 (princ
237 (or condition
238 "there is no matching context"))
239 (terpri)
240 (princ "CALLS ") (princ call)
241 (if doc (progn (princ " WHICH:") (terpri) (terpri)
242 (princ doc)))
243 (if (memq cmd-sym '(hui:hbut-act hui:hbut-help))
244 (progn
245 (princ (format "\n\nBUTTON SPECIFICS:\n\n%s\n"
246 (actype:doc 'hbut:current t)))
247 (hattr:report
248 (nthcdr 2 (hattr:list 'hbut:current)))))
249 (terpri)
250 ))
251 "")
252 (message "No %s Key command for current context."
253 (if assist-flag "Assist" "Action"))))
254 doc))
255
256 (defun assist-key-help ()
257 "Display doc associated with Assist Key command in current context.
258 Returns non-nil iff associated documentation is found."
259 (interactive)
260 (hkey-help 'assist))
261
262 (defun hkey-help-hide ()
263 "Restores frame to configuration prior to help buffer display.
264 Point must be in the help buffer."
265 (let ((buf (current-buffer)))
266 (if *hkey-wconfig*
267 (set-window-configuration *hkey-wconfig*)
268 (switch-to-buffer (other-buffer)))
269 (bury-buffer buf)
270 (setq *hkey-wconfig* nil)))
271
272 (defun hkey-help-show (buffer &optional current-window)
273 "Saves prior frame configuration if BUFFER displays help. Displays BUFFER.
274
275 Optional second arg CURRENT-WINDOW non-nil forces display of buffer within
276 the current window. By default, it is displayed in another window."
277 (if (bufferp buffer) (setq buffer (buffer-name buffer)))
278 (and (stringp buffer)
279 (string-match "Help\\*$" buffer)
280 (not (memq t (mapcar (function
281 (lambda (wind)
282 (string-match
283 "Help\\*$"
284 (buffer-name (window-buffer wind)))))
285 (hypb:window-list 'no-mini))))
286 (setq *hkey-wconfig* (current-window-configuration)))
287 (let* ((buf (get-buffer-create buffer))
288 (wind (if current-window
289 (progn (switch-to-buffer buf)
290 (selected-window))
291 (display-buffer buf))))
292 (setq minibuffer-scroll-window wind)))
293
294 (defun hkey-operate (arg)
295 "Uses the keyboard to emulate Smart Mouse Key drag actions.
296 Each invocation alternates between starting a drag and ending it.
297 Prefix ARG non-nil means emulate Assist Key rather than the Action Key.
298
299 Only works when running under a window system, not from a dumb terminal."
300 (interactive "P")
301 (or hyperb:window-system
302 (hypb:error "(hkey-operate): Drag actions require mouse support"))
303 (if arg
304 (if assist-key-depressed-flag
305 (progn (assist-mouse-key)
306 (message "Assist Key released."))
307 (assist-key-depress)
308 (message
309 "Assist Key depressed; go to release point and hit {%s %s}."
310 (substitute-command-keys "\\[universal-argument]")
311 (substitute-command-keys "\\[hkey-operate]")
312 ))
313 (if action-key-depressed-flag
314 (progn (action-mouse-key)
315 (message "Action Key released."))
316 (action-key-depress)
317 (message "Action Key depressed; go to release point and hit {%s}."
318 (substitute-command-keys "\\[hkey-operate]"))
319 )))
320
321 (defun hkey-summarize (&optional current-window)
322 "Displays smart key operation summary in help buffer.
323 Optional arg CURRENT-WINDOW non-nil forces display of buffer within
324 the current window. By default, it is displayed in another window."
325 (let* ((doc-file (hypb:mouse-help-file))
326 (buf-name (hypb:help-buf-name "Smart"))
327 (wind (get-buffer-window buf-name))
328 owind)
329 (if (file-readable-p doc-file)
330 (progn
331 (if (br-in-browser)
332 (br-to-view-window))
333 (setq owind (selected-window))
334 (unwind-protect
335 (progn
336 (if wind
337 (select-window wind)
338 (hkey-help-show buf-name current-window)
339 (select-window (get-buffer-window buf-name)))
340 (setq buffer-read-only nil) (erase-buffer)
341 (insert-file-contents doc-file)
342 (goto-char (point-min))
343 (set-buffer-modified-p nil))
344 (select-window owind))))))
345
346 ;; ************************************************************************
347 ;; Private variables
348 ;; ************************************************************************
349
350 (defvar action-key-depress-args nil
351 "List of mouse event args from most recent depress of the Action Key.")
352 (defvar assist-key-depress-args nil
353 "List of mouse event args from most recent depress of the Assist Key.")
354
355 (defvar action-key-release-args nil
356 "List of mouse event args from most recent release of the Action Key.")
357 (defvar assist-key-release-args nil
358 "List of mouse event args from most recent release of the Assist Key.")
359
360 (defvar action-mouse-key-prev-window nil
361 "Window point was in prior to current invocation of 'action/assist-mouse-key'.")
362
363 (defvar action-mouse-key-prefix-arg nil
364 "Prefix argument to pass to 'smart-br-cmd-select'.")
365
366 (defvar action-key-depressed-flag nil "t while Action Key is depressed.")
367 (defvar assist-key-depressed-flag nil "t while Assist Key is depressed.")
368 (defvar hkey-help-msg "" "Holds last Smart Key help message.")
369 (defvar *hkey-wconfig* nil
370 "Screen configuration prior to display of a help buffer.")
371
372 ;;; ************************************************************************
373 ;;; public support functions
374 ;;; ************************************************************************
375
376 ;; "hsite.el" contains documentation for this variable.
377 (or (boundp 'smart-scroll-proportional) (setq smart-scroll-proportional nil))
378
379 ;; The smart keys scroll buffers when pressed at the ends of lines.
380 ;; These next two functions do the scrolling and keep point at the end
381 ;; of line to simplify repeated scrolls when using keyboard smart keys.
382 ;;
383 ;; These functions may also be used to test whether the scroll action would
384 ;; be successful, no action is taken if it would fail (because the beginning
385 ;; or end of a buffer is already showing) and nil is returned.
386 ;; t is returned whenever scrolling is performed.
387
388 (defun smart-scroll-down ()
389 "Scrolls down according to value of smart-scroll-proportional.
390 If smart-scroll-proportional is nil or if point is on the bottom window line,
391 scrolls down (backward) a windowful. Otherwise, tries to bring current line
392 to bottom of window. Leaves point at end of line and returns t if scrolled,
393 nil if not."
394 (interactive)
395 (let ((rtn t))
396 (if smart-scroll-proportional
397 ;; If selected line is already last in window, then scroll backward
398 ;; a windowful, otherwise make it last in window.
399 (if (>= (point) (save-excursion
400 (goto-char (1- (window-end)))
401 (beginning-of-line) (point)))
402 (if (pos-visible-in-window-p (point-min))
403 (setq rtn nil)
404 (scroll-down))
405 (recenter -1))
406 (if (pos-visible-in-window-p (point-min))
407 (setq rtn nil)
408 (scroll-down)))
409 (end-of-line)
410 (or rtn (progn (beep) (message "Beginning of buffer")))
411 rtn))
412
413 (defun smart-scroll-up ()
414 "Scrolls up according to value of smart-scroll-proportional.
415 If smart-scroll-proportional is nil or if point is on the top window line,
416 scrolls up (forward) a windowful. Otherwise, tries to bring current line to
417 top of window. Leaves point at end of line and returns t if scrolled, nil if
418 not."
419 (interactive)
420 (let ((rtn t))
421 (if smart-scroll-proportional
422 ;; If selected line is already first in window, then scroll forward a
423 ;; windowful, otherwise make it first in window.
424 (if (<= (point) (save-excursion
425 (goto-char (window-start))
426 (end-of-line) (point)))
427 (if (pos-visible-in-window-p (point-max))
428 (setq rtn nil)
429 (scroll-up))
430 (recenter 0))
431 (if (pos-visible-in-window-p (point-max))
432 (setq rtn nil)
433 (scroll-up)))
434 (end-of-line)
435 (or rtn (progn (beep) (message "End of buffer")))
436 rtn))
437
438 (provide 'hmouse-drv)