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