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

   1 ;;; hmouse-reg.el --- System-dependent Smart Mouse Key bindings (no shift key).
   2
   3 ;; Copyright (C) 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 ;;; Code:
  30
  31 ;;;
  32 ;;; Public functions
  33 ;;;
  34
  35 (defun hmouse-get-bindings ()
  36   "Returns list of bindings for mouse keys prior to their use as Smart Keys."
  37   (eval
  38    (cdr (assoc
  39          ;; Get mouse bindings under Emacs 19 or XEmacs, even if not under a
  40          ;; window system since it can have frames on ttys and windowed
  41          ;; displays at the same time.
  42          (or hyperb:window-system
  43              (and (not noninteractive) hyperb:xemacs-p "xemacs")
  44              (and (not noninteractive) hyperb:emacs19-p "emacs19"))
  45          '(("emacs19" .
  46             (mapcar (function
  47                      (lambda (key) (cons key (lookup-key global-map key))))
  48                     (if (memq window-system '(ns dps))
  49                         ;; NEXTSTEP offers only 2 mouse buttons which we use
  50                         ;; as the Smart Keys.  We move the mouse-set-point
  51                         ;; command to shift-left.
  52                         '([down-mouse-1] [mouse-1] [down-mouse-2] [mouse-2]
  53                           [double-mouse-1] [triple-mouse-1]
  54                           [double-mouse-2] [triple-mouse-2]
  55                           [vertical-line down-mouse-1] [vertical-line mouse-1]
  56                           [vertical-line down-mouse-2] [vertical-line mouse-2]
  57                           [mode-line down-mouse-1] [mode-line mouse-1]
  58                           [mode-line down-mouse-2] [mode-line mouse-2]
  59                           [S-mouse-1]
  60                           )
  61                       ;; X
  62                       '([down-mouse-2] [mouse-2] [down-mouse-3] [mouse-3]
  63                         [double-mouse-2] [triple-mouse-2]
  64                         [double-mouse-3] [triple-mouse-3]
  65                         [vertical-line down-mouse-2] [vertical-line mouse-2]
  66                         [vertical-line down-mouse-3] [vertical-line mouse-3]
  67                         [mode-line down-mouse-2] [mode-line mouse-2]
  68                         [mode-line down-mouse-3] [mode-line mouse-3]
  69                         ))))
  70            ("xemacs" .
  71             (nconc
  72              (mapcar (function
  73                       (lambda (key)
  74                         (cons key (lookup-key global-map key))))
  75                      '([button2] [button2up] [button3] [button3up]))
  76              (if (boundp 'mode-line-map)
  77                  (mapcar (function
  78                           (lambda (key)
  79                             (cons key (lookup-key mode-line-map key))))
  80                          '([button3] [button3up])))))
  81            ("xterm" .
  82             (mapcar (function
  83                      (lambda (key) (cons key (lookup-key mouse-map key))))
  84                     (list x-button-middle x-button-middle-up
  85                           x-button-right  x-button-right-up)))
  86            ("epoch" .
  87             (mapcar (function
  88                      (lambda (key) (cons key (aref mouse::global-map key))))
  89                     (list (mouse::index mouse-middle mouse-down)
  90                           (mouse::index mouse-middle mouse-up)
  91                           (mouse::index mouse-right mouse-down)
  92                           (mouse::index mouse-right mouse-up)
  93                           ;; Modeline mouse map
  94                           (mouse::index mouse-mode-middle mouse-down)
  95                           (mouse::index mouse-mode-middle mouse-up)
  96                           (mouse::index mouse-mode-right mouse-down)
  97                           (mouse::index mouse-mode-right mouse-up)
  98                           )))
  99            ("next" .
 100             (mapcar (function
 101                      (lambda (key)
 102                        (cons key (mousemap-get
 103                                   (mouse-list-to-mouse-code key)
 104                                   current-global-mousemap))))
 105                     (apply 'nconc
 106                            (mapcar (function
 107                                     (lambda (region)
 108                                       (mapcar (function
 109                                                (lambda (key)
 110                                                  (cons region key)))
 111                                               '((left) (up left) (shift left)
 112                                                 (right) (up right)
 113                                                 ))))
 114                                    '(text scrollbar modeline minibuffer)))
 115                     ))
 116            ;; SunView
 117            ("sun" .
 118             (mapcar (function
 119                      (lambda (key)
 120                        (setq key (mouse-list-to-mouse-code key))
 121                        (cons key (mousemap-get
 122                                   key current-global-mousemap))))
 123                     (apply 'nconc
 124                            (mapcar (function
 125                                     (lambda (region)
 126                                       (mapcar (function
 127                                                (lambda (key)
 128                                                  (cons region key)))
 129                                               '((middle) (up middle)
 130                                                 (right) (up right)
 131                                                 ))))
 132                                    '(text scrollbar modeline minibuffer)))
 133                     ))
 134            ("apollo" .
 135             (mapcar (function
 136                      (lambda (key-str) (apollo-mouse-key-and-binding
 137                                         key-str)))
 138                     '("M2D" "M2U" "M3D" "M3U")))
 139            )))))
 140
 141 (defun hmouse-setup ()
 142   "Binds mouse keys for use as Smart Keys."
 143   (interactive)
 144   (or hmouse-bindings-flag hmouse-previous-bindings
 145       (setq hmouse-previous-bindings (hmouse-get-bindings)))
 146   ;; Ensure Gillespie's Info mouse support is off since
 147   ;; Hyperbole handles that.
 148   (setq Info-mouse-support nil)
 149   ;;
 150   (cond ;; GNU Emacs 19
 151    ((if (not noninteractive) hyperb:emacs19-p)
 152     (setq hmouse-set-point-command 'mouse-set-point)
 153     ;; Get rid of Info-mode [mouse-2] binding since Hyperbole performs
 154     ;; a superset of what it does.
 155     (add-hook 'Info-mode-hook
 156               (function (lambda () (define-key Info-mode-map [mouse-2] nil))))
 157     ;;
 158     (if (memq window-system '(ns dps))
 159         ;; NEXTSTEP offers only 2 mouse buttons which we use
 160         ;; as the Smart Keys.  We move the mouse-set-point
 161         ;; command to shift-left.
 162         (progn
 163           (global-set-key [S-down-mouse-1]      'mouse-drag-region)
 164           (global-set-key [S-mouse-1]           'mouse-set-point)
 165           (global-set-key [down-mouse-1]        'action-key-depress-emacs19)
 166           (global-set-key [mouse-1]             'action-mouse-key-emacs19)
 167           (global-set-key [double-mouse-1]      'action-mouse-key-emacs19)
 168           (global-set-key [triple-mouse-1]      'action-mouse-key-emacs19)
 169           (global-set-key [down-mouse-2]        'assist-key-depress-emacs19)
 170           (global-set-key [mouse-2]             'assist-mouse-key-emacs19)
 171           (global-set-key [double-mouse-2]      'assist-mouse-key-emacs19)
 172           (global-set-key [triple-mouse-2]      'assist-mouse-key-emacs19)
 173           (global-set-key [vertical-line down-mouse-1] 'action-key-depress-emacs19)
 174           (global-set-key [vertical-line mouse-1] 'action-mouse-key-emacs19)
 175           (global-set-key [vertical-line down-mouse-2] 'assist-key-depress-emacs19)
 176           (global-set-key [vertical-line mouse-2] 'assist-mouse-key-emacs19)
 177           (global-set-key [mode-line down-mouse-2] 'action-key-depress-emacs19)
 178           (global-set-key [mode-line mouse-2]      'action-mouse-key-emacs19)
 179           (global-set-key [mode-line down-mouse-3] 'assist-key-depress-emacs19)
 180           (global-set-key [mode-line mouse-3]   'assist-mouse-key-emacs19))
 181       ;; X
 182       (global-set-key [down-mouse-2]           'action-key-depress-emacs19)
 183       (global-set-key [mouse-2]                'action-mouse-key-emacs19)
 184       (global-set-key [double-mouse-2]         'action-mouse-key-emacs19)
 185       (global-set-key [triple-mouse-2]         'action-mouse-key-emacs19)
 186       (global-set-key [down-mouse-3]           'assist-key-depress-emacs19)
 187       (global-set-key [mouse-3]                'assist-mouse-key-emacs19)
 188       (global-set-key [double-mouse-3]         'assist-mouse-key-emacs19)
 189       (global-set-key [triple-mouse-3]         'assist-mouse-key-emacs19)
 190       (global-set-key [vertical-line down-mouse-2] 'action-key-depress-emacs19)
 191       (global-set-key [vertical-line mouse-2]      'action-mouse-key-emacs19)
 192       (global-set-key [vertical-line down-mouse-3] 'assist-key-depress-emacs19)
 193       (global-set-key [vertical-line mouse-3]      'assist-mouse-key-emacs19)
 194       (global-set-key [mode-line down-mouse-2] 'action-key-depress-emacs19)
 195       (global-set-key [mode-line mouse-2]      'action-mouse-key-emacs19)
 196       (global-set-key [mode-line down-mouse-3] 'assist-key-depress-emacs19)
 197       (global-set-key [mode-line mouse-3]      'assist-mouse-key-emacs19)))
 198    ;;
 199    ;; XEmacs
 200    ((if (not noninteractive) hyperb:xemacs-p)
 201     ;; Set mouse bindings under XEmacs, even if not under a window
 202     ;; system since it can have frames on ttys and windowed displays at
 203     ;; the same time.
 204     (setq hmouse-set-point-command 'hmouse-move-point-xemacs)
 205     ;; Get rid of Info-mode buttons 2 and 3 bindings since Hyperbole
 206     ;; handles things in Info.
 207     (add-hook 'Info-mode-hook
 208               (function (lambda ()
 209                           (define-key Info-mode-map 'button2 nil))))
 210     ;;
 211     (global-set-key 'button2     'action-key-depress)
 212     (global-set-key 'button2up   'action-mouse-key)
 213     (if (fboundp 'infodock-set-mouse-bindings)
 214         (infodock-set-mouse-bindings)
 215       (let ((unbind-but3
 216              (function (lambda ()
 217                          (define-key Info-mode-map 'button3 nil)))))
 218         (if (and (boundp 'Info-mode-map) (keymapp Info-mode-map))
 219             (funcall unbind-but3)
 220           (add-hook 'Info-mode-hook unbind-but3)))
 221       (if (boundp 'mode-line-map)
 222           (progn (define-key mode-line-map 'button3   'assist-key-depress)
 223                  (define-key mode-line-map 'button3up 'assist-mouse-key)))
 224       (global-set-key 'button3     'assist-key-depress)
 225       (global-set-key 'button3up   'assist-mouse-key)))
 226    ;;
 227    ;; X
 228    ((equal hyperb:window-system "xterm")
 229     (setq hmouse-set-point-command 'x-mouse-set-point)
 230     (define-key mouse-map x-button-middle 'action-key-depress)
 231     (define-key mouse-map x-button-middle-up 'action-mouse-key)
 232     (define-key mouse-map x-button-right 'assist-key-depress)
 233     (define-key mouse-map x-button-right-up 'assist-mouse-key)
 234     ;; Use these instead of the above for a true META-BUTTON binding.
 235     ;; (define-key mouse-map x-button-m-middle 'assist-key-depress)
 236     ;; (define-key mouse-map x-button-m-middle-up 'assist-mouse-key)
 237     )
 238    ;;
 239    ;; Epoch
 240    ((equal hyperb:window-system "epoch")
 241     (setq hmouse-set-point-command 'mouse::set-point)
 242     (global-set-mouse mouse-middle mouse-down  'action-key-depress)
 243     (global-set-mouse mouse-middle mouse-up    'action-mouse-key)
 244     (global-set-mouse mouse-right  mouse-down  'assist-key-depress)
 245     (global-set-mouse mouse-right  mouse-up    'assist-mouse-key)
 246     ;; Modeline mouse map
 247     (global-set-mouse mouse-mode-middle mouse-down  'action-key-depress)
 248     (global-set-mouse mouse-mode-middle mouse-up    'action-mouse-key)
 249     (global-set-mouse mouse-mode-right  mouse-down  'assist-key-depress)
 250     (global-set-mouse mouse-mode-right  mouse-up    'assist-mouse-key)
 251     )
 252    ;;
 253    ;; NeXT
 254    ((equal hyperb:window-system "next")
 255     (setq hmouse-set-point-command 'hmouse-move-point-eterm)
 256     ;; Use shift-left button to set point.
 257     ;; Use left button instead of non-existent middle as Smart Key.
 258     (mapcar
 259      (function
 260       (lambda (region)
 261         (global-set-mouse (cons region '(shift left)) 'mouse-move-point)
 262         (global-set-mouse (cons region '(left))       'action-key-depress)
 263         (global-set-mouse (cons region '(up left))    'action-mouse-key)
 264         (global-set-mouse (cons region '(right))      'assist-key-depress)
 265         (global-set-mouse (cons region '(up right))   'assist-mouse-key)
 266         ;; Use these instead of the above for a true META-BUTTON binding.
 267         ;; (global-set-mouse (cons region '(meta    right)) 'assist-key-depress)
 268         ;; (global-set-mouse (cons region '(meta up right)) 'assist-mouse-key)
 269         ))
 270      '(text scrollbar modeline minibuffer))
 271     )
 272    ;;
 273    ;; SunView
 274    ((equal hyperb:window-system "sun")
 275     (setq hmouse-set-point-command 'hmouse-move-point-eterm)
 276     (mapcar
 277      (function
 278       (lambda (region)
 279         (global-set-mouse (cons region '(middle))     'action-key-depress)
 280         (global-set-mouse (cons region '(up middle))  'action-mouse-key)
 281         (global-set-mouse (cons region '(right))      'assist-key-depress)
 282         (global-set-mouse (cons region '(up right))   'assist-mouse-key)
 283         ;; Use these instead of the above for a true META-BUTTON binding.
 284         ;; (global-set-mouse (cons region '(meta    middle)) 'assist-key-depress)
 285         ;; (global-set-mouse (cons region '(meta up middle)) 'assist-mouse-key)
 286         ))
 287      '(text scrollbar modeline minibuffer))
 288     )
 289    ;;
 290    ;; Apollo DM
 291    ((equal hyperb:window-system "apollo")
 292     (setq hmouse-set-point-command 'apollo-mouse-move-point)
 293     (bind-apollo-mouse-button "M2D" 'action-key-depress)
 294     (bind-apollo-mouse-button "M2U" 'action-mouse-key)
 295     (bind-apollo-mouse-button "M3D" 'assist-key-depress)
 296     (bind-apollo-mouse-button "M3U" 'assist-mouse-key)
 297     ;; Use these instead of the above for a true META-BUTTON binding.
 298     ;; (bind-apollo-mouse-button "M2U" 'action-mouse-key
 299     ;;  'assist-mouse-key)
 300     ;; (bind-apollo-mouse-button "M2D" 'action-key-depress 'assist-key-depress)
 301     ))
 302   (setq hmouse-bindings (hmouse-get-bindings)
 303         hmouse-bindings-flag t))
 304
 305 ;;; hmouse-reg.el ends here