Source

hyperbole / hmouse-drv.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
;;; hmouse-drv.el --- Smart Key/Mouse driver functions.

;; Copyright (C) 1989-1995 Free Software Foundation, Inc.
;; Developed with support from Motorola Inc.

;; Author: Bob Weiner, Brown U.
;; Maintainer: Mats Lidell <matsl@contactor.se>
;; Keywords: hypermedia, mouse

;; This file is part of GNU Hyperbole.

;; GNU Hyperbole is free software; you can redistribute it and/or
;; modify it under the terms of the GNU General Public License as
;; published by the Free Software Foundation; either version 3, or (at
;; your option) any later version.

;; GNU Hyperbole is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to the
;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.

;;; Commentary:

;;; Code:

;;;
;;; Other required Elisp libraries
;;;

(require 'hypb)

;;;
;;; Public variables
;;;

(defvar action-key-depress-window nil
  "The last window in which the Action Key was depressed or nil.")
(defvar assist-key-depress-window nil
  "The last window in which the Assist Key was depressed or nil.")
(defvar action-key-release-window nil
  "The last window in which the Action Key was released or nil.")
(defvar assist-key-release-window nil
  "The last window in which the Assist Key was released or nil.")

(defvar action-key-depress-prev-point nil
  "Marker at point prior to last Action Key depress.
Note that this may be a buffer different than where the depress occurs.")
(defvar assist-key-depress-prev-point nil
  "Marker at point prior to last Assist Key depress.
Note that this may be a buffer different than where the depress occurs.")
(defvar action-key-release-prev-point nil
  "Marker at point prior to last Action Key release.
Note that this may be a buffer different than where the release occurs.")
(defvar assist-key-release-prev-point nil
  "Marker at point prior to last Assist Key release.
Note that this may be a buffer different than where the release occurs.")

(defvar action-key-cancelled nil
  "When non-nil, cancels last Action Key depress.")
(defvar assist-key-cancelled nil
  "When non-nil, cancels last Assist Key depress.")

(defvar action-key-help-flag nil
  "When non-nil, forces display of help for next Action Key release.")
(defvar assist-key-help-flag nil
  "When non-nil, forces display of help for next Assist Key release.")

;;;
;;; Hyperbole context-sensitive key driver functions
;;;

(defun action-mouse-key (&rest args)
  "Set point to the current mouse cursor position and execute 'action-key'.
Any ARGS will be passed to 'hmouse-function'."
  (interactive)
  (require 'hsite)
  ;; Make this a no-op if some local mouse key binding overrode the global
  ;; action-key-depress command invocation.
  (if action-key-depressed-flag
      (let ((hkey-alist hmouse-alist))
	(setq action-key-depressed-flag nil)
	(cond (action-key-cancelled
		(setq action-key-cancelled nil
		      assist-key-depressed-flag nil))
	      (assist-key-depressed-flag
		(hmouse-function nil nil args))
	      ((action-mouse-key-help nil args))
	      (t (hmouse-function 'action-key nil args))))))

(defun assist-mouse-key (&rest args)
  "Set point to the current mouse cursor position and execute 'assist-key'.
Any ARGS will be passed to 'hmouse-function'."
  (interactive)
  (require 'hsite)
  ;; Make this a no-op if some local mouse key binding overrode the global
  ;; assist-key-depress command invocation.
  (if assist-key-depressed-flag
      (let ((hkey-alist hmouse-alist))
	(setq assist-key-depressed-flag nil)
	(cond (assist-key-cancelled
		(setq assist-key-cancelled nil
		      action-key-depressed-flag nil))
	      (action-key-depressed-flag
		(hmouse-function nil t args))
	      ((action-mouse-key-help t args))
	      (t (hmouse-function 'assist-key t args))))))

(defun hmouse-function (func assist-flag set-point-arg-list)
  "Executes FUNC for Action Key (Assist Key with ASSIST-FLAG non-nil) and sets point from SET-POINT-ARG-LIST.
FUNC may be nil in which case no function is called.
SET-POINT-ARG-LIST is passed to the call of the command bound to
'hmouse-set-point-command'.  Returns nil if 'hmouse-set-point-command' variable
is not bound to a valid function."
  (if (fboundp hmouse-set-point-command)
      (let ((release-args (hmouse-set-point set-point-arg-list)))
	(if assist-flag
	    (setq assist-key-release-window (selected-window)
		  assist-key-release-args release-args
		  assist-key-release-prev-point (point-marker))
	  (setq action-key-release-window (selected-window)
		action-key-release-args release-args
		action-key-release-prev-point (point-marker)))
	(and (eq major-mode 'br-mode)
	     (setq action-mouse-key-prev-window 
		   (if (br-in-view-window-p)
		       (save-window-excursion
			 (br-next-listing-window)
			 (selected-window))
		     (selected-window))))
	(setq action-mouse-key-prefix-arg current-prefix-arg)
	(if (null func)
	    nil
	  (funcall func)
	  (setq action-mouse-key-prev-window nil
		action-mouse-key-prefix-arg nil))
	t)))

(defun action-mouse-key-help (assist-flag args)
  "If a Smart Key help flag is set and the other Smart Key is not down, shows help.
Takes two args:  ASSIST-FLAG should be non-nil iff command applies to the Assist Key.
ARGS is a list of arguments passed to 'hmouse-function'.
Returns t if help is displayed, nil otherwise."
  (let ((help-shown)
	(other-key-released (not (if assist-flag
				     action-key-depressed-flag
				   assist-key-depressed-flag))))
    (unwind-protect
	(setq help-shown
	      (cond ((and  action-key-help-flag other-key-released)
		     (setq action-key-help-flag nil)
		     (hmouse-function 'hkey-help assist-flag args)
		     t)
		    ((and  assist-key-help-flag other-key-released)
		     (setq assist-key-help-flag nil)
		     (hmouse-function 'assist-key-help assist-flag args)
		     t)))
      (if help-shown
	  ;; Then both Smart Keys have been released. 
	  (progn (setq action-key-cancelled nil
		       assist-key-cancelled nil)
		 t)))))

(defun action-key ()
  "Use one key to perform functions that vary by buffer.
Default function is given by 'action-key-default-function' variable.
Returns t unless 'action-key-default-function' variable is not bound to a valid
function."
  (interactive)
  (require 'hsite)
  (or (hkey-execute nil)
      (if (fboundp action-key-default-function)
	 (progn (funcall action-key-default-function)
		t))))

(defun assist-key ()
  "Use one assist-key to perform functions that vary by buffer.
Default function is given by 'assist-key-default-function' variable.
Returns non-nil unless 'assist-key-default-function' variable is not bound
to a valid function."
  (interactive)
  (require 'hsite)
  (or (hkey-execute t)
      (if (fboundp assist-key-default-function)
	  (progn (funcall assist-key-default-function)
		 t))))

(defun hkey-execute (assist-flag)
  "Evaluate Action Key form (or Assist Key form with ASSIST-FLAG non-nil) for first non-nil predicate from 'hkey-alist'.
Non-nil ASSIST-FLAG means evaluate second form, otherwise evaluate first form.
Returns non-nil iff a non-nil predicate is found."
    (let ((pred-forms hkey-alist)
	  (pred-form) (pred-t))
      (while (and (null pred-t) (setq pred-form (car pred-forms)))
	(if (setq pred-t (eval (car pred-form)))
	    (eval (if assist-flag (cdr (cdr pred-form)) (car (cdr pred-form))))
	  (setq pred-forms (cdr pred-forms))))
      pred-t))

(defun hkey-help (&optional assist-flag)
  "Display help for the Action Key command in current context.
With optional ASSIST-FLAG non-nil, display help for the Assist Key command.
Returns non-nil iff associated help documentation is found."
  (interactive "P")
  (require 'hsite)
  (let ((pred-forms hkey-alist)
	(pred-form) (pred-t) (call) (cmd-sym) (doc))
    (while (and (null pred-t) (setq pred-form (car pred-forms)))
      (or (setq pred-t (eval (car pred-form)))
	  (setq pred-forms (cdr pred-forms))))
    (if pred-t
	(setq call (if assist-flag (cdr (cdr pred-form))
		     (car (cdr pred-form)))
	      cmd-sym (car call))
      (setq cmd-sym
	    (if assist-flag assist-key-default-function action-key-default-function)
	    call cmd-sym))
    (setq hkey-help-msg
	  (if (and cmd-sym (symbolp cmd-sym))
	      (progn
		(setq doc (documentation cmd-sym))
		(let* ((condition (car pred-form))
		       (temp-buffer-show-hook
			 (function
			   (lambda (buf)
			     (set-buffer buf)
			     (setq buffer-read-only t)
			     (if (br-in-browser)
				 (save-excursion
				   (let ((owind (selected-window)))
				     (br-to-view-window)
				     (select-window (previous-window))
				     (display-buffer buf 'other-win)
				     (select-window owind)))
			       (display-buffer buf 'other-win)))))
		       (temp-buffer-show-function temp-buffer-show-hook))
		  (with-output-to-temp-buffer (hypb:help-buf-name "Smart")
		    (princ (format "A click of the %s Key"
				   (if assist-flag "Assist" "Action")))
		    (terpri)
		    (princ "WHEN  ")
		    (princ
		      (or condition
			  "there is no matching context"))
		    (terpri)
		    (princ "CALLS ") (princ call)
		    (if doc (progn (princ " WHICH:") (terpri) (terpri)
				   (princ doc)))
		    (if (memq cmd-sym '(hui:hbut-act hui:hbut-help))
			(progn
			  (princ (format "\n\nBUTTON SPECIFICS:\n\n%s\n"
					 (actype:doc 'hbut:current t)))
			  (hattr:report
			    (nthcdr 2 (hattr:list 'hbut:current)))))
		    (terpri)
		    ))
		"")
	    (message "No %s Key command for current context."
		     (if assist-flag "Assist" "Action"))))
    doc))

(defun assist-key-help ()
  "Display doc associated with Assist Key command in current context.
Returns non-nil iff associated documentation is found."
  (interactive)
  (hkey-help 'assist))

(defun hkey-help-hide ()
  "Restores frame to configuration prior to help buffer display.
Point must be in the help buffer."
  (let ((buf (current-buffer)))
    (if *hkey-wconfig*
	(set-window-configuration *hkey-wconfig*)
      (switch-to-buffer (other-buffer)))
    (if (fboundp 'help-mode-bury)
	(help-mode-bury)
      (bury-buffer buf))
    (setq *hkey-wconfig* nil)))

(defun hkey-help-show (buffer &optional current-window)
  "Saves prior frame configuration if BUFFER displays help.  Displays BUFFER.

Optional second arg CURRENT-WINDOW non-nil forces display of buffer within
the current window.  By default, it is displayed in another window."
  (if (bufferp buffer) (setq buffer (buffer-name buffer)))
  (and (stringp buffer)
       (string-match "Help\\*$" buffer)
       (not (memq t (mapcar (function
			     (lambda (wind)
			       (string-match
				"Help\\*$"
				(buffer-name (window-buffer wind)))))
			    (hypb:window-list 'no-mini))))
       (setq *hkey-wconfig* (current-window-configuration)))
  (let* ((buf (get-buffer-create buffer))
	 (wind (if current-window
		   (progn (switch-to-buffer buf)
			  (selected-window))
		 (display-buffer buf))))
    (setq minibuffer-scroll-window wind)))

(defun hkey-operate (arg)
  "Uses the keyboard to emulate Smart Mouse Key drag actions.
Each invocation alternates between starting a drag and ending it.
Prefix ARG non-nil means emulate Assist Key rather than the Action Key.

Only works when running under a window system, not from a dumb terminal."
  (interactive "P")
  (or hyperb:window-system
      (hypb:error "(hkey-operate): Drag actions require mouse support"))
  (if arg
      (if assist-key-depressed-flag
	  (progn (assist-mouse-key)
		 (message "Assist Key released."))
	(assist-key-depress)
	(message
	  "Assist Key depressed; go to release point and hit {%s %s}."
	  (substitute-command-keys "\\[universal-argument]")
	  (substitute-command-keys "\\[hkey-operate]")
	  ))
    (if action-key-depressed-flag
	(progn (action-mouse-key)
	       (message "Action Key released."))
      (action-key-depress)
      (message "Action Key depressed; go to release point and hit {%s}."
	       (substitute-command-keys "\\[hkey-operate]"))
      )))

(defun hkey-summarize (&optional current-window)
  "Displays smart key operation summary in help buffer.
Optional arg CURRENT-WINDOW non-nil forces display of buffer within
the current window.  By default, it is displayed in another window."
  (let* ((doc-file (hypb:mouse-help-file))
	 (buf-name (hypb:help-buf-name "Smart"))
	 (wind (get-buffer-window buf-name))
	 owind)
    (if (file-readable-p doc-file)
	(progn
	  (if (br-in-browser)
	      (br-to-view-window))
	  (setq owind (selected-window))
	  (unwind-protect
	      (progn
		(if wind
		    (select-window wind)
		  (hkey-help-show buf-name current-window)
		  (select-window (get-buffer-window buf-name)))
		(setq buffer-read-only nil) (erase-buffer)
		(insert-file-contents doc-file)
		(goto-char (point-min))
		(set-buffer-modified-p nil))
	    (select-window owind))))))

;; 
;; Private variables
;; 

(defvar action-key-depress-args nil
  "List of mouse event args from most recent depress of the Action Key.")
(defvar assist-key-depress-args nil
  "List of mouse event args from most recent depress of the Assist Key.")

(defvar action-key-release-args nil
  "List of mouse event args from most recent release of the Action Key.")
(defvar assist-key-release-args nil
  "List of mouse event args from most recent release of the Assist Key.")

(defvar action-mouse-key-prev-window nil
  "Window point was in prior to current invocation of 'action/assist-mouse-key'.")

(defvar action-mouse-key-prefix-arg nil
  "Prefix argument to pass to 'smart-br-cmd-select'.")

(defvar action-key-depressed-flag nil "t while Action Key is depressed.")
(defvar assist-key-depressed-flag nil "t while Assist Key is depressed.")
(defvar hkey-help-msg "" "Holds last Smart Key help message.")
(defvar *hkey-wconfig* nil
  "Screen configuration prior to display of a help buffer.")

;;;
;;; public support functions
;;;

;; "hsite.el" contains documentation for this variable.
(or (boundp 'smart-scroll-proportional) (setq smart-scroll-proportional nil))

;; The smart keys scroll buffers when pressed at the ends of lines.
;; These next two functions do the scrolling and keep point at the end
;; of line to simplify repeated scrolls when using keyboard smart keys.
;;
;; These functions may also be used to test whether the scroll action would
;; be successful, no action is taken if it would fail (because the beginning
;; or end of a buffer is already showing) and nil is returned.
;; t is returned whenever scrolling is performed.

(defun smart-scroll-down ()
  "Scrolls down according to value of smart-scroll-proportional.
If smart-scroll-proportional is nil or if point is on the bottom window line,
scrolls down (backward) a windowful.  Otherwise, tries to bring current line
to bottom of window.  Leaves point at end of line and returns t if scrolled,
nil if not."
  (interactive)
  (let ((rtn t))
    (if smart-scroll-proportional
	;; If selected line is already last in window, then scroll backward
	;; a windowful, otherwise make it last in window.
	(if (>= (point) (save-excursion
			  (goto-char (1- (window-end)))
			  (beginning-of-line) (point)))
	    (if (pos-visible-in-window-p (point-min))
		(setq rtn nil)
	      (scroll-down))
	  (recenter -1))
      (if (pos-visible-in-window-p (point-min))
	  (setq rtn nil)
	(scroll-down)))
    (end-of-line)
    (or rtn (progn (beep) (message "Beginning of buffer")))
    rtn))

(defun smart-scroll-up ()
  "Scrolls up according to value of smart-scroll-proportional.
If smart-scroll-proportional is nil or if point is on the top window line,
scrolls up (forward) a windowful.  Otherwise, tries to bring current line to
top of window.  Leaves point at end of line and returns t if scrolled, nil if
not."
  (interactive)
  (let ((rtn t))
    (if smart-scroll-proportional
	;; If selected line is already first in window, then scroll forward a
	;; windowful, otherwise make it first in window.
	(if (<= (point) (save-excursion
			  (goto-char (window-start))
			  (end-of-line) (point)))
	    (if (pos-visible-in-window-p (point-max))
		(setq rtn nil)
	      (scroll-up))
	  (recenter 0))
      (if (pos-visible-in-window-p (point-max))
	  (setq rtn nil)
	(scroll-up)))
    (end-of-line)
    (or rtn (progn (beep) (message "End of buffer")))
    rtn))

(provide 'hmouse-drv)

;;; hmouse-drv.el ends here