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

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