mirror of
git://git.sv.gnu.org/emacs.git
synced 2026-01-03 18:41:25 -08:00
*** empty log message ***
This commit is contained in:
Jim Blandy
parent
6367dc09a1
commit
cc0a8174ba
3 changed files with 376 additions and 309 deletions
390
lisp/mouse.el
390
lisp/mouse.el
|
|
@ -1,170 +1,95 @@
|
|||
;; Mouse support that is independent of window systems.
|
||||
;; Copyright (C) 1988 Free Software Foundation, Inc.
|
||||
;;; Window system-independent mouse support.
|
||||
;;; Copyright (C) 1988 Free Software Foundation, Inc.
|
||||
|
||||
;; This file is part of GNU Emacs.
|
||||
;;; 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 1, or (at your option)
|
||||
;; any later version.
|
||||
;;; 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 1, 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.
|
||||
;;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
;;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
|
||||
|
||||
(provide 'mouse)
|
||||
|
||||
|
||||
(defun mouse-select ()
|
||||
"Select the Emacs window the mouse is on."
|
||||
(interactive "@"))
|
||||
;;; Utility functions.
|
||||
|
||||
(defun mouse-delete-window ()
|
||||
"Delete the Emacs window the mouse is on."
|
||||
(interactive "@")
|
||||
(delete-window))
|
||||
(defun mouse-movement-p (event)
|
||||
(and (consp event)
|
||||
(eq (car event) 'mouse-movement)))
|
||||
|
||||
(defun mouse-keep-one-window ()
|
||||
"Select Emacs window mouse is on, then kill all other Emacs windows."
|
||||
(interactive "@")
|
||||
(defun event-window (event) (nth 1 event))
|
||||
(defun event-point (event) (nth 2 event))
|
||||
(defun mouse-coords (event) (nth 3 event))
|
||||
(defun mouse-timestamp (event) (nth 4 event))
|
||||
|
||||
;;; Indent track-mouse like progn.
|
||||
(put 'track-mouse 'lisp-indent-function 0)
|
||||
|
||||
|
||||
(defun mouse-delete-window (click)
|
||||
"Delete the window clicked on.
|
||||
This must be bound to a mouse click."
|
||||
(interactive "K")
|
||||
(delete-window (event-window click)))
|
||||
|
||||
(defun mouse-delete-other-windows (click)
|
||||
"Select Emacs window clicked on, then kill all other Emacs windows.
|
||||
This must be bound to a mouse click."
|
||||
(interactive "K")
|
||||
(select-window (event-window click))
|
||||
(delete-other-windows))
|
||||
|
||||
(defun mouse-select-and-split ()
|
||||
"Select Emacs window mouse is on, then split it vertically in half."
|
||||
(interactive "@")
|
||||
(split-window-vertically nil))
|
||||
(defun mouse-split-window-vertically (click)
|
||||
"Select Emacs window mouse is on, then split it vertically in half.
|
||||
The window is split at the line clicked on.
|
||||
This command must be bound to a mouse click."
|
||||
(interactive "K")
|
||||
(select-window (event-window click))
|
||||
(split-window-vertically (1+ (cdr (mouse-coords click)))))
|
||||
|
||||
(defun mouse-set-point (event)
|
||||
"Select Emacs window mouse is on, and move point to mouse position."
|
||||
(interactive "@e")
|
||||
(let ((relative-coordinate
|
||||
(coordinates-in-window-p (car event) (selected-window))))
|
||||
(if (consp relative-coordinate)
|
||||
(progn
|
||||
(move-to-window-line (car (cdr relative-coordinate)))
|
||||
;; Note that hscroll must get above 1
|
||||
;; before the text actually starts to move.
|
||||
(move-to-column (+ (car relative-coordinate) (current-column)
|
||||
(1- (max 1 (window-hscroll (selected-window))))))
|
||||
(what-line)))))
|
||||
(defun mouse-set-point (click)
|
||||
"Move point to the position clicked on with the mouse.
|
||||
This must be bound to a mouse click."
|
||||
(interactive "K")
|
||||
(select-window (event-window click))
|
||||
(goto-char (event-point click)))
|
||||
|
||||
(defun mouse-eval-last-sexpr (event)
|
||||
(interactive "@e")
|
||||
(save-excursion
|
||||
(mouse-set-point event)
|
||||
(eval-last-sexp nil)))
|
||||
|
||||
(defun mouse-line-length (event)
|
||||
"Print the length of the line indicated by the pointer."
|
||||
(interactive "@e")
|
||||
(let ((relative-coordinate
|
||||
(coordinates-in-window-p (car event) (selected-window))))
|
||||
(if (consp relative-coordinate)
|
||||
(save-excursion
|
||||
(move-to-window-line (car (cdr relative-coordinate)))
|
||||
(end-of-line)
|
||||
(push-mark nil t)
|
||||
(beginning-of-line)
|
||||
(message "Line length: %d"
|
||||
(- (region-end) (region-beginning)))
|
||||
(sleep-for 1)))))
|
||||
|
||||
(defun mouse-set-mark (event)
|
||||
"Select Emacs window mouse is on, and set mark at mouse position.
|
||||
Display cursor at that position for a second."
|
||||
(interactive "@e")
|
||||
(defun mouse-set-mark (click)
|
||||
"Set mark at the position clicked on with the mouse.
|
||||
Display cursor at that position for a second.
|
||||
This must be bound to a mouse click."
|
||||
(interactive "K")
|
||||
(let ((point-save (point)))
|
||||
(unwind-protect
|
||||
(progn (mouse-set-point event)
|
||||
(progn (mouse-set-point click)
|
||||
(push-mark nil t)
|
||||
(sit-for 1))
|
||||
(goto-char point-save))))
|
||||
|
||||
(defun mouse-fill-paragraph (event)
|
||||
"Fill the paragraph at the mouse position."
|
||||
(interactive "@e")
|
||||
(save-excursion
|
||||
(mouse-set-point event)
|
||||
(fill-paragraph)))
|
||||
(defun mouse-kill (click)
|
||||
"Kill the region between point and the mouse click.
|
||||
The text is saved in the kill ring, as with \\[kill-region]."
|
||||
(interactive "K")
|
||||
(mouse-set-mark click)
|
||||
(kill-region))
|
||||
|
||||
(defun mouse-fill-paragraph-with-prefix (event)
|
||||
"Fill the paragraph at the mouse position with specified fill prefix.
|
||||
Click at the end of the fill prefix that you want;
|
||||
The text before the mouse position, on the same line, is used as the prefix."
|
||||
(interactive "@e")
|
||||
(save-excursion
|
||||
(mouse-set-point event)
|
||||
(let ((fill-prefix (buffer-substring (save-excursion (beginning-of-line)
|
||||
(point))
|
||||
(point))))
|
||||
(fill-paragraph))))
|
||||
(defun mouse-kill-ring-save
|
||||
"Copy the region between point and the mouse click in the kill ring.
|
||||
This does not delete the region; it acts like \\[kill-ring-save]."
|
||||
(interactive "K")
|
||||
(mouse-set-mark click)
|
||||
(kill-ring-save))
|
||||
|
||||
(defun mouse-scroll (event)
|
||||
"Scroll point to the mouse position."
|
||||
(interactive "@e")
|
||||
(let ((relative-coordinate
|
||||
(coordinates-in-window-p (car event) (selected-window))))
|
||||
(if (consp relative-coordinate)
|
||||
(progn
|
||||
(recenter (car (cdr relative-coordinate)))
|
||||
(scroll-right (+ (car relative-coordinate) (current-column)))))))
|
||||
|
||||
(defun mouse-del-char (event)
|
||||
"Delete the char pointed to by the mouse."
|
||||
(interactive "@e")
|
||||
(let ((relative-coordinate
|
||||
(coordinates-in-window-p (car event) (selected-window))))
|
||||
(if (consp relative-coordinate)
|
||||
(progn
|
||||
(move-to-window-line (car (cdr relative-coordinate)))
|
||||
(move-to-column (+ (car relative-coordinate) (current-column)))
|
||||
(delete-char 1 nil)))))
|
||||
|
||||
(defun mouse-kill-line (event)
|
||||
"Kill the line pointed to by the mouse."
|
||||
(interactive "@e")
|
||||
(let ((relative-coordinate
|
||||
(coordinates-in-window-p (car event) (selected-window))))
|
||||
(if (consp relative-coordinate)
|
||||
(progn
|
||||
(move-to-window-line (car (cdr relative-coordinate)))
|
||||
(move-to-column (+ (car relative-coordinate) (current-column)))
|
||||
(kill-line nil)))))
|
||||
|
||||
(defun narrow-window-to-region (m n)
|
||||
"Narrow window to region between point and last mark"
|
||||
(interactive "r")
|
||||
(save-excursion
|
||||
(save-restriction
|
||||
(if (eq (selected-window) (next-window))
|
||||
(split-window))
|
||||
(goto-char m)
|
||||
(recenter 0)
|
||||
(if (eq (selected-window)
|
||||
(if (zerop (minibuffer-depth))
|
||||
(next-window)))
|
||||
()
|
||||
(shrink-window (- (- (window-height) (count-lines m n)) 1))))))
|
||||
|
||||
(defun mouse-window-to-region (event)
|
||||
"Narrow window to region between cursor and mouse pointer."
|
||||
(interactive "@e")
|
||||
(let ((point-save (point)))
|
||||
(unwind-protect
|
||||
(progn (mouse-set-point event)
|
||||
(push-mark nil t)
|
||||
(sit-for 1))
|
||||
(goto-char point-save)
|
||||
(narrow-window-to-region (region-beginning) (region-end)))))
|
||||
|
||||
(defun mouse-ignore ()
|
||||
"Don't do anything."
|
||||
(interactive))
|
||||
|
||||
;; Commands for the scroll bar.
|
||||
|
||||
|
|
@ -231,77 +156,77 @@ The text before the mouse position, on the same line, is used as the prefix."
|
|||
|
||||
;; Set up these commands, including the prefix keys for the scroll bar.
|
||||
|
||||
(fset 'mouse-vertical-scroll-bar-prefix (make-sparse-keymap))
|
||||
(define-key global-mouse-map mouse-vertical-scroll-bar-prefix
|
||||
'mouse-vertical-scroll-bar-prefix)
|
||||
|
||||
(defun mouse-scroll-motion (event)
|
||||
(interactive "e")
|
||||
(let ((pos (car (car event)))
|
||||
(length (car (cdr (car event)))))
|
||||
(message "[%d %d]" pos length)))
|
||||
|
||||
(let ((map (function mouse-vertical-scroll-bar-prefix)))
|
||||
(define-key map mouse-button-right 'mouse-scroll-down)
|
||||
(define-key map mouse-button-left 'mouse-scroll-up)
|
||||
(define-key map mouse-button-middle 'mouse-scroll-absolute)
|
||||
(define-key map mouse-motion 'x-horizontal-line))
|
||||
|
||||
;(fset 'mouse-vertical-slider-prefix (make-sparse-keymap))
|
||||
;(define-key global-mouse-map mouse-vertical-slider-prefix
|
||||
; 'mouse-vertical-slider-prefix)
|
||||
|
||||
;(let ((map (function mouse-vertical-slider-prefix)))
|
||||
; (define-key map mouse-button-right 'mouse-scroll-move-cursor)
|
||||
; (define-key map mouse-button-left 'mouse-scroll-move-cursor)
|
||||
; (define-key map mouse-button-middle 'mouse-scroll-move-cursor))
|
||||
|
||||
(fset 'mouse-vertical-thumbup-prefix (make-sparse-keymap))
|
||||
(define-key global-mouse-map mouse-vertical-thumbup-prefix
|
||||
'mouse-vertical-thumbup-prefix)
|
||||
|
||||
(let ((map (function mouse-vertical-thumbup-prefix)))
|
||||
(define-key map mouse-button-right 'mouse-scroll-down-full)
|
||||
(define-key map mouse-button-left 'mouse-scroll-down-full)
|
||||
(define-key map mouse-button-middle 'mouse-scroll-down-full))
|
||||
|
||||
(fset 'mouse-vertical-thumbdown-prefix (make-sparse-keymap))
|
||||
(define-key global-mouse-map mouse-vertical-thumbdown-prefix
|
||||
'mouse-vertical-thumbdown-prefix)
|
||||
|
||||
(let ((map (function mouse-vertical-thumbdown-prefix)))
|
||||
(define-key map mouse-button-right 'mouse-scroll-up-full)
|
||||
(define-key map mouse-button-left 'mouse-scroll-up-full)
|
||||
(define-key map mouse-button-middle 'mouse-scroll-up-full))
|
||||
|
||||
;; Horizontal bar
|
||||
|
||||
(fset 'mouse-horizontal-scroll-bar-prefix (make-sparse-keymap))
|
||||
(define-key global-mouse-map mouse-horizontal-scroll-bar-prefix
|
||||
'mouse-horizontal-scroll-bar-prefix)
|
||||
|
||||
(let ((map (function mouse-horizontal-scroll-bar-prefix)))
|
||||
(define-key map mouse-button-right 'mouse-scroll-right)
|
||||
(define-key map mouse-button-left 'mouse-scroll-left)
|
||||
(define-key map mouse-button-middle 'mouse-scroll-absolute-horizontally))
|
||||
|
||||
(fset 'mouse-horizontal-thumbleft-prefix (make-sparse-keymap))
|
||||
(define-key global-mouse-map mouse-horizontal-thumbleft-prefix
|
||||
'mouse-horizontal-thumbleft-prefix)
|
||||
|
||||
(let ((map (function mouse-horizontal-thumbleft-prefix)))
|
||||
(define-key map mouse-button-right 'mouse-scroll-left-full)
|
||||
(define-key map mouse-button-left 'mouse-scroll-left-full)
|
||||
(define-key map mouse-button-middle 'mouse-scroll-left-full))
|
||||
|
||||
(fset 'mouse-horizontal-thumbright-prefix (make-sparse-keymap))
|
||||
(define-key global-mouse-map mouse-horizontal-thumbright-prefix
|
||||
'mouse-horizontal-thumbright-prefix)
|
||||
|
||||
(let ((map (function mouse-horizontal-thumbright-prefix)))
|
||||
(define-key map mouse-button-right 'mouse-scroll-right-full)
|
||||
(define-key map mouse-button-left 'mouse-scroll-right-full)
|
||||
(define-key map mouse-button-middle 'mouse-scroll-right-full))
|
||||
;;; (fset 'mouse-vertical-scroll-bar-prefix (make-sparse-keymap))
|
||||
;;; (define-key global-mouse-map mouse-vertical-scroll-bar-prefix
|
||||
;;; 'mouse-vertical-scroll-bar-prefix)
|
||||
;;;
|
||||
;;; (defun mouse-scroll-motion (event)
|
||||
;;; (interactive "e")
|
||||
;;; (let ((pos (car (car event)))
|
||||
;;; (length (car (cdr (car event)))))
|
||||
;;; (message "[%d %d]" pos length)))
|
||||
;;;
|
||||
;;; (let ((map (function mouse-vertical-scroll-bar-prefix)))
|
||||
;;; (define-key map mouse-button-right 'mouse-scroll-down)
|
||||
;;; (define-key map mouse-button-left 'mouse-scroll-up)
|
||||
;;; (define-key map mouse-button-middle 'mouse-scroll-absolute)
|
||||
;;; (define-key map mouse-motion 'x-horizontal-line))
|
||||
;;;
|
||||
;;; ;(fset 'mouse-vertical-slider-prefix (make-sparse-keymap))
|
||||
;;; ;(define-key global-mouse-map mouse-vertical-slider-prefix
|
||||
;;; ; 'mouse-vertical-slider-prefix)
|
||||
;;;
|
||||
;;; ;(let ((map (function mouse-vertical-slider-prefix)))
|
||||
;;; ; (define-key map mouse-button-right 'mouse-scroll-move-cursor)
|
||||
;;; ; (define-key map mouse-button-left 'mouse-scroll-move-cursor)
|
||||
;;; ; (define-key map mouse-button-middle 'mouse-scroll-move-cursor))
|
||||
;;;
|
||||
;;; (fset 'mouse-vertical-thumbup-prefix (make-sparse-keymap))
|
||||
;;; (define-key global-mouse-map mouse-vertical-thumbup-prefix
|
||||
;;; 'mouse-vertical-thumbup-prefix)
|
||||
;;;
|
||||
;;; (let ((map (function mouse-vertical-thumbup-prefix)))
|
||||
;;; (define-key map mouse-button-right 'mouse-scroll-down-full)
|
||||
;;; (define-key map mouse-button-left 'mouse-scroll-down-full)
|
||||
;;; (define-key map mouse-button-middle 'mouse-scroll-down-full))
|
||||
;;;
|
||||
;;; (fset 'mouse-vertical-thumbdown-prefix (make-sparse-keymap))
|
||||
;;; (define-key global-mouse-map mouse-vertical-thumbdown-prefix
|
||||
;;; 'mouse-vertical-thumbdown-prefix)
|
||||
;;;
|
||||
;;; (let ((map (function mouse-vertical-thumbdown-prefix)))
|
||||
;;; (define-key map mouse-button-right 'mouse-scroll-up-full)
|
||||
;;; (define-key map mouse-button-left 'mouse-scroll-up-full)
|
||||
;;; (define-key map mouse-button-middle 'mouse-scroll-up-full))
|
||||
;;;
|
||||
;;; ;; Horizontal bar
|
||||
;;;
|
||||
;;; (fset 'mouse-horizontal-scroll-bar-prefix (make-sparse-keymap))
|
||||
;;; (define-key global-mouse-map mouse-horizontal-scroll-bar-prefix
|
||||
;;; 'mouse-horizontal-scroll-bar-prefix)
|
||||
;;;
|
||||
;;; (let ((map (function mouse-horizontal-scroll-bar-prefix)))
|
||||
;;; (define-key map mouse-button-right 'mouse-scroll-right)
|
||||
;;; (define-key map mouse-button-left 'mouse-scroll-left)
|
||||
;;; (define-key map mouse-button-middle 'mouse-scroll-absolute-horizontally))
|
||||
;;;
|
||||
;;; (fset 'mouse-horizontal-thumbleft-prefix (make-sparse-keymap))
|
||||
;;; (define-key global-mouse-map mouse-horizontal-thumbleft-prefix
|
||||
;;; 'mouse-horizontal-thumbleft-prefix)
|
||||
;;;
|
||||
;;; (let ((map (function mouse-horizontal-thumbleft-prefix)))
|
||||
;;; (define-key map mouse-button-right 'mouse-scroll-left-full)
|
||||
;;; (define-key map mouse-button-left 'mouse-scroll-left-full)
|
||||
;;; (define-key map mouse-button-middle 'mouse-scroll-left-full))
|
||||
;;;
|
||||
;;; (fset 'mouse-horizontal-thumbright-prefix (make-sparse-keymap))
|
||||
;;; (define-key global-mouse-map mouse-horizontal-thumbright-prefix
|
||||
;;; 'mouse-horizontal-thumbright-prefix)
|
||||
;;;
|
||||
;;; (let ((map (function mouse-horizontal-thumbright-prefix)))
|
||||
;;; (define-key map mouse-button-right 'mouse-scroll-right-full)
|
||||
;;; (define-key map mouse-button-left 'mouse-scroll-right-full)
|
||||
;;; (define-key map mouse-button-middle 'mouse-scroll-right-full))
|
||||
|
||||
|
||||
;;;;
|
||||
|
|
@ -402,10 +327,10 @@ The text before the mouse position, on the same line, is used as the prefix."
|
|||
(x-erase-rectangle (selected-screen))
|
||||
(setq last-line-drawn nil))))
|
||||
|
||||
(defun test-x-rectangle ()
|
||||
(use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap)))
|
||||
(define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing)
|
||||
(define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box))
|
||||
;;; (defun test-x-rectangle ()
|
||||
;;; (use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap)))
|
||||
;;; (define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing)
|
||||
;;; (define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box))
|
||||
|
||||
;;
|
||||
;; Here is how to do double clicking in lisp. About to change.
|
||||
|
|
@ -433,10 +358,10 @@ The text before the mouse position, on the same line, is used as the prefix."
|
|||
(> (- (nth 4 event ) double-start) double-click-interval)
|
||||
(setq double-start nil)))
|
||||
|
||||
(defun x-test-doubleclick ()
|
||||
(use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap)))
|
||||
(define-key doubleclick-test-map mouse-button-left 'double-down)
|
||||
(define-key doubleclick-test-map mouse-button-left-up 'double-up))
|
||||
;;; (defun x-test-doubleclick ()
|
||||
;;; (use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap)))
|
||||
;;; (define-key doubleclick-test-map mouse-button-left 'double-down)
|
||||
;;; (define-key doubleclick-test-map mouse-button-left-up 'double-up))
|
||||
|
||||
;;
|
||||
;; This scrolls while button is depressed. Use preferable in scrollbar.
|
||||
|
|
@ -467,12 +392,12 @@ The text before the mouse position, on the same line, is used as the prefix."
|
|||
(setq scrolled-lines 0)
|
||||
(sleep-for 1))
|
||||
|
||||
(defun x-testing-scroll ()
|
||||
(let ((scrolling-map (function mouse-vertical-scroll-bar-prefix)))
|
||||
(define-key scrolling-map mouse-button-left 'incr-scroll-down)
|
||||
(define-key scrolling-map mouse-button-right 'incr-scroll-up)
|
||||
(define-key scrolling-map mouse-button-left-up 'incr-scroll-stop)
|
||||
(define-key scrolling-map mouse-button-right-up 'incr-scroll-stop)))
|
||||
;;; (defun x-testing-scroll ()
|
||||
;;; (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix)))
|
||||
;;; (define-key scrolling-map mouse-button-left 'incr-scroll-down)
|
||||
;;; (define-key scrolling-map mouse-button-right 'incr-scroll-up)
|
||||
;;; (define-key scrolling-map mouse-button-left-up 'incr-scroll-stop)
|
||||
;;; (define-key scrolling-map mouse-button-right-up 'incr-scroll-stop)))
|
||||
|
||||
;;
|
||||
;; Some playthings suitable for picture mode? They need work.
|
||||
|
|
@ -522,3 +447,10 @@ The text before the mouse position, on the same line, is used as the prefix."
|
|||
(mouse-multiple-insert
|
||||
(- (car relative-coordinate) (current-column)) " "))
|
||||
((= (current-column) (car relative-coordinate)) (ding))))))
|
||||
|
||||
|
||||
;;; Bindings for mouse commands.
|
||||
|
||||
(global-set-key [mouse-1] 'mouse-set-point)
|
||||
(global-set-key [S-mouse-1] 'mouse-set-mark)
|
||||
(global-set-key [mouse-3] 'mouse-delete-other-windows)
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue