lisp/term/sup-mouse.el

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