lisp/term/sup-mouse.el

   1 ;;; sup-mouse.el --- supdup mouse support for lisp machines
   2
   3 ;; Copyright (C) Free Software Foundation 1985, 1986
   4
   5 ;; Author: Wolfgang Rupprecht
   6 ;; Maintainer: FSF
   7 ;; Created: 21 Nov 1986
   8 ;; Keywords: hardware
   9
  10 ;;     (from code originally written by John Robinson@bbn for the bitgraph)
  11
  12 ;; This file is part of GNU Emacs.
  13
  14 ;; GNU Emacs is free software; you can redistribute it and/or modify
  15 ;; it under the terms of the GNU General Public License as published by
  16 ;; the Free Software Foundation; either version 2, or (at your option)
  17 ;; any later version.
  18
  19 ;; GNU Emacs is distributed in the hope that it will be useful,
  20 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  21 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  22 ;; GNU General Public License for more details.
  23
  24 ;; You should have received a copy of the GNU General Public License
  25 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  26 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  27
  28 ;;; Code:
  29
  30 ;;;  User customization option:
  31
  32 (defvar sup-mouse-fast-select-window nil
  33   "*Non-nil for mouse hits to select new window, then execute; else just select.")
  34
  35 (defconst mouse-left 0)
  36 (defconst mouse-center 1)
  37 (defconst mouse-right 2)
  38
  39 (defconst mouse-2left 4)
  40 (defconst mouse-2center 5)
  41 (defconst mouse-2right 6)
  42
  43 (defconst mouse-3left 8)
  44 (defconst mouse-3center 9)
  45 (defconst mouse-3right 10)
  46
  47 ;;;  Defuns:
  48
  49 (defun sup-mouse-report ()
  50   "This function is called directly by the mouse, it parses and
  51 executes the mouse commands.
  52
  53  L move point          *  |---- These apply for mouse click in a window.
  54 2L delete word            |
  55 3L copy word              | If sup-mouse-fast-select-window is nil,
  56  C move point and yank *  | just selects that window.
  57 2C yank pop               |
  58  R set mark            *  |
  59 2R delete region          |
  60 3R copy region            |
  61
  62 on modeline                 on \"scroll bar\"   in minibuffer
  63  L scroll-up                line to top         execute-extended-command
  64  C proportional goto-char   line to middle      mouse-help
  65  R scroll-down              line to bottom      eval-expression"
  66
  67   (interactive)
  68   (let*
  69 ;; expect a string of <esc>:<buttons>;<x-pos>;<y-pos>c
  70       ((buttons (sup-get-tty-num ?\;))
  71        (x (sup-get-tty-num ?\;))
  72        (y (sup-get-tty-num ?c))
  73        (window (sup-pos-to-window x y))
  74        (edges (window-edges window))
  75        (old-window (selected-window))
  76        (in-minibuf-p (eq y (1- (frame-height))))
  77        (same-window-p (and (not in-minibuf-p) (eq window old-window)))
  78        (in-modeline-p (eq y (1- (nth 3 edges))))
  79        (in-scrollbar-p (>= x (1- (nth 2 edges)))))
  80     (setq x (- x (nth 0 edges)))
  81     (setq y (- y (nth 1 edges)))
  82
  83 ;    (error "mouse-hit %d %d %d" buttons x y) ;;;; debug
  84
  85     (cond (in-modeline-p
  86            (select-window window)
  87            (cond ((= buttons mouse-left)
  88                   (scroll-up))
  89                  ((= buttons mouse-right)
  90                   (scroll-down))
  91                  ((= buttons mouse-center)
  92                   (goto-char (/ (* x
  93                                    (- (point-max) (point-min)))
  94                                 (1- (window-width))))
  95                   (beginning-of-line)
  96                   (what-cursor-position)))
  97            (select-window old-window))
  98           (in-scrollbar-p
  99            (select-window window)
 100            (scroll-up
 101             (cond ((= buttons mouse-left)
 102                    y)
 103                   ((= buttons mouse-right)
 104                    (+ y (- 2 (window-height))))
 105                   ((= buttons mouse-center)
 106                    (/ (+ 2 y y (- (window-height))) 2))
 107                   (t
 108                    0)))
 109            (select-window old-window))
 110           (same-window-p
 111            (cond ((= buttons mouse-left)
 112                   (sup-move-point-to-x-y x y))
 113                  ((= buttons mouse-2left)
 114                   (sup-move-point-to-x-y x y)
 115                   (kill-word 1))
 116                  ((= buttons mouse-3left)
 117                   (sup-move-point-to-x-y x y)
 118                   (save-excursion
 119                     (copy-region-as-kill
 120                      (point) (progn (forward-word 1) (point))))
 121                   (setq this-command 'yank)
 122                   )
 123                  ((= buttons mouse-right)
 124                   (push-mark)
 125                   (sup-move-point-to-x-y x y)
 126                   (exchange-point-and-mark))
 127                  ((= buttons mouse-2right)
 128                   (push-mark)
 129                   (sup-move-point-to-x-y x y)
 130                   (kill-region (mark) (point)))
 131                  ((= buttons mouse-3right)
 132                   (push-mark)
 133                   (sup-move-point-to-x-y x y)
 134                   (copy-region-as-kill (mark) (point))
 135                   (setq this-command 'yank))
 136                  ((= buttons mouse-center)
 137                   (sup-move-point-to-x-y x y)
 138                   (setq this-command 'yank)
 139                   (yank))
 140                  ((= buttons mouse-2center)
 141                   (yank-pop 1))
 142                  )
 143            )
 144           (in-minibuf-p
 145            (cond ((= buttons mouse-right)
 146                   (call-interactively 'eval-expression))
 147                  ((= buttons mouse-left)
 148                   (call-interactively 'execute-extended-command))
 149                  ((= buttons mouse-center)
 150                   (describe-function 'sup-mouse-report)); silly self help
 151                  ))
 152           (t                            ;in another window
 153            (select-window window)
 154            (cond ((not sup-mouse-fast-select-window))
 155                  ((= buttons mouse-left)
 156                   (sup-move-point-to-x-y x y))
 157                  ((= buttons mouse-right)
 158                   (push-mark)
 159                   (sup-move-point-to-x-y x y)
 160                   (exchange-point-and-mark))
 161                  ((= buttons mouse-center)
 162                   (sup-move-point-to-x-y x y)
 163                   (setq this-command 'yank)
 164                   (yank))
 165                  ))
 166           )))
 167 \f
 168
 169 (defun sup-get-tty-num (term-char)
 170   "Read from terminal until TERM-CHAR is read, and return intervening number.
 171 Upon non-numeric not matching TERM-CHAR signal an error."
 172   (let
 173       ((num 0)
 174        (char (read-char)))
 175     (while (and (>= char ?0)
 176                 (<= char ?9))
 177       (setq num (+ (* num 10) (- char ?0)))
 178       (setq char (read-char)))
 179     (or (eq term-char char)
 180         (error "Invalid data format in mouse command"))
 181     num))
 182
 183 (defun sup-move-point-to-x-y (x y)
 184   "Position cursor in window coordinates.
 185 X and Y are 0-based character positions in the window."
 186   (move-to-window-line y)
 187   (move-to-column x)
 188   )
 189
 190 (defun sup-pos-to-window (x y)
 191   "Find window corresponding to frame coordinates.
 192 X and Y are 0-based character positions on the frame."
 193   (let ((edges (window-edges))
 194         (window nil))
 195     (while (and (not (eq window (selected-window)))
 196                 (or (<  y (nth 1 edges))
 197                     (>= y (nth 3 edges))
 198                     (<  x (nth 0 edges))
 199                     (>= x (nth 2 edges))))
 200       (setq window (next-window window))
 201       (setq edges (window-edges window))
 202       )
 203     (or window (selected-window))
 204     )
 205   )
 206
 207 ;;; sup-mouse.el ends here