cgit.sxemacs.org Git - packages/blob - xemacs-packages/hyperbole/hmouse-drv.el

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