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

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