sup-mouse.el 6.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209
  1. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2. ;; ;;
  3. ;; File: sup-mouse.el ;;
  4. ;; Author: Wolfgang Rupprecht ;;
  5. ;; Created: Fri Nov 21 19:22:22 1986 ;;
  6. ;; Contents: supdup mouse support for lisp machines ;;
  7. ;; ;;
  8. ;; (from code originally written by John Robinson@bbn for the bitgraph) ;;
  9. ;; ;;
  10. ;; $Log$ ;;
  11. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  12. ;; GNU Emacs code for lambda/supdup mouse
  13. ;; Copyright (C) Free Software Foundation 1985, 1986
  14. ;; This file is part of GNU Emacs.
  15. ;; GNU Emacs is distributed in the hope that it will be useful,
  16. ;; but WITHOUT ANY WARRANTY. No author or distributor
  17. ;; accepts responsibility to anyone for the consequences of using it
  18. ;; or for whether it serves any particular purpose or works at all,
  19. ;; unless he says so in writing. Refer to the GNU Emacs General Public
  20. ;; License for full details.
  21. ;; Everyone is granted permission to copy, modify and redistribute
  22. ;; GNU Emacs, but only under the conditions described in the
  23. ;; GNU Emacs General Public License. A copy of this license is
  24. ;; supposed to have been given to you along with GNU Emacs so you
  25. ;; can know your rights and responsibilities. It should be in a
  26. ;; file named COPYING. Among other things, the copyright notice
  27. ;; and this notice must be preserved on all copies.
  28. ;;; User customization option:
  29. (defvar sup-mouse-fast-select-window nil
  30. "*Non-nil for mouse hits to select new window, then execute; else just select.")
  31. (defconst mouse-left 0)
  32. (defconst mouse-center 1)
  33. (defconst mouse-right 2)
  34. (defconst mouse-2left 4)
  35. (defconst mouse-2center 5)
  36. (defconst mouse-2right 6)
  37. (defconst mouse-3left 8)
  38. (defconst mouse-3center 9)
  39. (defconst mouse-3right 10)
  40. ;;; Defuns:
  41. (defun sup-mouse-report ()
  42. "This function is called directly by the mouse, it parses and
  43. executes the mouse commands.
  44. L move point * |---- These apply for mouse click in a window.
  45. 2L delete word |
  46. 3L copy word | If sup-mouse-fast-select-window is nil,
  47. C move point and yank * | just selects that window.
  48. 2C yank pop |
  49. R set mark * |
  50. 2R delete region |
  51. 3R copy region |
  52. on modeline on \"scroll bar\" in minibuffer
  53. L scroll-up line to top execute-extended-command
  54. C proportional goto-char line to middle mouse-help
  55. R scroll-down line to bottom eval-expression"
  56. (interactive)
  57. (let*
  58. ;; expect a string of <esc>:<buttons>;<x-pos>;<y-pos>c
  59. ((buttons (sup-get-tty-num ?\;))
  60. (x (sup-get-tty-num ?\;))
  61. (y (sup-get-tty-num ?c))
  62. (window (sup-pos-to-window x y))
  63. (edges (window-edges window))
  64. (old-window (selected-window))
  65. (in-minibuf-p (eq y (1- (screen-height))))
  66. (same-window-p (and (not in-minibuf-p) (eq window old-window)))
  67. (in-modeline-p (eq y (1- (nth 3 edges))))
  68. (in-scrollbar-p (>= x (1- (nth 2 edges)))))
  69. (setq x (- x (nth 0 edges)))
  70. (setq y (- y (nth 1 edges)))
  71. ; (error "mouse-hit %d %d %d" buttons x y) ;;;; debug
  72. (cond (in-modeline-p
  73. (select-window window)
  74. (cond ((= buttons mouse-left)
  75. (scroll-up))
  76. ((= buttons mouse-right)
  77. (scroll-down))
  78. ((= buttons mouse-center)
  79. (goto-char (/ (* x
  80. (- (point-max) (point-min)))
  81. (1- (window-width))))
  82. (beginning-of-line)
  83. (what-cursor-position)))
  84. (select-window old-window))
  85. (in-scrollbar-p
  86. (select-window window)
  87. (scroll-up
  88. (cond ((= buttons mouse-left)
  89. y)
  90. ((= buttons mouse-right)
  91. (+ y (- 2 (window-height))))
  92. ((= buttons mouse-center)
  93. (/ (+ 2 y y (- (window-height))) 2))
  94. (t
  95. 0)))
  96. (select-window old-window))
  97. (same-window-p
  98. (cond ((= buttons mouse-left)
  99. (sup-move-point-to-x-y x y))
  100. ((= buttons mouse-2left)
  101. (sup-move-point-to-x-y x y)
  102. (kill-word 1))
  103. ((= buttons mouse-3left)
  104. (sup-move-point-to-x-y x y)
  105. (save-excursion
  106. (copy-region-as-kill
  107. (point) (progn (forward-word 1) (point))))
  108. (setq this-command 'yank)
  109. )
  110. ((= buttons mouse-right)
  111. (push-mark)
  112. (sup-move-point-to-x-y x y)
  113. (exchange-point-and-mark))
  114. ((= buttons mouse-2right)
  115. (push-mark)
  116. (sup-move-point-to-x-y x y)
  117. (kill-region (mark) (point)))
  118. ((= buttons mouse-3right)
  119. (push-mark)
  120. (sup-move-point-to-x-y x y)
  121. (copy-region-as-kill (mark) (point))
  122. (setq this-command 'yank))
  123. ((= buttons mouse-center)
  124. (sup-move-point-to-x-y x y)
  125. (setq this-command 'yank)
  126. (yank))
  127. ((= buttons mouse-2center)
  128. (yank-pop 1))
  129. )
  130. )
  131. (in-minibuf-p
  132. (cond ((= buttons mouse-right)
  133. (call-interactively 'eval-expression))
  134. ((= buttons mouse-left)
  135. (call-interactively 'execute-extended-command))
  136. ((= buttons mouse-center)
  137. (describe-function 'sup-mouse-report)); silly self help
  138. ))
  139. (t ;in another window
  140. (select-window window)
  141. (cond ((not sup-mouse-fast-select-window))
  142. ((= buttons mouse-left)
  143. (sup-move-point-to-x-y x y))
  144. ((= buttons mouse-right)
  145. (push-mark)
  146. (sup-move-point-to-x-y x y)
  147. (exchange-point-and-mark))
  148. ((= buttons mouse-center)
  149. (sup-move-point-to-x-y x y)
  150. (setq this-command 'yank)
  151. (yank))
  152. ))
  153. )))
  154. (defun sup-get-tty-num (term-char)
  155. "Read from terminal until TERM-CHAR is read, and return intervening number.
  156. Upon non-numeric not matching TERM-CHAR signal an error."
  157. (let
  158. ((num 0)
  159. (char (read-char)))
  160. (while (and (>= char ?0)
  161. (<= char ?9))
  162. (setq num (+ (* num 10) (- char ?0)))
  163. (setq char (read-char)))
  164. (or (eq term-char char)
  165. (error "Invalid data format in mouse command"))
  166. num))
  167. (defun sup-move-point-to-x-y (x y)
  168. "Position cursor in window coordinates.
  169. X and Y are 0-based character positions in the window."
  170. (move-to-window-line y)
  171. (move-to-column x)
  172. )
  173. (defun sup-pos-to-window (x y)
  174. "Find window corresponding to screen coordinates.
  175. X and Y are 0-based character positions on the screen."
  176. (let ((edges (window-edges))
  177. (window nil))
  178. (while (and (not (eq window (selected-window)))
  179. (or (< y (nth 1 edges))
  180. (>= y (nth 3 edges))
  181. (< x (nth 0 edges))
  182. (>= x (nth 2 edges))))
  183. (setq window (next-window window))
  184. (setq edges (window-edges window))
  185. )
  186. (or window (selected-window))
  187. )
  188. )