;;; vt-mouse.el --- Video Terminal Mouse support ;; ;; Copyright (C) 2007 Free Software Foundation, Inc. ;; Copyright (C) 2001-2006 Devon Sean McCullough ;; ;; Authors: Devon Sean McCullough 2001-2007 ;; Daniel Dean Badger 2007 ;; Maintainers: ;; Created: 2001 ;; Version: 0.7 ;; Keywords: menu, mouse, scroll, terminal, terminals ;; This file is part of GNU Emacs. ;; GNU Emacs is free software; you can redistribute it and/or modify ;; it under the terms of the GNU General Public License as published by ;; the Free Software Foundation; either version 2, or (at your option) ;; any later version. ;; GNU Emacs is distributed in the hope that it will be useful, ;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ;; GNU General Public License for more details. ;; You should have received a copy of the GNU General Public License ;; along with GNU Emacs; see the file COPYING. If not, write to the ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, ;; Boston, MA 02110-1301, USA. ;; Fodder: ;; ;; ;;; xt-mouse.el --- support the mouse when emacs run in an xterm ;; ;; Author: Per Abrahamsen 1994 ;; ;;; Commentary: ;; Package to interpret mouse actions from raw escape sequences into ;; standard Emacs command events, providing basic mouse functionality ;; when using Emacs without a window-manager, insofar as the terminal ;; emulator and/or remote window-manager permit. ;; Implemented features include resize of window by dragging on its ;; mode-line, vertical-line, or header-line, in addition to fundamental ;; mouse-sensatized menu-bar access, along with most standard positioning ;; and highlighting X-Window System defaults. ;;; The scroll wheel has a crude acceleration curve ;;; and shift/control do scroll slower/faster. ;;; For your .emacs init file: ;; ;; ; (setq vt-custom ':swap) ; uncomment for two-button mouse ;; ;; ;; To start `vt-mouse' when not using window-system: ;; ;; (unless window-system (require 'vt-mouse)) ;; ;;; or, depending on installation, ;; ;; (vt-mouse-mode 1) ; affects nothing if using a window-system ;; ;;; or possibly nothing, needed on sites where `vt-mouse' is required ;;; automatically upon finding no `window-system'; enables `vt-mouse-mode'. ;;; Also recommended ;; (transient-mark-mode 1) ; Highlight region. ;; ;;; Alternatively, autoload ;; ; (setq vt-custom '(...)) ; see vt-custom for option doc ;; (global-set-key "\e[M" 'vt-mouse-prefix) ;; (autoload 'vt-mouse-prefix "vt-mouse" "Video Terminal Mouse." t)) ;; Video Terminal mouse click, double, triple, drag, wheel, etc. support ;; Some (require 'mouse) commands should also work with this library. ; [down-mouse-1] vt-mouse-set-point ; [drag-mouse-1] vt-mouse-drag-region ; [double-mouse-1] vt-mouse-mark-thing ; [triple-mouse-1] vt-mouse-mark-line ; [M-mouse-1] vt-mouse-find-thing ; [C-mouse-1] vt-mouse-insert-thing ; Scroll Wheel Previous vt-scroll-previous ; Scroll Wheel Next vt-scroll-next ;; M-x vt-mouse RET enable/disable VT Mouse ;; M-2 M-x vt-mouse RET two button mouse ;; M-3 M-x vt-mouse RET three button mouse (default) ;; C-u M-x vt-mouse RET bypass GNU SCREEN bug ;; M-x vt-window-title RET hack window title ;; M-x vt-enable-meta RET 8th TTY bit as meta ;; M-: (vt-input-mode) RET hack TTY input modes ;; M-: (vt-input-mode ':meta 0) 8-bit TTY chars as data ;;; COMPATIBILITY ; Apple Terminal 1.5 no no mouse support but Option-click can send arrow keys ; Gnome Terminal 2.10 ok grabs s- m- c- but sends ms- cs- ; PuTTY Beta 0.5 ok grabs s- ; Screen 4.00 ok see vt-custom :bypass for older version workaround ; SecureCRT ok no scroll wheel support ; xterm ok grabs s- c-, also window manager might grab m- ;;; HISTORY ; 2007 Wed Mar 14 21:03 EDT badger initial section of vt-menu.el from vt-mouse.el ; 2007 Feb 18 Sun 17:00 EST badger add mouse menu interface to tmm ; 2006 Oct 24 Tue 03:01 EDT devon quote ':keywords for older emacsen ; 2006 May 24 Wed 12:17 EDT devon test terminals, add options and doc ; 2006 Mar 23 Thu 19:52 EST devon minor cleanup, screen-height => frame-height ; 2005 Jun 30 Thu 06:18 EDT devon mouse-wheel-scroll-amount, separate design notes ; 2005 Feb 09 Wed 07:12 EST devon fix scroll wheel, mouse roller scrolling works now ; 2004 Feb 09 Mon 17:40 EST devon double/triple click bindings, disable when leaving ; 2003 Aug 24 Sun 18:05 EDT devon double click ; 2003 Jul 28 Mon 10:12 EDT devon fix EOL/EOB bug ; 2003 Jul 15 Tue 13:20 EDT devon fix INFO header bug ; 2003 May 22 Thu 09:42 EDT devon past EOB gets EOB-1 ; 2002 May 12 Sun 20:28 EDT devon mostly works in emacs-21.1 ; 2001 Oct 03 Wed 15:27 EDT devon loses big in splitscreen ; 2001 Mar 31 Sat 23:01 EST devon works with SCRT ; 2001 Mar 31 Sat 22:49 EST devon does not work with SCRT ;;; BUGS in ELISP code ; TERM=cons25 screen ??? disables vt-input-mode :meta ??? ; down-mouse-1 does nothing in emacs 20 ; knows not of windows shifted right by GDB => pointer ; drag loses, should be easy fix ; click on text sometimes errs as menu-bar ; because unix cooked tty driver eats C-M-g code for column 102. ; Workarounds possible but idiosyncratic and erratic. ;;; TODO ; MacOS PuTTY or hack MacOS Terminal to send mouse events ; invent esc seq and hack PuTTY to auto sync kill ring with cut/paste buffer ; vt-cmg-esc-102-bug workaround test on various platforms -- any volunteers? ;;; TODO in ELISP ; more and smarter commands, e.g., double and triple drag ; merge with mouse.el, mwheel.el and xt-mouse.el ; defcustom user preferences ; vt-custom ; support mwheel.el customization variables ; mouse-wheel-follow-mouse -- can any terminal support this? ; mouse-wheel-inhibit-click-time -- does anybody want this? ; mouse-wheel-progessive-speed -- can anybody spell this? ;;; TODO in C code ; (mouse-at x y) make mouse event. Drag? Motion? Optional window config? ; (interactive "~") undo or inhibit echo hosing window config, e.g., minibuf gone. ; (interactive "E") mouse set point, e.g., same "@E" command handles mouse and key sequence. ;;; Code: ;; (require 'mouse) ; broken in emacs 21.3.50 ;; (require 'mwheel) ; untested (defvar vt-saved-keyboard-translate-table nil "best cleared using vt-suite") (defvar vt-mouse-loading t "inform any requirements") ;; get sub-requirement definitions for vt-menu and auxillary support (require 'vt-aux) ; vt hacks and debug support (require 'vt-menu) ; vt-mouse supported menu-bar access ;;; Video Terminal mouse customization options (defgroup vt-mouse () "Video Terminal (VT100, PuTTY, xterm, ...) mouse click, double, triple, drag, wheel, etc. support" :tag "Video Terminal Mouse" :prefix "vt-mouse-" :group 'mouse) ;;; customizable user preferences (defvar vt-custom '(:noswap :enable :disable :bind :detect :nobypass) "Initializations to perform when loading vt-mouse, either a keyword or list of keyword options to swap middle and right buttons :noswap three button mouse :swap two button mouse enable remote mouse clicks when emacs starts, :enable set remote mouse mode :noenable no action disable remote mouse clicks when emacs stops, :disable install hooks :nodisable no action bind mouse events to vt-mouse commands, :bind add bindings :nobind no action detect the column 102 C-M-g ESC syndrome, :detect beep rather than spazz :nodetect let it lose bypass older versions of gnu screen :nobypass normal operation :bypass prompt for real TTY device nil or void gets the defaults listed first in each section. Keyword :no gets all options named with a :no prefix. \(vt-init vt-custom) ; to re-initialize.") (defvar vt-two-button-mouse nil "Swap mouse keys 2 and 3 as most two-button mouse users prefer.") (defvar vt-cmg-esc-102-bug nil ;; Detect ESC [ M SPC C-M-g ESC syndrome where unix ;; receives ESC [ M SPC C-M-g * ESC [ M # C-M-g * but ;; the raw tty driver drops characters after the C-M-g ;; in a characteristic pattern. The * row number ;; is dropped so the only recovery is to ignore. "Workaround column 102 bug by detecting a common syndrome which typically manifests in PuTTY running under MS-W95. Other video terminals and systems will likely manifest different syndromes which may be harder to detect.") ;;; internal state (defvar vt-mouse-bypass-tty nil ;; Gnu ``screen'' prior to version 4 requires this workaround "NIL or name of real TTY device to work around older versions of gnu ``screen'' which don't support mouse escape sequences. To get the device name, run ``tty'' before you run ``screen'' or while suspended or detached.") (defvar vt-mouse-active nil "Non-nil means user wants Video Terminal mouse clicks for Emacs.") (defvar vt-mouse-counter 0 "Kludge counts number of mouse blips seen.") (defvar vt-mouse-last-k -1) ; for drag, double-click, etc. (defvar vt-mouse-last-x -1) (defvar vt-mouse-last-y -1) (defvar vt-mouse-down-time 0) (defvar vt-mouse-down-count 0) (defvar vt-mouse-last-event '()) (defvar vt-mouse-last-position '()) (defvar vt-mouse-prior-position '()) (defvar vt-menu-original-mode nil) ; for vt-menu-mode status rollback ;;; Gnu ``screen'' documents various VT100/ANSI modes ESC [ ... h/l ;;; ?9 X10 mouse tracking ;;; ?1000 (V) VT200 mouse tracking ;;; maybe subtly wrong, cannot mix ESC [ ? with ESC [ as I recall. ;;; todo: check obscure termcap boolean ;;; XT Terminal understands special xterm sequences (OSC, mouse tracking). ;;; Also, in screen/ansi.c ;;; case 1000: /* VT200 mouse tracking */ ;;; case 1001: /* VT200 highlight mouse */ ;;; case 1002: /* button event mouse*/ ;;; case 1003: /* any event mouse*/ (defvar vt-mouse-enable-string "\e[?1000h" "Video Terminal command to send mouse clicks to EMACS.") (defvar vt-mouse-disable-string "\e[?1000l" "Video Terminal command to processs mouse clicks locally.") (defvar vt-mouse-bait-flag nil "Cleared before down-mouse- events and set by `vt-mouse-bait-handler' so t if bait not taken, nil if a down-mouse- handler ate the bait. Mouse down and release events come in pairs so we follow every down-mouse- event with a vt-mouse-bait event as a proxy for the release event which we expect soon. This protects the first character of the release sequence from getting eaten by a down-mouse- handler attempting to discard the following release event. May lose if a down-mouse- event handler looks at the bait instead of flushing it, e.g., mouse motion tracking is not supported and would lose.") (defun vt-finish-redisplay () "Wait until redisplay is complete." (if (boundp 'redisplay-dont-pause) (let ((redisplay-dont-pause t)) (sit-for 0)) ;; pre emacs 21 loses, no known workaround yet (sit-for 0))) ;;; util (defun vt-mouse (&optional mode bypass interactive) "Video Terminal mouse clicks for emacs, e.g., xterm, putty, ... Positive MODE enables, negative disables, otherwise toggle; 2 also sets `vt-two-button-mouse' and 3 clears it. C-u prefix or non-nil BYPASS prompts for a tty/pty/sty device to bypass older versions of gnu ``screen'' lacking mouse support. Non-nil INTERACTIVE for status message." (interactive (list (and current-prefix-arg (prefix-numeric-value current-prefix-arg)) (consp current-prefix-arg) t)) (while bypass (let* ((insert-default-directory t) (tty (read-file-name "bypass to TTY device: (default cancels bypass) " "/dev/" "" t))) (or (file-regular-p tty) (setq vt-mouse-bypass-tty (and (not (string= "" tty)) tty) bypass nil)))) (vt-mouse-control (setq vt-mouse-active (cond ((or (not (numberp mode)) (zerop mode)) (not vt-mouse-active)) ((= 2 mode) (setq vt-two-button-mouse t) t) ((= 3 mode) (setq vt-two-button-mouse nil) t) (t (< 0 mode))))) (if vt-mouse-active ;; activate minor mode (and (not vt-mouse-mode) (vt-mouse-mode 1)) ;; deactivate minor-mode (and vt-mouse-mode (vt-mouse-mode 0))) (if interactive (message "VT Mouse %s" (if vt-mouse-active 'enabled 'disabled)))) (defun vt-mouse-control (active) "ACTIVE t/nil sends raw enable/disable command to Video Terminal." (let ((escape-sequence (if active vt-mouse-enable-string vt-mouse-disable-string))) (cond ((not vt-mouse-bypass-tty) (send-string-to-terminal escape-sequence)) ((file-regular-p vt-mouse-bypass-tty) (error "%s is not a valid vt-mouse-bypass-tty" vt-mouse-bypass-tty)) (t ;; emacs cannot output directly to a device (call-process "/bin/sh" nil nil nil "-c" (format "echo -n '%s' > %s" escape-sequence vt-mouse-bypass-tty)))))) (defun vt-mouse-start-hook () "Remote mouse mode as needed when emacs resumes." (if vt-mouse-active (vt-mouse-control t))) (defun vt-mouse-stop-hook () "Local mouse mode when emacs stops." (if vt-mouse-active (vt-mouse-control nil))) (defun read-octet-exclusive () "Like read-char-exclusive but returns a binary 8-bit byte" ;; maybe use read-char instead ??? ;; should caller zero bind echo-keystrokes ??? ;; read-char-exclusive hacks the meta bit, undo that ;; by treating any and all modifier bits as if meta. ;; thus #x99 ==> Meta-#x19 ==> #xF8000019 ==> #x99 (let* ((c (read-char-exclusive nil nil)) (b (logand 255 c)) (d (if (= c b) b (logior 128 b)))) ;(vt-debug-message "{%c %x -> %c %x -> %c %x}" c c b b d d) d)) ; /usr/local/info/elisp ; Click Events ; You can also use prefixes `A-', `C-', `H-', `M-', `S-' and `s-' ; for modifiers alt, control, hyper, meta, shift and super, just as ; you would with function keys. (defun vt-mouse-event-type (k) "Compute event type from mouse key code K, nil for up events" (let ((button (aref (if vt-two-button-mouse ["1" "3" "2" nil] ["1" "2" "3" nil]) (logand k 3)))) (and button (let* ((bits (concat (if (zerop (logand k 96)) "" "R-") ; #b1100000 for scroll wheel (or #b10... or #b01...) (if (zerop (logand k 16)) "" "C-") (if (zerop (logand k 8)) "" "M-") (if (zerop (logand k 4)) "" "S-"))) (down (intern (concat bits "down-mouse-" button))) (drag (intern (concat bits "drag-mouse-" button))) (click (intern (concat bits "mouse-" button))) (double-down (intern (concat bits "double-down-mouse-" button))) (double-drag (intern (concat bits "double-drag-mouse-" button))) (double-click (intern (concat bits "double-mouse-" button))) (triple-down (intern (concat bits "triple-down-mouse-" button))) (triple-drag (intern (concat bits "triple-drag-mouse-" button))) (triple-click (intern (concat bits "triple-mouse-" button)))) (put down 1 down) (put down 2 double-down) (put down 3 triple-down) (put down 'vt-mouse-drag drag) (put double-down 'vt-mouse-drag double-drag) (put triple-down 'vt-mouse-drag triple-drag) (put down 'vt-mouse-click click) (put double-down 'vt-mouse-click double-click) (put triple-down 'vt-mouse-click triple-click) down)))) (defun vt-mouse-event-posn (x y window) "Given X, Y character coordinates of click in frame of WINDOW, return posn structure (window pos (hpos . vpos) time) where window's buffer's keymaps should bind us to a command, pos is the character position of a text area click and hpos, vpos are character coordinates in window, otherwise pos is a symbol naming the area clicked, one of mode-line header-line left-fringe right-fringe vertical-line or nil for a click outside the window or not a live window." (let ((time (setq vt-mouse-counter (1+ vt-mouse-counter))) ; timeless for now ??? (where (or (and (window-live-p window) (coordinates-in-window-p (cons x y) window)) (let ((menu-lines (frame-parameter (selected-frame) 'menu-bar-lines))) (if (and (numberp menu-lines) (plusp menu-lines) (< y menu-lines)) 'menu-bar nil))))) (vt-debug-message "coordinates-in-window-p %S %S %S = %S\nlast-input-event = %S\n(this-command-keys) = %S" x y window where last-input-event (this-command-keys)) (if (symbolp where) (cond ((eq 'header-line where) (let ((wxy (coordinates-in-window-p (cons x (1+ y)) window))) (or (consp wxy) (error "bug confused by header-line")) (list window where (cons (car wxy) (1- (cdr wxy))) time (list (if (symbolp header-line-format) (symbol-value header-line-format) header-line-format))))) ((eq 'mode-line where) (let ((wxy (coordinates-in-window-p (cons x (1- y)) window))) (or (consp wxy) (error "bug confused by mode-line")) (list window where (cons (car wxy) (1+ (cdr wxy))) time (list (if (symbolp mode-line-format) (symbol-value mode-line-format) mode-line-format))))) ((eq 'menu-bar where) (list window where (cons x y) time)) ((eq 'vertical-line where) (list window where (coordinates-in-window-p (cons (1- x) y) window) time)) ((null where) (error "mouse click [%d,%d] not in live window %S" x y window)) (t (list window where 'vt-mouse-unknown-x-y time))) ;; consp where (set-buffer (window-buffer window)) (let* ((hscroll (window-hscroll window)) (motion (compute-motion (window-start window) (if (and (boundp 'header-line-format) header-line-format) '(0 . 1) '(0 . 0)) (point-max) (if (zerop hscroll) where (setcar where (1+ (car where))) where) (1- (window-width window)) (cons hscroll 0) ; what is the mysterious TAB-OFFSET ??? window)) (pos (car motion)) (hpos (cadr motion)) (vpos (nth 2 motion)) (prevhpos (nth 3 motion)) (contin (nth 4 motion))) (vt-debug-message "[%s %s] PREV = %s HPOS = %s CONTIN = %s" (car where) (cdr where) prevhpos hpos contin) ;; fix click-past-EOL and click-past-TAB/^G/\007 [note setcar above] ;; loses on wrapped TAB/^G so maybe CONTIN not totally useless ??? (if (or (< (cdr where) vpos) (and (< (1+ prevhpos) hpos) (< (car where) hpos))) (setq pos (1- pos))) (list window pos (cons hpos vpos) time))))) (defun vt-enable-meta () "Enable 8th bit as Meta so you can click wide lines in PuTTY, SecureCRT, etc. and input control-meta keys. Try this if you can't click beyond column 94." (interactive) (vt-input-mode ':meta t)) (defun vt-input-mode (&rest &key) "Set specified terminal input modes by name, e.g., how and whether to accept 7 or 8 bit input Combine `set-input-mode' and `current-input-mode' to fix incorrect termcap/terminfo initialization specify &key style :keyword value pair without changing other modes. To set input modes \(vt-input-mode ':meta t) ; accept 8th bit as Meta key \(vt-input-mode ':meta 0) ; accept 8-bit characters \(vt-input-mode ':meta nil) ; ignore 8th bit \(vt-input-mode ':quit ?\C-G) ; Control-G signal QUIT \(vt-input-mode ':interrupt nil ; CBREAK input ':flow t) ; with ^Q/^S XON/XOFF To get input modes \(vt-input-mode) ; get (interrupt flow meta quit) as a list." (let* ((keylist &key) (mode (current-input-mode)) (interrupt (nth 0 mode)) (flow (nth 1 mode)) (meta (nth 2 mode)) (quit (nth 3 mode))) (while keylist (or (and (consp keylist) (consp (cdr keylist))) (error "improper &key list %S" &key)) (cond ((eq (car keylist) ':interrupt) (setq interrupt (cadr keylist))) ((eq (car keylist) ':flow) (setq flow (cadr keylist))) ((eq (car keylist) ':meta) (setq meta (cadr keylist))) ((eq (car keylist) ':quit) (setq quit (cadr keylist))) (t (error "unknown &key %S" (car keylist)))) (setq keylist (cddr keylist))) (set-input-mode interrupt flow meta quit)) (current-input-mode)) ;;; mode ;; this wrapper produces the right results from `mouse-position' when ;; using `vt-mouse-mode' -- actually only informs of last action location (defun vt-mouse-position (&optional mouse-position) "Provides correct result from `mouse-position'." (when (not mouse-position) (setq mouse-position (mouse-position))) `(,(car mouse-position) ,@(posn-x-y (event-end vt-mouse-last-event)))) ;; (define-minor-mode vt-mouse-mode ;; "Toggle Video Terminal Mouse mode. ;; With prefix arg, turn vt-mouse mode on iff arg is positive. ;; ;; Turn it on to use Emacs mouse commands, and off to use only native ;; mouse commands. ;; ;; This works in ANSI, VT, xterm compatable terminal emulators, only ;; for simple uses of the mouse. Basically, only non-modified single ;; clicks are supported. When turned on, the normal mouse functionality ;; for such clicks is still available by holding down the SHIFT key while ;; pressing the mouse button." ;; :global t ;; :group 'mouse ;; (if vt-mouse-mode ;; (unless window-system ;; ;; set needed bindings and ensure start of vt-mouse ;; (setq mouse-position-function 'vt-mouse-position) ;; (if vt-menu-mode ;; (setq vt-menu-original-mode 1) ;; (setq vt-menu-original-mode 0)) ;; (unless vt-menu-mode ;; (vt-menu-mode 1)) ;; (unless vt-mouse-active ;; (vt-mouse 1)) ;; (unless vt-mouse-last-event ;; (push 'vt-mouse-bait unread-command-events)) ;; (setq vt-saved-keyboard-translate-table keyboard-translate-table) ;; (setq keyboard-translate-table nil)) ;; (unless window-system ;; ;; disable vt-mouse and reset key previous bindings ;; (setq mouse-position-function nil) ;; (when vt-mouse-active (vt-mouse -1)) ;; (vt-menu-mode vt-menu-original-mode) ;; (setq keyboard-translate-table vt-saved-keyboard-translate-table)))) ;; Emacs versions before 21 do not have define-minor-mode ;;;###autoload (let ((documentation "Toggle Video Terminal Mouse mode. With prefix arg, turn vt-mouse mode on iff arg is positive. Turn it on to use Emacs mouse commands, and off to use only native mouse commands. This works in ANSI, VT, xterm compatable terminal emulators, only for simple uses of the mouse. Basically, only non-modified single clicks are supported. When turned on, the normal mouse functionality for such clicks is still available by holding down the SHIFT key while pressing the mouse button.") (procedure `(if vt-mouse-mode (unless window-system ;; set needed bindings and ensure start of vt-mouse (setq mouse-position-function 'vt-mouse-position) (if vt-menu-mode (setq vt-menu-original-mode 1) (setq vt-menu-original-mode 0)) (unless vt-menu-mode (vt-menu-mode 1)) (unless vt-mouse-active (vt-mouse 1)) (unless vt-mouse-last-event (push 'vt-mouse-bait unread-command-events)) (setq vt-saved-keyboard-translate-table keyboard-translate-table) (setq keyboard-translate-table nil)) (unless window-system ;; disable vt-mouse and reset key previous bindings (setq mouse-position-function nil) (when vt-mouse-active (vt-mouse -1)) (vt-menu-mode vt-menu-original-mode) (setq keyboard-translate-table vt-saved-keyboard-translate-table))))) (if (functionp 'define-minor-mode) (eval `(define-minor-mode vt-mouse-mode ,documentation :global t :group 'mouse ,procedure)) (defvar vt-mouse-mode nil "Vt-Mouse status") (eval `(defun vt-mouse-mode (&optional arg) ,documentation (interactive) (setq vt-mouse-mode (if arg (> (prefix-numeric-value arg) 0) (not vt-mouse-mode))) ,procedure (run-hooks 'vt-mouse-mode-hook (if vt-mouse-mode 'vt-mouse-mode-on-hook 'vt-mouse-mode-off-hook)) (if (interactive-p) (message "Vt-Mouse mode %sabled" (if vt-mouse-mode "en" "dis"))) (force-mode-line-update) vt-mouse-mode)))) ;;; events ;; construct special vt-method location symbol drag handler event ;; substituting equivalent numeric position for location symbol to ;; handle drag of special locations, mode-line, vertical-line, ;; header-line, circumnavigating methods which use `track-mouse'. ;; Here is an example generated event: ;; ;; (mode-line-drag-mouse-1 ; `event-basic-type' ;; (# 4289 (79 . 44) 922) ; `event-start' ;; (# 5984 (180 . 47) 923) ; `event-end' ;; 1) ; `event-click-count' (defun vt-mouse-pseudo-drag-event (window x y) "Returns name-substituted, buffer-position de-symbolized equivalenced special location drag event, using vt-mouse-last-event to derive event-start, and window, x, y to derive event-end." (let* ((type (car vt-mouse-last-event)) (time (nth 3 (event-start vt-mouse-last-event))) (location (posn-point (event-start vt-mouse-last-event))) (x0 (car (posn-x-y (event-start vt-mouse-last-event)))) (y0 (cdr (posn-x-y (event-start vt-mouse-last-event))))) `( ;; `event-basic-type' ,(car (read-from-string (format "%s-%s" location type))) ;; `event-start' (,(car (event-start vt-mouse-last-event)) ; first window ,(save-excursion (select-window (car (event-start vt-mouse-last-event))) (goto-char (window-start)) (ignore-errors (forward-line y0)) (ignore-errors (forward-char x0)) (point)) ; first buffer position as numeric value (,x0 . ,y0) ; first mouse location ,time) ; initial time ;; `event-end' (,window ; final window ,(save-excursion (select-window window) (goto-char (window-start)) (ignore-errors (forward-line y)) (ignore-errors (forward-char x)) (point)) ; final buffer position as numeric value (,vt-mouse-last-x . ,vt-mouse-last-y) ; final mouse location ,(+ 1 time)) ; one tick later ;; `event-click-count' 1 ))) ;; These `vt-mouse-drag-' functions are used as drag-and-drop analogies ;; to the corresponding `mouse-drag-' handlers when using vt-mouse mode, ;; in order to circumnavigate mouse.el procedures using `track-mouse'. ;; ;; They accept for argument specific drag events created for this purpose ;; by `vt-mouse-pseudo-drag-event' when pushed onto the command queue by ;; `vt-mouse-prefix' upon drag of special symbol valued locations. ;; ;; Keys for these events are defined in the `vt-init' procedure. ;; single event equivalent of mouse-drag-mode-line in mouse.el (defun vt-mouse-drag-mode-line (&optional drag-event) "Change window size with single drag-event of mode-line." (interactive "e") (unless drag-event (setq drag-event vt-mouse-last-event)) (let* ((start-window (car (event-start drag-event))) (end-window (car (event-end drag-event))) (line-count (if (equalp start-window end-window) (abs (- (cdr (posn-x-y (event-end drag-event))) (cdr (posn-x-y (event-start drag-event))))) (abs (- (cdr (posn-x-y (event-start drag-event))) (cdr (posn-x-y (event-end drag-event)))))))) (select-window start-window) (if (equalp start-window end-window) (enlarge-window (- line-count)) (shrink-window (- line-count))) (vt-debug-message "%S" drag-event))) ;; single event equivalent of mouse-drag-vertical-line in mouse.el (defun vt-mouse-drag-vertical-line (&optional drag-event) "Change window size with single drag-event of vertical-line." (interactive "e") (unless drag-event (setq drag-event vt-mouse-last-event)) (let* ((start-window (car (event-start drag-event))) (end-window (car (event-end drag-event))) (column-count (if (equalp start-window end-window) (abs (- (car (posn-x-y (event-end drag-event))) (car (posn-x-y (event-start drag-event))))) (abs (- (car (posn-x-y (event-start drag-event))) (car (posn-x-y (event-end drag-event)))))))) (unless (equalp start-window end-window) (while (> column-count (window-width start-window)) (setq column-count (abs (- column-count (window-width start-window)))))) (select-window start-window) (if (equalp start-window end-window) (shrink-window-horizontally column-count) (enlarge-window-horizontally column-count)) (vt-debug-message "%S" drag-event))) ;; single event equivalent of mouse-drag-header-line in mouse.el (defun vt-mouse-drag-header-line (&optional drag-event) "Change window size with single drag-event of header-line." (interactive "e") (unless drag-event (setq drag-event vt-mouse-last-event)) (let* ((start-window (car (event-start drag-event))) (end-window (car (event-end drag-event))) (line-count (abs (- (cddr vt-mouse-last-position) (cddr vt-mouse-prior-position))))) (if (equalp start-window end-window) (progn (select-window start-window) (shrink-window line-count)) (progn (select-window end-window) (shrink-window (- (window-height) line-count)) (select-window start-window))) (vt-debug-message "%S" drag-event))) ;; generate and push converted special vt-method drag handler event ;; to activate an aforementioned symbol location handler function (defun vt-mouse-symbol-position-drag (window x y) "push generated symbol position drag event" (push (setq vt-mouse-last-event (vt-mouse-pseudo-drag-event window x y)) unread-command-events)) ;; generate and push drag to menu completions event ;; to activate handler from vt-menu.el (defun vt-menu-drag-to-completions () "push `vt-menubar-selection' invocation onto menu-completions." (vt-menu-switch-to-completions) ;; zero click-count informs this handler original event was drag (push `(vt-menubar-select ,(event-end vt-mouse-last-event) 0) unread-command-events)) ;; generate and push vt-menubar event embedding vt-mouse-last-event ;; to activate handler from vt-menu.el (defun vt-mouse-menubar () "push `vt-menubar' event" (if vt-menu-active (setq vt-menu-depth (if (= 0 vt-menu-depth) -999 ; zero flag (- vt-menu-depth))) ;; embed down-mouse event in meta-event to be unpacked by handler (push `(vt-menubar ,vt-mouse-last-event) unread-command-events))) ;; capture mouse prefix and create appropriate mouse event, invoking ;; procedures bound to certain special operations if needed (defun vt-mouse-prefix () "Bind this to ESC [ M, it reads k x y and makes a mouse click event" ;; safe to assume click in selected frame ;; need 8-bit input to click past column 128 ;; which can be specified by `set-input-mode'. (interactive) (let* ((mask (if (nth 2 (current-input-mode)) 255 127)) (k (- (read-octet-exclusive) ?\ )) (x (logand (- (read-octet-exclusive) ?\!) mask)) (y (logand (- (read-octet-exclusive) ?\!) mask)) (time (let ((hlu (current-time))) ; time in milliseconds mod 2^16 seconds (+ (* (nth 1 hlu) 1000) (/ (nth 2 hlu) 1000)))) (window (or (and vt-cmg-esc-102-bug (zerop (logand (+ x ?\! -135) mask)) ; C-M-g (zerop (logand (+ y ?\! -27) mask)) ; ESC (error "Mouse column 102 bug")) (window-at x y) (and (< y (frame-parameter (selected-frame) 'menu-bar-lines)) 'menu-bar))) (type (cond (window (vt-mouse-event-type k)) (t (error "Mouse [%d,%d] out of window" x y)))) (still (and (= vt-mouse-last-x x) ; ignore double-click-fuzz in favor of char cell fuzz (= vt-mouse-last-y y))) (count (cond ((not type) vt-mouse-down-count) ((not still) 1) ((null double-click-time) 1) ((or (not (integerp double-click-time)) (< (- time vt-mouse-down-time) double-click-time)) (min 3 (1+ vt-mouse-down-count))) (t 1))) (event (cond ((null type) (and vt-mouse-bait-flag (setq type (get (car-safe vt-mouse-last-event) (if still 'vt-mouse-click 'vt-mouse-drag))) ;; click-up, bait uneaten -- ;; last event was a down-mouse- (if still ;; (event-type (window buffer-pos (x . y) timestamp) click-count) (list type ; mouse- (vt-mouse-event-posn x y window) count) ;; (event-type (start-window buffer-pos (x . y) timestamp) (end-window buffer-pos (x . y) timestamp) click-count) (list type ; drag-mouse- (cadr vt-mouse-last-event) (vt-mouse-event-posn x y window))))) (window (setq vt-mouse-down-time time vt-mouse-down-count count type (get type count)) (list type ; down-mouse- (vt-mouse-event-posn x y window) count)) (t ; maybe should be (list type) ??? type)))) ;;(EVENT-TYPE (WINDOW BUFFER-POS (X . Y) TIMESTAMP) CLICK-COUNT) ;;(mouse-1 (# 2613 (0 . 38) -864180)) ;;(M-S-down-mouse-2 (# mode-line (33 . 31) -457844)) (vt-debug-message "VT mouse event %8X [%s, %s] %d\t-%S-\t%S" ;; type (posn-point (event-start event)) k x y (- time vt-mouse-down-time) vt-mouse-bait-flag event ;; \n last event %8X [%s, %s]\t%S ;; vt-mouse-last-k vt-mouse-last-x vt-mouse-last-y vt-mouse-last-event ) (setq vt-mouse-prior-position vt-mouse-last-position) (when type ;; remember all but ignored mouse release events (setq vt-mouse-last-k k vt-mouse-last-x x vt-mouse-last-y y vt-mouse-last-event event)) (setq vt-mouse-last-position (mouse-position)) (cond ((null type) (and vt-mouse-bait-flag ;; bait not eaten, note multiple releases and maybe unexpected events (vt-debug-message "unexpected mouse release event #x%X [%s, %s]" k x y))) ;; handle menu-bar down-mouse-1 event ((and (eq 'menu-bar window) (eq 'down-mouse-1 type)) (vt-mouse-menubar)) ;; handle menu-bar drag-mouse-1 to menu-completions event ((and (eq 'drag-mouse-1 type) (eq 'menu-bar (car (event-start vt-mouse-last-event)))) (vt-menu-drag-to-completions)) ;; handle drag-mouse-1 of symbol-valued buffer locations ((and (eq 'drag-mouse-1 type) (symbolp (posn-point (event-start vt-mouse-last-event)))) (vt-mouse-symbol-position-drag window x y)) (t ;; After a click-down event, suffix a magic cookie to ;; workaround code that does (read-event) inappropriately. (when (get (car-safe event) 'vt-mouse-click) ; maybe vt-mouse-drag too ??? (push 'vt-mouse-bait unread-command-events) (setq vt-mouse-bait-flag nil)) ;; Select this window (or start-window) if destination for event ;; as workaround for misselected window during some mouse actions. (let ((start-window (car (event-start event))) (end-window (car (event-end event)))) (unless (eq (selected-window) window) (if (and (windowp window) (not (symbolp window))) (if (equalp start-window window) (select-window window) (if (or (symbolp start-window) (not (windowp start-window))) (select-window window) (select-window start-window))) (if (and (windowp start-window) (not (symbolp start-window))) (select-window start-window) (vt-debug-message "current %S window %S begin %S end %S" (selected-window) window start-window end-window))))) ;; Mouse event (push event unread-command-events))))) ;; kludge -- censor down- events on mode/header lines ; ((and (eq 'down-mouse-1 type) ; (memq (posn-point (event-start event)) ; '(header-line mode-line))) ; (setq vt-mouse-last-event event) ; (setq event nil)) ;; Before a non-text-area click, prefix an imaginary key. ; ((memq (cadadr event) ; '(mode-line header-line left-fringe right-fringe vertical-line vertical-scroll-bar)) ; (push (cadadr event) unread-command-events)) (defun vt-mouse-bait-handler () "The vt-mouse-bait special event is for down-mouse- event handlers which stupidly eat the following event to inhibit the up click. Flag is cleared when ``vt-mouse-prefix'' generates a bait event. If eaten, flag stays clear to discard up clicks. If left uneaten, set flag to generate a mouse- or drag-mouse- event when the corresponding up click arrives." (interactive) ;; unread-command-events loses with special events, drat! (setq vt-mouse-bait-flag t) (vt-debug-message "Mouse bait not eaten")) ;;; should integrate with lisp/mouse.el ??? (defun vt-mouse-set-point (event) "Move point to the position clicked on with the mouse. This should be bound to a mouse click event type." (interactive "e") (vt-debug-message "\n(vt-mouse-set-point %S)" event) (mouse-minibuffer-check event) (setq mark-active nil) (posn-set-point (event-end event))) (defun vt-mouse-ignore-noisily (event) "Do nothing and log that in the debug log." (interactive "e") (vt-debug-message "\n(vt-mouse-ignore-noisily %S)" event)) (defun vt-mouse-drag-region (event) "Set region to dragged-over area. This should be bound to a mouse drag event type." (interactive "e") (mouse-minibuffer-check event) (let* ((start (event-start event)) (end (event-end event)) (window (posn-window start)) (w1 (posn-window end))) (or (and (windowp window) (eq window w1)) (error "Positions not in text area of window")) (select-window window) (set-mark (posn-point start)) (goto-char (posn-point end)))) (unless (fboundp 'mouse-minibuffer-check) ; from lisp/mouse.el (defun mouse-minibuffer-check (event) (let ((w (posn-window (event-start event)))) (and (window-minibuffer-p w) (not (minibuffer-window-active-p w)) (error "Minibuffer window is not active"))) ;; Give temporary modes such as isearch a chance to turn off. (run-hooks 'mouse-leave-buffer-hook)) ) (unless (fboundp 'posn-set-point) ; from emacs-21.3.50/lisp/subr.el (defun posn-set-point (position) "Move point to POSITION. Select the corresponding window as well." (if (not (windowp (posn-window position))) (error "Position not in text area of window")) (select-window (posn-window position)) (if (numberp (posn-point position)) (goto-char (posn-point position)))) ) ;;; mousy goodies (defun vt-mouse-insert-thing (click) "Traditional control-click DWIM (Do What I Mean) command, insert char/symbol/sexp/line by context, e.g., line at End-Of-Line." ;;; BUGS: see mouse-mark-thing (interactive "e") (insert (save-excursion (vt-mouse-mark-thing click) (buffer-substring (point) (mark))))) (defun vt-mouse-mark-thing (click) "Traditional double-click DWIM (Do What I Mean) command, mark char/symbol/sexp/line by context, e.g., line at End-Of-Line." ;;; BUG: looks at major-mode instead of adding hooks to text and fundamental modes. ;;; uses set-mark not push-mark because you can only click on what you see nearby, ;;; should push old mark but carelessly changing this breaks vt-mouse-insert-thing (interactive "@e") (mouse-set-point click) (let* ((char (or (char-after (point)) 0)) (syntax (char-syntax char))) (cond ((eobp) ; unterminated line at eob. (set-mark (point)) (beginning-of-line 1)) ((eolp) ; whole line at eol. (set-mark (1+ (point))) (beginning-of-line 1)) ((and (eq syntax ?w) ; word. (memq major-mode '(text-mode fundamental-mode))) (forward-word 1) (set-mark (point)) (forward-word -1)) ((memq syntax '(?w ?_)) ; identifier. (forward-sexp 1) (set-mark (point)) (forward-sexp -1)) ((eq syntax ?\( ) ; open paren. (mark-sexp 1)) ((eq syntax ?\) ) ; close paren. (forward-char 1) (mark-sexp -1) (exchange-point-and-mark)) (t ; character. (set-mark (1+ (point))))))) (defun vt-mouse-mark-line (click) "Mark the line clicked in." (interactive "@e") (mouse-set-point click) (end-of-line) (set-mark (1+ (point))) (beginning-of-line)) ;;; reinvent the mouse wheel (defalias 'vt-scroll-previous #'scroll-down) ; Scroll to bring `window-start' closer to `point-min' and gain slack. (defalias 'vt-scroll-next #'scroll-up) ; Scroll to bring `window-start' closer to `point-max' and eschew ambiguity. (defun vt-scroll-next-1 (&optional ignore) (interactive) (vt-scroll-next 1)) (defun vt-scroll-next-3 (&optional ignore) (interactive) (vt-scroll-next 3)) (defun vt-scroll-next-5 (&optional ignore) (interactive) (vt-scroll-next 5)) (defun vt-scroll-next-6 (&optional ignore) (interactive) (vt-scroll-next 6)) (defun vt-scroll-next-15 (&optional ignore) (interactive) (vt-scroll-next 15)) (defun vt-scroll-next-30 (&optional ignore) (interactive) (vt-scroll-next 30)) (defun vt-scroll-next-page (&optional ignore) (interactive) (vt-scroll-next (- (window-height) next-screen-context-lines))) (defun vt-scroll-next-page-3 (&optional ignore) (interactive) (vt-scroll-next (* 3 (- (window-height) next-screen-context-lines)))) (defun vt-scroll-next-page-6 (&optional ignore) (interactive) (vt-scroll-next (* 6 (- (window-height) next-screen-context-lines)))) (defun vt-scroll-previous-1 (&optional ignore) (interactive) (vt-scroll-previous 1)) (defun vt-scroll-previous-3 (&optional ignore) (interactive) (vt-scroll-previous 3)) (defun vt-scroll-previous-5 (&optional ignore) (interactive) (vt-scroll-previous 5)) (defun vt-scroll-previous-6 (&optional ignore) (interactive) (vt-scroll-previous 6)) (defun vt-scroll-previous-15 (&optional ignore) (interactive) (vt-scroll-previous 15)) (defun vt-scroll-previous-30 (&optional ignore) (interactive) (vt-scroll-previous 30)) (defun vt-scroll-previous-page (&optional ignore) (interactive) (vt-scroll-previous (- (window-height) next-screen-context-lines))) (defun vt-scroll-previous-page-3 (&optional ignore) (interactive) (vt-scroll-previous (* 3 (- (window-height) next-screen-context-lines)))) (defun vt-scroll-previous-page-6 (&optional ignore) (interactive) (vt-scroll-previous (* 6 (- (window-height) next-screen-context-lines)))) ; (defun vt-mouse-amount (arg) ; "ARG is probably wrong, `mouse-wheel-scroll-amount' is an ; alist of modifiers to scroll jump counts as documented in the ; mwheel library, i.e., '(5 ((shift) . 1) ((control) . nil)) ; by default. Way sketchy, implement later." ; ;; nil = full screen ; (* (or arg 1) ; (cond ((not (boundp 'mouse-wheel-scroll-amount)) ; 5) ; ((numberp mouse-wheel-scroll-amount) ; mouse-wheel-scroll-amount) ; (t ; (let ((rest mouse-wheel-scroll-amount) ; amt) ; (while (consp (setq amt (cond ((consp rest) ; (pop rest)) ; ((numberp rest) ; rest))))) ; (if (floatp amt) ; (1+ (truncate (* amt (window-height)))) ; amt)))))) ;;; initialize ;;; vain attempt to get [mouse] instead of ESC [ M in view-lossage ;(define-key function-key-map "\e[M" [mouse]) ;(global-set-key [mouse] 'vt-mouse-prefix) (global-set-key "\e[M" 'vt-mouse-prefix) (global-set-key [vt-mouse-bait] 'vt-mouse-bait-handler) ;;; kludge no beep on unbound mouse clicks (defalias 'vt-mouse-ignore 'ignore) (mapc '(lambda (key) (or (global-key-binding key) (global-set-key key 'vt-mouse-ignore))) '([down-mouse-1] [drag-mouse-1] [double-down-mouse-1] [double-drag-mouse-1] [triple-down-mouse-1] [triple-drag-mouse-1] [down-mouse-3] [drag-mouse-3] [double-down-mouse-3] [double-drag-mouse-3] [triple-down-mouse-3] [triple-drag-mouse-3] ;; ignore scroll wheel release events ;; probably should not even generate them ??? [R-mouse-1] [R-drag-mouse-1] [R-double-mouse-1] [R-double-drag-mouse-1] [R-triple-mouse-1] [R-triple-drag-mouse-1] [R-mouse-2] [R-drag-mouse-2] [R-double-mouse-2] [R-double-drag-mouse-2] [R-triple-mouse-2] [R-triple-drag-mouse-2])) ; (mapcar '(lambda (key) ; (cons key (global-key-binding key))) ; '([mouse] ; [vt-mouse-bait] ; [double-mouse-1] ; [triple-mouse-1] ; [double-down-mouse-1] ; [double-drag-mouse-1] ; [down-mouse-3] ; [drag-mouse-3])) (defun vt-custom-parse (custom parameters) "Parse CUSTOM options according to PARAMETERS. Default to the first keyword in each parameter." ; maybe no defaults ??? (let ((custom (if (listp custom) custom (list custom))) (options '())) (let ((known (apply #'append '(:no) parameters))) (dolist (c custom) (or (memq c known) (error "vt-custom unknown option %S" c))) (when (memq ':no custom) (dolist (k known) (if (string-match "^:no." (symbol-name k)) (push k custom))))) (dolist (param parameters) (let ((k nil)) (dolist (c custom) (when (memq c param) (if (or (null k) (eq k c)) (setq k c) (error "vt-custom %S contradicts %S" k c)))) (push (or k (car param)) options))) ; maybe not push if (not k) ??? options)) ;;; Preferences (defun vt-init (vt-custom) "Process `vt-custom' options." (let ((options (vt-custom-parse vt-custom '((:noswap :swap) (:enable :noenable) (:disable :nodisable) (:bind :nobind) ; :bind same as :rebind for now (:detect :nodetect) (:nobypass :bypass))))) (setq vt-cmg-esc-102-bug (not (memq ':nodetect options))) (unless (memq ':nobind options) ; (if (memq ':rebind options) (mapc #'(lambda (b) (global-set-key (car b) (cdr b))) ;;; #'(lambda (b) ;;; (or (global-key-binding (car b)) ;;; (global-set-key (car b) (cdr b))))) ;; customary mouse bindings -- need more '(([down-mouse-1] . vt-mouse-set-point) ([drag-mouse-1] . vt-mouse-drag-region) ([mouse-1] . vt-mouse-ignore) ([double-mouse-1] . vt-mouse-mark-thing) ([triple-mouse-1] . vt-mouse-mark-line) ;; special window location drag handlers ([mode-line-drag-mouse-1] . vt-mouse-drag-mode-line) ([vertical-line-drag-mouse-1] . vt-mouse-drag-vertical-line) ([header-line-drag-mouse-1] . vt-mouse-drag-header-line) ;; menu-bar global bindings from vt-menu.el ;;; ([f10] . vt-menubar-command) ; these are defined when ;;; ([M-\`] . vt-menubar-command) ; `vt-menu-mode' starts, either ;;; ([vt-menubar] . vt-menubar-handler) ; independent of, or along ;;; ([menu-bar mouse-1] . vt-menubar-handler) ; with `vt-mouse-mode' ;;; ([vt-menubar-select] . vt-menu-selection) ; -db- ;; roller scroller -- R- prefix temp kludge ([R-down-mouse-1] . vt-scroll-previous-5) ([R-down-mouse-2] . vt-scroll-next-5) ([R-C-down-mouse-1] . vt-scroll-previous-page) ([R-C-down-mouse-2] . vt-scroll-next-page) ([R-S-down-mouse-1] . vt-scroll-previous-1) ([R-S-down-mouse-2] . vt-scroll-next-1) ([R-double-down-mouse-1] . vt-scroll-previous-15) ([R-double-down-mouse-2] . vt-scroll-next-15) ([R-C-double-down-mouse-1] . vt-scroll-previous-page-3) ([R-C-double-down-mouse-2] . vt-scroll-next-page-3) ([R-S-double-down-mouse-1] . vt-scroll-previous-3) ([R-S-double-down-mouse-2] . vt-scroll-next-3) ([R-triple-down-mouse-1] . vt-scroll-previous-30) ([R-triple-down-mouse-2] . vt-scroll-next-30) ([R-C-triple-down-mouse-1] . vt-scroll-previous-page-6) ([R-C-triple-down-mouse-2] . vt-scroll-next-page-6) ([R-S-triple-down-mouse-1] . vt-scroll-previous-6) ([R-S-triple-down-mouse-2] . vt-scroll-next-6) ;; old favorites -- what were the ZMACS mouse bindings? ([M-mouse-1] . vt-mouse-find-thing) ; like Meta-dot ([C-mouse-1] . vt-mouse-insert-thing)))) (when (memq ':disable options) (add-hook 'kill-emacs-hook 'vt-mouse-stop-hook) (add-hook 'suspend-hook 'vt-mouse-stop-hook) (add-hook 'suspend-resume-hook 'vt-mouse-start-hook)) (when (memq ':nodisable options) (remove-hook 'kill-emacs-hook 'vt-mouse-stop-hook)) (and (memq ':enable options) (null window-system) (vt-mouse (if (memq ':swap options) 2 1) (memq ':bypass options))) (when (memq ':noenable options) (vt-mouse -1)))) (vt-init vt-custom) ;; clear loading flag used by sub-requirements (makunbound 'vt-mouse-loading) ;; what we do here (provide 'vt-mouse) ;;; end vt-mouse.el