-;; Mouse support that is independent of window systems.
-;; Copyright (C) 1988 Free Software Foundation, Inc.
-
-;; 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 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.
-
-(provide 'mouse)
-
-\f
-(defun mouse-select ()
- "Select Emacs window the mouse is on."
- (interactive "@"))
-
-(defun mouse-delete-window ()
- "Delete the Emacs window the mouse is on."
- (interactive "@")
- (delete-window))
-
-(defun mouse-keep-one-window ()
- "Select Emacs window mouse is on, then kill all other Emacs windows."
- (interactive "@")
- (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-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)))
- (move-to-column (+ (car relative-coordinate) (current-column)
- (window-hscroll (selected-window))))
- (what-line)))))
-
-(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")
- (let ((point-save (point)))
- (unwind-protect
- (progn (mouse-set-point event)
- (push-mark nil t)
- (sleep-for 1))
- (goto-char point-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))
-\f
-;; Commands for the scroll bar.
-
-(defun mouse-scroll-down (nlines)
- (interactive "@p")
- (scroll-down nlines))
-
-(defun mouse-scroll-up (nlines)
- (interactive "@p")
- (scroll-up nlines))
-
-(defun mouse-scroll-down-full ()
- (interactive "@")
- (scroll-down nil))
-
-(defun mouse-scroll-up-full ()
- (interactive "@")
- (scroll-up nil))
-
-(defun mouse-scroll-move-cursor (nlines)
- (interactive "@p")
- (move-to-window-line nlines))
-
-(defun mouse-scroll-absolute (event)
- (interactive "@e")
- (let* ((pos (car event))
- (position (car pos))
- (length (car (cdr pos))))
- (if (<= length 0) (setq length 1))
- (let* ((scale-factor (max 1 (/ length (/ 8000000 (buffer-size)))))
- (newpos (* (/ (* (/ (buffer-size) scale-factor)
- position)
- length)
- scale-factor)))
- (goto-char newpos)
- (recenter '(4)))))
-
-(defun mouse-scroll-left (ncolumns)
- (interactive "@p")
- (scroll-left ncolumns))
-
-(defun mouse-scroll-right (ncolumns)
- (interactive "@p")
- (scroll-right ncolumns))
-
-(defun mouse-scroll-left-full ()
- (interactive "@")
- (scroll-left nil))
-
-(defun mouse-scroll-right-full ()
- (interactive "@")
- (scroll-right nil))
-
-(defun mouse-scroll-move-cursor-horizontally (ncolumns)
- (interactive "@p")
- (move-to-column ncolumns))
-
-(defun mouse-scroll-absolute-horizontally (event)
- (interactive "@e")
- (let* ((pos (car event))
- (position (car pos))
- (length (car (cdr pos))))
- (set-window-hscroll (selected-window) 33)))
-
-;; 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))
-
-
-;;
-;; Here are experimental things being tested. Mouse events
-;; are of the form:
-;; ((x y) window screen-part key-sequence timestamp)
-
-;;
-;; Dynamically track mouse coordinates
-;;
-
-(defun track-mouse (event)
- "Track the coordinates, absolute and relative, of the mouse."
- (interactive "@e")
- (while mouse-grabbed
- (let* ((pos (read-mouse-position (selected-screen)))
- (abs-x (car pos))
- (abs-y (cdr pos))
- (relative-coordinate (coordinates-in-window-p
- (list (car pos) (cdr pos))
- (selected-window))))
- (if (consp relative-coordinate)
- (message "mouse: [%d %d], (%d %d)" abs-x abs-y
- (car relative-coordinate)
- (car (cdr relative-coordinate)))
- (message "mouse: [%d %d]" abs-x abs-y)))))
-
-;;
-;; Dynamically put a box around the line indicated by point
-;;
-
-(require 'backquote)
-
-(defun mouse-select-buffer-line (event)
- (interactive "@e")
- (let ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window)))
- (abs-y (car (cdr (car event)))))
- (if (consp relative-coordinate)
- (progn
- (save-excursion
- (move-to-window-line (car (cdr relative-coordinate)))
- (x-draw-rectangle
- (selected-screen)
- abs-y 0
- (save-excursion
- (move-to-window-line (car (cdr relative-coordinate)))
- (end-of-line)
- (push-mark nil t)
- (beginning-of-line)
- (- (region-end) (region-beginning))) 1)
- (setq the-buffer (Buffer-menu-buffer t)))
- (sit-for 1)
- (x-erase-rectangle (selected-screen))))))
-
-(defvar last-line-drawn nil)
-(defvar begin-delim "[^ \t]")
-(defvar end-delim "[^ \t]")
-
-(defun mouse-boxing (event)
- (interactive "@e")
- (save-excursion
- (let ((screen (selected-screen)))
- (while (= (x-mouse-events) 0)
- (let* ((pos (read-mouse-position screen))
- (abs-x (car pos))
- (abs-y (cdr pos))
- (relative-coordinate
- (coordinates-in-window-p (` ((, abs-x) (, abs-y)))
- (selected-window)))
- (begin-reg nil)
- (end-reg nil)
- (end-column nil)
- (begin-column nil))
- (if (and (consp relative-coordinate)
- (or (not last-line-drawn)
- (not (= last-line-drawn abs-y))))
- (progn
- (move-to-window-line (car (cdr relative-coordinate)))
- (if (= (following-char) 10)
- ()
- (progn
- (setq begin-reg (1- (re-search-forward end-delim)))
- (setq begin-column (1- (current-column)))
- (end-of-line)
- (setq end-reg (1+ (re-search-backward begin-delim)))
- (setq end-column (1+ (current-column)))
- (message "%s" (buffer-substring begin-reg end-reg))
- (x-draw-rectangle screen
- (setq last-line-drawn abs-y)
- begin-column
- (- end-column begin-column) 1))))))))))
-
-(defun mouse-erase-box ()
- (interactive)
- (if last-line-drawn
- (progn
- (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))
-
-;;
-;; Here is how to do double clicking in lisp. About to change.
-;;
-
-(defvar double-start nil)
-(defconst double-click-interval 300
- "Max ticks between clicks")
-
-(defun double-down (event)
- (interactive "@e")
- (if double-start
- (let ((interval (- (nth 4 event) double-start)))
- (if (< interval double-click-interval)
- (progn
- (backward-up-list 1)
- ;; (message "Interval %d" interval)
- (sleep-for 1)))
- (setq double-start nil))
- (setq double-start (nth 4 event))))
-
-(defun double-up (event)
- (interactive "@e")
- (and double-start
- (> (- (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))
-
-;;
-;; This scrolls while button is depressed. Use preferable in scrollbar.
-;;
-
-(defvar scrolled-lines 0)
-(defconst scroll-speed 1)
-
-(defun incr-scroll-down (event)
- (interactive "@e")
- (setq scrolled-lines 0)
- (incremental-scroll scroll-speed))
-
-(defun incr-scroll-up (event)
- (interactive "@e")
- (setq scrolled-lines 0)
- (incremental-scroll (- scroll-speed)))
-
-(defun incremental-scroll (n)
- (while (= (x-mouse-events) 0)
- (setq scrolled-lines (1+ (* scroll-speed scrolled-lines)))
- (scroll-down n)
- (sit-for 300 t)))
-
-(defun incr-scroll-stop (event)
- (interactive "@e")
- (message "Scrolled %d lines" scrolled-lines)
- (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)))
-
-;;
-;; Some playthings suitable for picture mode? They need work.
-;;
-
-(defun mouse-kill-rectangle (event)
- "Kill the rectangle between point and the mouse cursor."
- (interactive "@e")
- (let ((point-save (point)))
- (save-excursion
- (mouse-set-point event)
- (push-mark nil t)
- (if (> point-save (point))
- (kill-rectangle (point) point-save)
- (kill-rectangle point-save (point))))))
-
-(defun mouse-open-rectangle (event)
- "Kill the rectangle between point and the mouse cursor."
- (interactive "@e")
- (let ((point-save (point)))
- (save-excursion
- (mouse-set-point event)
- (push-mark nil t)
- (if (> point-save (point))
- (open-rectangle (point) point-save)
- (open-rectangle point-save (point))))))
-
-;; Must be a better way to do this.
-
-(defun mouse-multiple-insert (n char)
- (while (> n 0)
- (insert char)
- (setq n (1- n))))
-
-;; What this could do is not finalize until button was released.
-
-(defun mouse-move-text (event)
- "Move text from point to cursor position, inserting spaces."
- (interactive "@e")
- (let* ((relative-coordinate
- (coordinates-in-window-p (car event) (selected-window))))
- (if (consp relative-coordinate)
- (cond ((> (current-column) (car relative-coordinate))
- (delete-char
- (- (car relative-coordinate) (current-column))))
- ((< (current-column) (car relative-coordinate))
- (mouse-multiple-insert
- (- (car relative-coordinate) (current-column)) " "))
- ((= (current-column) (car relative-coordinate)) (ding))))))
+;;; mouse.el --- window system-independent mouse support.
+
+;;; Copyright (C) 1993 Free Software Foundation, Inc.
+
+;; Maintainer: FSF
+;; Keywords: hardware
+
+;;; 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, 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;; Commentary:
+
+;; This package provides various useful commands (including help
+;; system access) through the mouse. All this code assumes that mouse
+;; interpretation has been abstracted into Emacs input events.
+;;
+;; The code is rather X-dependent.
+
+;;; Code:
+
+;;; Utility functions.
+
+;;; Indent track-mouse like progn.
+(put 'track-mouse 'lisp-indent-function 0)
+
+(defvar mouse-yank-at-point nil
+ "*If non-nil, mouse yank commands yank at point instead of at click.")
+\f
+(defun mouse-delete-window (click)
+ "Delete the window you click on.
+This must be bound to a mouse click."
+ (interactive "e")
+ (delete-window (posn-window (event-start click))))
+
+(defun mouse-tear-off-window (click)
+ "Delete the window clicked on, and create a new frame displaying its buffer."
+ (interactive "e")
+ (let* ((window (posn-window (event-start click)))
+ (buf (window-buffer window))
+ (frame (new-frame)))
+ (select-frame frame)
+ (switch-to-buffer buf)
+ (delete-window window)))
+
+(defun mouse-delete-other-windows ()
+ "Delete all window except the one you click on."
+ (interactive "@")
+ (delete-other-windows))
+
+(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 "@e")
+ (let ((start (event-start click)))
+ (select-window (posn-window start))
+ (let ((new-height (if (eq (posn-point start) 'vertical-scroll-bar)
+ (scroll-bar-scale (posn-col-row start)
+ (1- (window-height)))
+ (1+ (cdr (posn-col-row (event-end click))))))
+ (first-line window-min-height)
+ (last-line (- (window-height) window-min-height)))
+ (if (< last-line first-line)
+ (error "window too short to split")
+ (split-window-vertically
+ (min (max new-height first-line) last-line))))))
+
+(defun mouse-split-window-horizontally (click)
+ "Select Emacs window mouse is on, then split it horizontally in half.
+The window is split at the column clicked on.
+This command must be bound to a mouse click."
+ (interactive "@e")
+ (let ((start (event-start click)))
+ (select-window (posn-window start))
+ (let ((new-width (1+ (car (posn-col-row (event-end click)))))
+ (first-col window-min-width)
+ (last-col (- (window-width) window-min-width)))
+ (if (< last-col first-col)
+ (error "window too narrow to split")
+ (split-window-horizontally
+ (min (max new-width first-col) last-col))))))
+
+(defun 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")
+ ;; Use event-end in case called from mouse-drag-region.
+ ;; If EVENT is a click, event-end and event-start give same value.
+ (let ((posn (event-end event)))
+ (and (window-minibuffer-p (posn-window posn))
+ (not (minibuffer-window-active-p (posn-window posn)))
+ (error "Minibuffer window is not active"))
+ (select-window (posn-window posn))
+ (if (numberp (posn-point posn))
+ (goto-char (posn-point posn)))))
+
+(defun mouse-set-region (click)
+ "Set the region to the text dragged over, and copy to kill ring.
+This should be bound to a mouse drag event."
+ (interactive "e")
+ (let ((posn (event-start click))
+ (end (event-end click)))
+ (select-window (posn-window posn))
+ (if (numberp (posn-point posn))
+ (goto-char (posn-point posn)))
+ ;; If mark is highlighted, no need to bounce the cursor.
+ (or (and transient-mark-mode
+ (eq (framep (selected-frame)) 'x))
+ (sit-for 1))
+ (push-mark)
+ (set-mark (point))
+ (if (numberp (posn-point end))
+ (goto-char (posn-point end)))
+ ;; Don't set this-command to kill-region, so that a following
+ ;; C-w will not double the text in the kill ring.
+ (let (this-command)
+ (copy-region-as-kill (mark) (point)))))
+
+(defvar mouse-scroll-delay 0.25
+ "*The pause between scroll steps caused by mouse drags, in seconds.
+If you drag the mouse beyond the edge of a window, Emacs scrolls the
+window to bring the text beyond that edge into view, with a delay of
+this many seconds between scroll steps. Scrolling stops when you move
+the mouse back into the window, or release the button.
+This variable's value may be non-integral.
+Setting this to zero causes Emacs to scroll as fast as it can.")
+
+(defun mouse-scroll-subr (jump &optional overlay start)
+ "Scroll the selected window JUMP lines at a time, until new input arrives.
+If OVERLAY is an overlay, let it stretch from START to the far edge of
+the newly visible text.
+Upon exit, point is at the far edge of the newly visible text."
+ (while (progn
+ (goto-char (window-start))
+ (if (not (zerop (vertical-motion jump)))
+ (progn
+ (set-window-start (selected-window) (point))
+ (if (natnump jump)
+ (progn
+ (goto-char (window-end (selected-window)))
+ ;; window-end doesn't reflect the window's new
+ ;; start position until the next redisplay. Hurrah.
+ (vertical-motion (1- jump)))
+ (goto-char (window-start (selected-window))))
+ (if overlay
+ (move-overlay overlay start (point)))
+ (if (not (eobp))
+ (sit-for mouse-scroll-delay))))))
+ (point))
+
+(defvar mouse-drag-overlay (make-overlay 1 1))
+(overlay-put mouse-drag-overlay 'face 'region)
+
+(defvar mouse-selection-click-count 0)
+
+(defun mouse-drag-region (start-event)
+ "Set the region to the text that the mouse is dragged over.
+Highlight the drag area as you move the mouse.
+This must be bound to a button-down mouse event.
+In Transient Mark mode, the highlighting remains once you
+release the mouse button. Otherwise, it does not."
+ (interactive "e")
+ (let* ((start-posn (event-start start-event))
+ (start-point (posn-point start-posn))
+ (start-window (posn-window start-posn))
+ (start-frame (window-frame start-window))
+ (bounds (window-edges start-window))
+ (top (nth 1 bounds))
+ (bottom (if (window-minibuffer-p start-window)
+ (nth 3 bounds)
+ ;; Don't count the mode line.
+ (1- (nth 3 bounds))))
+ (click-count (1- (event-click-count start-event))))
+ (setq mouse-selection-click-count click-count)
+ (mouse-set-point start-event)
+ (let ((range (mouse-start-end start-point start-point click-count)))
+ (move-overlay mouse-drag-overlay (car range) (nth 1 range)
+ (window-buffer start-window)))
+ (deactivate-mark)
+ (let (event end end-point)
+ (track-mouse
+ (while (progn
+ (setq event (read-event))
+ (or (mouse-movement-p event)
+ (eq (car-safe event) 'switch-frame)))
+ (if (eq (car-safe event) 'switch-frame)
+ nil
+ (setq end (event-end event)
+ end-point (posn-point end))
+
+ (cond
+
+ ;; Ignore switch-frame events.
+ ((eq (car-safe event) 'switch-frame))
+
+ ;; Are we moving within the original window?
+ ((and (eq (posn-window end) start-window)
+ (integer-or-marker-p end-point))
+ (goto-char end-point)
+ (let ((range (mouse-start-end start-point (point) click-count)))
+ (move-overlay mouse-drag-overlay (car range) (nth 1 range))))
+
+ ;; Are we moving on a different window on the same frame?
+ ((and (windowp (posn-window end))
+ (eq (window-frame (posn-window end)) start-frame))
+ (let ((mouse-row
+ (+ (nth 1 (window-edges (posn-window end)))
+ (cdr (posn-col-row end)))))
+ (cond
+ ((< mouse-row top)
+ (mouse-scroll-subr
+ (- mouse-row top) mouse-drag-overlay start-point))
+ ((and (not (eobp))
+ (>= mouse-row bottom))
+ (mouse-scroll-subr (1+ (- mouse-row bottom))
+ mouse-drag-overlay start-point)))))
+
+ (t
+ (let ((mouse-y (cdr (cdr (mouse-position))))
+ (menu-bar-lines (or (cdr (assq 'menu-bar-lines
+ (frame-parameters)))
+ 0)))
+
+ ;; Are we on the menu bar?
+ (and (integerp mouse-y) (< mouse-y menu-bar-lines)
+ (mouse-scroll-subr (- mouse-y menu-bar-lines)
+ mouse-drag-overlay start-point))))))))
+
+ (if (and (eq (get (event-basic-type event) 'event-kind) 'mouse-click)
+ (eq (posn-window (event-end event)) start-window)
+ (numberp (posn-point (event-end event))))
+ (let ((fun (key-binding (vector (car event)))))
+ (if (memq fun '(mouse-set-region mouse-set-point))
+ (if (not (= (overlay-start mouse-drag-overlay)
+ (overlay-end mouse-drag-overlay)))
+ (let (this-command)
+ (push-mark (overlay-start mouse-drag-overlay) t t)
+ (goto-char (overlay-end mouse-drag-overlay))
+ (copy-region-as-kill (point) (mark t)))
+ (goto-char (overlay-end mouse-drag-overlay))
+ (setq this-command 'mouse-set-point))
+ (if (fboundp fun)
+ (funcall fun event)))))
+ (delete-overlay mouse-drag-overlay))))
+\f
+;; Commands to handle xterm-style multiple clicks.
+
+(defun mouse-skip-word (dir)
+ "Skip over word, over whitespace, or over identical punctuation.
+If DIR is positive skip forward; if negative, skip backward."
+ (let* ((char (following-char))
+ (syntax (char-to-string (char-syntax char))))
+ (if (or (string= syntax "w") (string= syntax " "))
+ (if (< dir 0)
+ (skip-syntax-backward syntax)
+ (skip-syntax-forward syntax))
+ (if (< dir 0)
+ (while (and (not (bobp)) (= (preceding-char) char))
+ (forward-char -1))
+ (while (and (not (eobp)) (= (following-char) char))
+ (forward-char 1))))))
+
+;; Return a list of region bounds based on START and END according to MODE.
+;; If MODE is 0 then set point to (min START END), mark to (max START END).
+;; If MODE is 1 then set point to start of word at (min START END),
+;; mark to end of word at (max START END).
+;; If MODE is 2 then do the same for lines.
+(defun mouse-start-end (start end mode)
+ (if (> start end)
+ (let ((temp start))
+ (setq start end
+ end temp)))
+ (setq mode (mod mode 3))
+ (cond ((= mode 0)
+ (list start end))
+ ((and (= mode 1)
+ (= start end)
+ (char-after start)
+ (= (char-syntax (char-after start)) ?\())
+ (list start
+ (save-excursion
+ (goto-char start)
+ (forward-sexp 1)
+ (point))))
+ ((and (= mode 1)
+ (= start end)
+ (char-after start)
+ (= (char-syntax (char-after start)) ?\)))
+ (list (save-excursion
+ (goto-char (1+ start))
+ (backward-sexp 1)
+ (point))
+ (1+ start)))
+ ((= mode 1)
+ (list (save-excursion
+ (goto-char start)
+ (mouse-skip-word -1)
+ (point))
+ (save-excursion
+ (goto-char end)
+ (mouse-skip-word 1)
+ (point))))
+ ((= mode 2)
+ (list (save-excursion
+ (goto-char start)
+ (beginning-of-line 1)
+ (point))
+ (save-excursion
+ (goto-char end)
+ (forward-line 1)
+ (point))))))
+\f
+;; Subroutine: set the mark where CLICK happened,
+;; but don't do anything else.
+(defun mouse-set-mark-fast (click)
+ (let ((posn (event-start click)))
+ (select-window (posn-window posn))
+ (if (numberp (posn-point posn))
+ (push-mark (posn-point posn) t t))))
+
+;; Momentarily show where the mark is, if highlighting doesn't show it.
+(defun mouse-show-mark ()
+ (or transient-mark-mode
+ (save-excursion
+ (goto-char (mark t))
+ (sit-for 1))))
+
+(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 "e")
+ (let ((point-save (point)))
+ (unwind-protect
+ (progn (mouse-set-point click)
+ (push-mark nil t t)
+ (or transient-mark-mode
+ (sit-for 1)))
+ (goto-char point-save))))
+
+(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 "e")
+ (let ((click-posn (posn-point (event-start click))))
+ (if (numberp click-posn)
+ (kill-region (min (point) click-posn)
+ (max (point) click-posn)))))
+
+(defun mouse-yank-at-click (click arg)
+ "Insert the last stretch of killed text at the position clicked on.
+Also move point to one end of the text thus inserted (normally the end).
+Prefix arguments are interpreted as with \\[yank].
+If `mouse-yank-at-point' is non-nil, insert at point
+regardless of where you click."
+ (interactive "e\nP")
+ (or mouse-yank-at-point (mouse-set-point click))
+ (setq this-command 'yank)
+ (yank arg))
+
+(defun mouse-kill-ring-save (click)
+ "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 "e")
+ (mouse-set-mark-fast click)
+ (kill-ring-save (point) (mark t))
+ (mouse-show-mark))
+
+;;; This function used to delete the text between point and the mouse
+;;; whenever it was equal to the front of the kill ring, but some
+;;; people found that confusing.
+
+;;; A list (TEXT START END), describing the text and position of the last
+;;; invocation of mouse-save-then-kill.
+(defvar mouse-save-then-kill-posn nil)
+
+(defun mouse-save-then-kill-delete-region (beg end)
+ ;; We must make our own undo boundaries
+ ;; because they happen automatically only for the current buffer.
+ (undo-boundary)
+ (if (or (= beg end) (eq buffer-undo-list t))
+ ;; If we have no undo list in this buffer,
+ ;; just delete.
+ (delete-region beg end)
+ ;; Delete, but make the undo-list entry share with the kill ring.
+ ;; First, delete just one char, so in case buffer is being modified
+ ;; for the first time, the undo list records that fact.
+ (delete-region beg
+ (+ beg (if (> end beg) 1 -1)))
+ (let ((buffer-undo-list buffer-undo-list))
+ ;; Undo that deletion--but don't change the undo list!
+ (primitive-undo 1 buffer-undo-list)
+ ;; Now delete the rest of the specified region,
+ ;; but don't record it.
+ (setq buffer-undo-list t)
+ (if (/= (length (car kill-ring)) (- (max end beg) (min end beg)))
+ (error "Lossage in mouse-save-then-kill-delete-region"))
+ (delete-region beg end))
+ (let ((tail buffer-undo-list))
+ ;; Search back in buffer-undo-list for the string
+ ;; that came from deleting one character.
+ (while (and tail (not (stringp (car (car tail)))))
+ (setq tail (cdr tail)))
+ ;; Replace it with an entry for the entire deleted text.
+ (and tail
+ (setcar tail (cons (car kill-ring) (min beg end))))))
+ (undo-boundary))
+
+(defun mouse-save-then-kill (click)
+ "Save text to point in kill ring; the second time, kill the text.
+If the text between point and the mouse is the same as what's
+at the front of the kill ring, this deletes the text.
+Otherwise, it adds the text to the kill ring, like \\[kill-ring-save],
+which prepares for a second click to delete the text.
+
+If you have selected words or lines, this command extends the
+selection through the word or line clicked on. If you do this
+again in a different position, it extends the selection again.
+If you do this twice in the same position, the selection is killed."
+ (interactive "e")
+ (let ((click-posn (posn-point (event-start click)))
+ ;; Don't let a subsequent kill command append to this one:
+ ;; prevent setting this-command to kill-region.
+ (this-command this-command))
+ (if (> (mod mouse-selection-click-count 3) 0)
+ (if (not (and (eq last-command 'mouse-save-then-kill)
+ (equal click-posn
+ (car (cdr-safe (cdr-safe mouse-save-then-kill-posn))))))
+ ;; Find both ends of the object selected by this click.
+ (let* ((range
+ (mouse-start-end click-posn click-posn
+ mouse-selection-click-count)))
+ ;; Move whichever end is closer to the click.
+ ;; That's what xterm does, and it seems reasonable.
+ (if (< (abs (- click-posn (mark t)))
+ (abs (- click-posn (point))))
+ (set-mark (car range))
+ (goto-char (nth 1 range)))
+ ;; We have already put the old region in the kill ring.
+ ;; Replace it with the extended region.
+ ;; (It would be annoying to make a separate entry.)
+ (setcar kill-ring (buffer-substring (point) (mark t)))
+ (if interprogram-cut-function
+ (funcall interprogram-cut-function (car kill-ring)))
+ ;; Arrange for a repeated mouse-3 to kill this region.
+ (setq mouse-save-then-kill-posn
+ (list (car kill-ring) (point) click-posn))
+ (mouse-show-mark))
+ ;; If we click this button again without moving it,
+ ;; that time kill.
+ (mouse-save-then-kill-delete-region (point) (mark))
+ (setq mouse-selection-click-count 0)
+ (setq mouse-save-then-kill-posn nil))
+ (if (and (eq last-command 'mouse-save-then-kill)
+ mouse-save-then-kill-posn
+ (eq (car mouse-save-then-kill-posn) (car kill-ring))
+ (equal (cdr mouse-save-then-kill-posn) (list (point) click-posn)))
+ ;; If this is the second time we've called
+ ;; mouse-save-then-kill, delete the text from the buffer.
+ (progn
+ (mouse-save-then-kill-delete-region (point) (mark))
+ ;; After we kill, another click counts as "the first time".
+ (setq mouse-save-then-kill-posn nil))
+ (if (or (and (eq last-command 'mouse-save-then-kill)
+ mouse-save-then-kill-posn)
+ (and mark-active transient-mark-mode)
+ (and (eq last-command 'mouse-drag-region)
+ (or mark-even-if-inactive
+ (not transient-mark-mode))))
+ ;; We have a selection or suitable region, so adjust it.
+ (let* ((posn (event-start click))
+ (new (posn-point posn)))
+ (select-window (posn-window posn))
+ (if (numberp new)
+ (progn
+ ;; Move whichever end of the region is closer to the click.
+ ;; That is what xterm does, and it seems reasonable.
+ (if (< (abs (- new (point))) (abs (- new (mark t))))
+ (goto-char new)
+ (set-mark new))
+ (setq deactivate-mark nil)))
+ (setcar kill-ring (buffer-substring (point) (mark t)))
+ (if interprogram-cut-function
+ (funcall interprogram-cut-function (car kill-ring))))
+ ;; We just have point, so set mark here.
+ (mouse-set-mark-fast click)
+ (kill-ring-save (point) (mark t))
+ (mouse-show-mark))
+ (setq mouse-save-then-kill-posn
+ (list (car kill-ring) (point) click-posn))))))
+\f
+(global-set-key [M-mouse-1] 'mouse-start-secondary)
+(global-set-key [M-drag-mouse-1] 'mouse-set-secondary)
+(global-set-key [M-down-mouse-1] 'mouse-drag-secondary)
+(global-set-key [M-mouse-3] 'mouse-secondary-save-then-kill)
+(global-set-key [M-mouse-2] 'mouse-yank-secondary)
+
+;; An overlay which records the current secondary selection
+;; or else is deleted when there is no secondary selection.
+;; May be nil.
+(defvar mouse-secondary-overlay nil)
+
+;; A marker which records the specified first end for a secondary selection.
+;; May be nil.
+(defvar mouse-secondary-start nil)
+
+(defun mouse-start-secondary (click)
+ "Set one end of the secondary selection to the position clicked on.
+Use \\[mouse-secondary-save-then-kill] to set the other end
+and complete the secondary selection."
+ (interactive "e")
+ (let ((posn (event-start click)))
+ (save-excursion
+ (set-buffer (window-buffer (posn-window posn)))
+ ;; Cancel any preexisting secondary selection.
+ (if mouse-secondary-overlay
+ (delete-overlay mouse-secondary-overlay))
+ (if (numberp (posn-point posn))
+ (progn
+ (or mouse-secondary-start
+ (setq mouse-secondary-start (make-marker)))
+ (move-marker mouse-secondary-start (posn-point posn)))))))
+
+(defun mouse-set-secondary (click)
+ "Set the secondary selection to the text that the mouse is dragged over.
+This must be bound to a mouse drag event."
+ (interactive "e")
+ (let ((posn (event-start click))
+ beg
+ (end (event-end click)))
+ (save-excursion
+ (set-buffer (window-buffer (posn-window posn)))
+ (if (numberp (posn-point posn))
+ (setq beg (posn-point posn)))
+ (if mouse-secondary-overlay
+ (move-overlay mouse-secondary-overlay beg (posn-point end))
+ (setq mouse-secondary-overlay (make-overlay beg (posn-point end))))
+ (overlay-put mouse-secondary-overlay 'face 'secondary-selection))))
+
+(defun mouse-drag-secondary (start-event)
+ "Set the secondary selection to the text that the mouse is dragged over.
+Highlight the drag area as you move the mouse.
+This must be bound to a button-down mouse event."
+ (interactive "e")
+ (let* ((start-posn (event-start start-event))
+ (start-point (posn-point start-posn))
+ (start-window (posn-window start-posn))
+ (start-frame (window-frame start-window))
+ (bounds (window-edges start-window))
+ (top (nth 1 bounds))
+ (bottom (if (window-minibuffer-p start-window)
+ (nth 3 bounds)
+ ;; Don't count the mode line.
+ (1- (nth 3 bounds))))
+ (click-count (1- (event-click-count start-event))))
+ (save-excursion
+ (set-buffer (window-buffer start-window))
+ (setq mouse-selection-click-count click-count)
+ (or mouse-secondary-overlay
+ (setq mouse-secondary-overlay
+ (make-overlay (point) (point))))
+ (overlay-put mouse-secondary-overlay 'face 'secondary-selection)
+ (if (> (mod click-count 3) 0)
+ ;; Double or triple press: make an initial selection
+ ;; of one word or line.
+ (let ((range (mouse-start-end start-point start-point click-count)))
+ (set-marker mouse-secondary-start nil)
+ (move-overlay mouse-secondary-overlay 1 1
+ (window-buffer start-window))
+ (move-overlay mouse-secondary-overlay (car range) (nth 1 range)
+ (window-buffer start-window)))
+ ;; Single-press: cancel any preexisting secondary selection.
+ (or mouse-secondary-start
+ (setq mouse-secondary-start (make-marker)))
+ (set-marker mouse-secondary-start start-point)
+ (delete-overlay mouse-secondary-overlay))
+ (let (event end end-point)
+ (track-mouse
+ (while (progn
+ (setq event (read-event))
+ (or (mouse-movement-p event)
+ (eq (car-safe event) 'switch-frame)))
+
+ (if (eq (car-safe event) 'switch-frame)
+ nil
+ (setq end (event-end event)
+ end-point (posn-point end))
+ (cond
+
+ ;; Ignore switch-frame events.
+ ((eq (car-safe event) 'switch-frame))
+
+ ;; Are we moving within the original window?
+ ((and (eq (posn-window end) start-window)
+ (integer-or-marker-p end-point))
+ (if (/= start-point end-point)
+ (set-marker mouse-secondary-start nil))
+ (let ((range (mouse-start-end start-point end-point
+ click-count)))
+ (move-overlay mouse-secondary-overlay
+ (car range) (nth 1 range))))
+
+ ;; Are we moving on a different window on the same frame?
+ ((and (windowp (posn-window end))
+ (eq (window-frame (posn-window end)) start-frame))
+ (let ((mouse-row
+ (+ (nth 1 (window-edges (posn-window end)))
+ (cdr (posn-col-row end)))))
+ (cond
+ ((< mouse-row top)
+ (mouse-scroll-subr
+ (- mouse-row top) mouse-secondary-overlay start-point))
+ ((and (not (eobp))
+ (>= mouse-row bottom))
+ (mouse-scroll-subr (1+ (- mouse-row bottom))
+ mouse-drag-overlay start-point)))))
+
+ (t
+ (let ((mouse-y (cdr (cdr (mouse-position))))
+ (menu-bar-lines (or (cdr (assq 'menu-bar-lines
+ (frame-parameters)))
+ 0)))
+
+ ;; Are we on the menu bar?
+ (and (integerp mouse-y) (< mouse-y menu-bar-lines)
+ (mouse-scroll-subr (- mouse-y menu-bar-lines)
+ mouse-secondary-overlay start-point))))))))
+
+ (if (and (eq (get (event-basic-type event) 'event-kind) 'mouse-click)
+ (eq (posn-window (event-end event)) start-window)
+ (numberp (posn-point (event-end event))))
+ (if (marker-position mouse-secondary-start)
+ (save-window-excursion
+ (delete-overlay mouse-secondary-overlay)
+ (x-set-selection 'SECONDARY nil)
+ (select-window start-window)
+ (save-excursion
+ (goto-char mouse-secondary-start)
+ (sit-for 1)))
+ (x-set-selection
+ 'SECONDARY
+ (buffer-substring (overlay-start mouse-secondary-overlay)
+ (overlay-end mouse-secondary-overlay)))))))))
+
+(defun mouse-yank-secondary (click)
+ "Insert the secondary selection at the position clicked on.
+Move point to the end of the inserted text.
+If `mouse-yank-at-point' is non-nil, insert at point
+regardless of where you click."
+ (interactive "e")
+ (or mouse-yank-at-point (mouse-set-point click))
+ (insert (x-get-selection 'SECONDARY)))
+
+(defun mouse-kill-secondary ()
+ "Kill the text in the secondary selection.
+This is intended more as a keyboard command than as a mouse command
+but it can work as either one.
+
+The current buffer (in case of keyboard use), or the buffer clicked on,
+must be the one that the secondary selection is in. This requirement
+is to prevent accidents."
+ (interactive)
+ (let* ((keys (this-command-keys))
+ (click (elt keys (1- (length keys)))))
+ (or (eq (overlay-buffer mouse-secondary-overlay)
+ (if (listp click)
+ (window-buffer (posn-window (event-start click)))
+ (current-buffer)))
+ (error "Select or click on the buffer where the secondary selection is")))
+ (save-excursion
+ (set-buffer (overlay-buffer mouse-secondary-overlay))
+ (kill-region (overlay-start mouse-secondary-overlay)
+ (overlay-end mouse-secondary-overlay)))
+ (delete-overlay mouse-secondary-overlay)
+ (x-set-selection 'SECONDARY nil)
+ (setq mouse-secondary-overlay nil))
+
+(defun mouse-secondary-save-then-kill (click)
+ "Save text to point in kill ring; the second time, kill the text.
+If the text between point and the mouse is the same as what's
+at the front of the kill ring, this deletes the text.
+Otherwise, it adds the text to the kill ring, like \\[kill-ring-save],
+which prepares for a second click to delete the text.
+
+If you have selected words or lines, this command extends the
+selection through the word or line clicked on. If you do this
+again in a different position, it extends the selection again.
+If you do this twice in the same position, the selection is killed."
+ (interactive "e")
+ (let ((posn (event-start click))
+ (click-posn (posn-point (event-start click)))
+ ;; Don't let a subsequent kill command append to this one:
+ ;; prevent setting this-command to kill-region.
+ (this-command this-command))
+ (or (eq (window-buffer (posn-window posn))
+ (or (and mouse-secondary-overlay
+ (overlay-buffer mouse-secondary-overlay))
+ (if mouse-secondary-start
+ (marker-buffer mouse-secondary-start))))
+ (error "Wrong buffer"))
+ (save-excursion
+ (set-buffer (window-buffer (posn-window posn)))
+ (if (> (mod mouse-selection-click-count 3) 0)
+ (if (not (and (eq last-command 'mouse-secondary-save-then-kill)
+ (equal click-posn
+ (car (cdr-safe (cdr-safe mouse-save-then-kill-posn))))))
+ ;; Find both ends of the object selected by this click.
+ (let* ((range
+ (mouse-start-end click-posn click-posn
+ mouse-selection-click-count)))
+ ;; Move whichever end is closer to the click.
+ ;; That's what xterm does, and it seems reasonable.
+ (if (< (abs (- click-posn (overlay-start mouse-secondary-overlay)))
+ (abs (- click-posn (overlay-end mouse-secondary-overlay))))
+ (move-overlay mouse-secondary-overlay (car range)
+ (overlay-end mouse-secondary-overlay))
+ (move-overlay mouse-secondary-overlay
+ (overlay-start mouse-secondary-overlay)
+ (nth 1 range)))
+ ;; We have already put the old region in the kill ring.
+ ;; Replace it with the extended region.
+ ;; (It would be annoying to make a separate entry.)
+ (setcar kill-ring (buffer-substring
+ (overlay-start mouse-secondary-overlay)
+ (overlay-end mouse-secondary-overlay)))
+ (if interprogram-cut-function
+ (funcall interprogram-cut-function (car kill-ring)))
+ ;; Arrange for a repeated mouse-3 to kill this region.
+ (setq mouse-save-then-kill-posn
+ (list (car kill-ring) (point) click-posn)))
+ ;; If we click this button again without moving it,
+ ;; that time kill.
+ (progn
+ (mouse-save-then-kill-delete-region
+ (overlay-start mouse-secondary-overlay)
+ (overlay-end mouse-secondary-overlay))
+ (setq mouse-save-then-kill-posn nil)
+ (setq mouse-selection-click-count 0)
+ (delete-overlay mouse-secondary-overlay)))
+ (if (and (eq last-command 'mouse-secondary-save-then-kill)
+ mouse-save-then-kill-posn
+ (eq (car mouse-save-then-kill-posn) (car kill-ring))
+ (equal (cdr mouse-save-then-kill-posn) (list (point) click-posn)))
+ ;; If this is the second time we've called
+ ;; mouse-secondary-save-then-kill, delete the text from the buffer.
+ (progn
+ (mouse-save-then-kill-delete-region
+ (overlay-start mouse-secondary-overlay)
+ (overlay-end mouse-secondary-overlay))
+ (setq mouse-save-then-kill-posn nil)
+ (delete-overlay mouse-secondary-overlay))
+ (if (overlay-start mouse-secondary-overlay)
+ ;; We have a selection, so adjust it.
+ (progn
+ (if (numberp click-posn)
+ (progn
+ ;; Move whichever end of the region is closer to the click.
+ ;; That is what xterm does, and it seems reasonable.
+ (if (< (abs (- click-posn (overlay-start mouse-secondary-overlay)))
+ (abs (- click-posn (overlay-end mouse-secondary-overlay))))
+ (move-overlay mouse-secondary-overlay click-posn
+ (overlay-end mouse-secondary-overlay))
+ (move-overlay mouse-secondary-overlay
+ (overlay-start mouse-secondary-overlay)
+ click-posn))
+ (setq deactivate-mark nil)))
+ (setcar kill-ring (buffer-substring
+ (overlay-start mouse-secondary-overlay)
+ (overlay-end mouse-secondary-overlay)))
+ (if interprogram-cut-function
+ (funcall interprogram-cut-function (car kill-ring))))
+ (if mouse-secondary-start
+ ;; All we have is one end of a selection,
+ ;; so put the other end here.
+ (let ((start (+ 0 mouse-secondary-start)))
+ (kill-ring-save start click-posn)
+ (if mouse-secondary-overlay
+ (move-overlay mouse-secondary-overlay start click-posn)
+ (setq mouse-secondary-overlay (make-overlay start click-posn)))
+ (overlay-put mouse-secondary-overlay 'face 'secondary-selection))))
+ (setq mouse-save-then-kill-posn
+ (list (car kill-ring) (point) click-posn))))
+ (x-set-selection 'SECONDARY
+ (if (overlay-buffer mouse-secondary-overlay)
+ (buffer-substring
+ (overlay-start mouse-secondary-overlay)
+ (overlay-end mouse-secondary-overlay)))))))
+\f
+(defun mouse-buffer-menu (event)
+ "Pop up a menu of buffers for selection with the mouse.
+This switches buffers in the window that you clicked on,
+and selects that window."
+ (interactive "e")
+ (let ((menu
+ (list "Buffer Menu"
+ (cons "Select Buffer"
+ (let ((tail (buffer-list))
+ (maxbuf 0)
+ head)
+ (while tail
+ (or (eq ?\ (aref (buffer-name (car tail)) 0))
+ (setq maxbuf
+ (max maxbuf
+ (length (buffer-name (car tail))))))
+ (setq tail (cdr tail)))
+ (setq tail (buffer-list))
+ (while tail
+ (let ((elt (car tail)))
+ (if (not (string-match "^ "
+ (buffer-name elt)))
+ (setq head (cons
+ (cons
+ (format
+ (format "%%%ds %%s%%s %%s"
+ maxbuf)
+ (buffer-name elt)
+ (if (buffer-modified-p elt)
+ "*" " ")
+ (save-excursion
+ (set-buffer elt)
+ (if buffer-read-only "%" " "))
+ (or (buffer-file-name elt) ""))
+ elt)
+ head))))
+ (setq tail (cdr tail)))
+ (reverse head))))))
+ (let ((buf (x-popup-menu event menu))
+ (window (posn-window (event-start event))))
+ (if buf
+ (progn
+ (or (framep window) (select-window window))
+ (switch-to-buffer buf))))))
+\f
+;;; These need to be rewritten for the new scroll bar implementation.
+
+;;;!! ;; Commands for the scroll bar.
+;;;!!
+;;;!! (defun mouse-scroll-down (click)
+;;;!! (interactive "@e")
+;;;!! (scroll-down (1+ (cdr (mouse-coords click)))))
+;;;!!
+;;;!! (defun mouse-scroll-up (click)
+;;;!! (interactive "@e")
+;;;!! (scroll-up (1+ (cdr (mouse-coords click)))))
+;;;!!
+;;;!! (defun mouse-scroll-down-full ()
+;;;!! (interactive "@")
+;;;!! (scroll-down nil))
+;;;!!
+;;;!! (defun mouse-scroll-up-full ()
+;;;!! (interactive "@")
+;;;!! (scroll-up nil))
+;;;!!
+;;;!! (defun mouse-scroll-move-cursor (click)
+;;;!! (interactive "@e")
+;;;!! (move-to-window-line (1+ (cdr (mouse-coords click)))))
+;;;!!
+;;;!! (defun mouse-scroll-absolute (event)
+;;;!! (interactive "@e")
+;;;!! (let* ((pos (car event))
+;;;!! (position (car pos))
+;;;!! (length (car (cdr pos))))
+;;;!! (if (<= length 0) (setq length 1))
+;;;!! (let* ((scale-factor (max 1 (/ length (/ 8000000 (buffer-size)))))
+;;;!! (newpos (* (/ (* (/ (buffer-size) scale-factor)
+;;;!! position)
+;;;!! length)
+;;;!! scale-factor)))
+;;;!! (goto-char newpos)
+;;;!! (recenter '(4)))))
+;;;!!
+;;;!! (defun mouse-scroll-left (click)
+;;;!! (interactive "@e")
+;;;!! (scroll-left (1+ (car (mouse-coords click)))))
+;;;!!
+;;;!! (defun mouse-scroll-right (click)
+;;;!! (interactive "@e")
+;;;!! (scroll-right (1+ (car (mouse-coords click)))))
+;;;!!
+;;;!! (defun mouse-scroll-left-full ()
+;;;!! (interactive "@")
+;;;!! (scroll-left nil))
+;;;!!
+;;;!! (defun mouse-scroll-right-full ()
+;;;!! (interactive "@")
+;;;!! (scroll-right nil))
+;;;!!
+;;;!! (defun mouse-scroll-move-cursor-horizontally (click)
+;;;!! (interactive "@e")
+;;;!! (move-to-column (1+ (car (mouse-coords click)))))
+;;;!!
+;;;!! (defun mouse-scroll-absolute-horizontally (event)
+;;;!! (interactive "@e")
+;;;!! (let* ((pos (car event))
+;;;!! (position (car pos))
+;;;!! (length (car (cdr pos))))
+;;;!! (set-window-hscroll (selected-window) 33)))
+;;;!!
+;;;!! (global-set-key [scroll-bar mouse-1] 'mouse-scroll-up)
+;;;!! (global-set-key [scroll-bar mouse-2] 'mouse-scroll-absolute)
+;;;!! (global-set-key [scroll-bar mouse-3] 'mouse-scroll-down)
+;;;!!
+;;;!! (global-set-key [vertical-slider mouse-1] 'mouse-scroll-move-cursor)
+;;;!! (global-set-key [vertical-slider mouse-2] 'mouse-scroll-move-cursor)
+;;;!! (global-set-key [vertical-slider mouse-3] 'mouse-scroll-move-cursor)
+;;;!!
+;;;!! (global-set-key [thumbup mouse-1] 'mouse-scroll-up-full)
+;;;!! (global-set-key [thumbup mouse-2] 'mouse-scroll-up-full)
+;;;!! (global-set-key [thumbup mouse-3] 'mouse-scroll-up-full)
+;;;!!
+;;;!! (global-set-key [thumbdown mouse-1] 'mouse-scroll-down-full)
+;;;!! (global-set-key [thumbdown mouse-2] 'mouse-scroll-down-full)
+;;;!! (global-set-key [thumbdown mouse-3] 'mouse-scroll-down-full)
+;;;!!
+;;;!! (global-set-key [horizontal-scroll-bar mouse-1] 'mouse-scroll-left)
+;;;!! (global-set-key [horizontal-scroll-bar mouse-2]
+;;;!! 'mouse-scroll-absolute-horizontally)
+;;;!! (global-set-key [horizontal-scroll-bar mouse-3] 'mouse-scroll-right)
+;;;!!
+;;;!! (global-set-key [horizontal-slider mouse-1]
+;;;!! 'mouse-scroll-move-cursor-horizontally)
+;;;!! (global-set-key [horizontal-slider mouse-2]
+;;;!! 'mouse-scroll-move-cursor-horizontally)
+;;;!! (global-set-key [horizontal-slider mouse-3]
+;;;!! 'mouse-scroll-move-cursor-horizontally)
+;;;!!
+;;;!! (global-set-key [thumbleft mouse-1] 'mouse-scroll-left-full)
+;;;!! (global-set-key [thumbleft mouse-2] 'mouse-scroll-left-full)
+;;;!! (global-set-key [thumbleft mouse-3] 'mouse-scroll-left-full)
+;;;!!
+;;;!! (global-set-key [thumbright mouse-1] 'mouse-scroll-right-full)
+;;;!! (global-set-key [thumbright mouse-2] 'mouse-scroll-right-full)
+;;;!! (global-set-key [thumbright mouse-3] 'mouse-scroll-right-full)
+;;;!!
+;;;!! (global-set-key [horizontal-scroll-bar S-mouse-2]
+;;;!! 'mouse-split-window-horizontally)
+;;;!! (global-set-key [mode-line S-mouse-2]
+;;;!! 'mouse-split-window-horizontally)
+;;;!! (global-set-key [vertical-scroll-bar S-mouse-2]
+;;;!! 'mouse-split-window)
+\f
+;;;!! ;;;;
+;;;!! ;;;; Here are experimental things being tested. Mouse events
+;;;!! ;;;; are of the form:
+;;;!! ;;;; ((x y) window screen-part key-sequence timestamp)
+;;;!! ;;
+;;;!! ;;;;
+;;;!! ;;;; Dynamically track mouse coordinates
+;;;!! ;;;;
+;;;!! ;;
+;;;!! ;;(defun track-mouse (event)
+;;;!! ;; "Track the coordinates, absolute and relative, of the mouse."
+;;;!! ;; (interactive "@e")
+;;;!! ;; (while mouse-grabbed
+;;;!! ;; (let* ((pos (read-mouse-position (selected-screen)))
+;;;!! ;; (abs-x (car pos))
+;;;!! ;; (abs-y (cdr pos))
+;;;!! ;; (relative-coordinate (coordinates-in-window-p
+;;;!! ;; (list (car pos) (cdr pos))
+;;;!! ;; (selected-window))))
+;;;!! ;; (if (consp relative-coordinate)
+;;;!! ;; (message "mouse: [%d %d], (%d %d)" abs-x abs-y
+;;;!! ;; (car relative-coordinate)
+;;;!! ;; (car (cdr relative-coordinate)))
+;;;!! ;; (message "mouse: [%d %d]" abs-x abs-y)))))
+;;;!!
+;;;!! ;;
+;;;!! ;; Dynamically put a box around the line indicated by point
+;;;!! ;;
+;;;!! ;;
+;;;!! ;;(require 'backquote)
+;;;!! ;;
+;;;!! ;;(defun mouse-select-buffer-line (event)
+;;;!! ;; (interactive "@e")
+;;;!! ;; (let ((relative-coordinate
+;;;!! ;; (coordinates-in-window-p (car event) (selected-window)))
+;;;!! ;; (abs-y (car (cdr (car event)))))
+;;;!! ;; (if (consp relative-coordinate)
+;;;!! ;; (progn
+;;;!! ;; (save-excursion
+;;;!! ;; (move-to-window-line (car (cdr relative-coordinate)))
+;;;!! ;; (x-draw-rectangle
+;;;!! ;; (selected-screen)
+;;;!! ;; abs-y 0
+;;;!! ;; (save-excursion
+;;;!! ;; (move-to-window-line (car (cdr relative-coordinate)))
+;;;!! ;; (end-of-line)
+;;;!! ;; (push-mark nil t)
+;;;!! ;; (beginning-of-line)
+;;;!! ;; (- (region-end) (region-beginning))) 1))
+;;;!! ;; (sit-for 1)
+;;;!! ;; (x-erase-rectangle (selected-screen))))))
+;;;!! ;;
+;;;!! ;;(defvar last-line-drawn nil)
+;;;!! ;;(defvar begin-delim "[^ \t]")
+;;;!! ;;(defvar end-delim "[^ \t]")
+;;;!! ;;
+;;;!! ;;(defun mouse-boxing (event)
+;;;!! ;; (interactive "@e")
+;;;!! ;; (save-excursion
+;;;!! ;; (let ((screen (selected-screen)))
+;;;!! ;; (while (= (x-mouse-events) 0)
+;;;!! ;; (let* ((pos (read-mouse-position screen))
+;;;!! ;; (abs-x (car pos))
+;;;!! ;; (abs-y (cdr pos))
+;;;!! ;; (relative-coordinate
+;;;!! ;; (coordinates-in-window-p (` ((, abs-x) (, abs-y)))
+;;;!! ;; (selected-window)))
+;;;!! ;; (begin-reg nil)
+;;;!! ;; (end-reg nil)
+;;;!! ;; (end-column nil)
+;;;!! ;; (begin-column nil))
+;;;!! ;; (if (and (consp relative-coordinate)
+;;;!! ;; (or (not last-line-drawn)
+;;;!! ;; (not (= last-line-drawn abs-y))))
+;;;!! ;; (progn
+;;;!! ;; (move-to-window-line (car (cdr relative-coordinate)))
+;;;!! ;; (if (= (following-char) 10)
+;;;!! ;; ()
+;;;!! ;; (progn
+;;;!! ;; (setq begin-reg (1- (re-search-forward end-delim)))
+;;;!! ;; (setq begin-column (1- (current-column)))
+;;;!! ;; (end-of-line)
+;;;!! ;; (setq end-reg (1+ (re-search-backward begin-delim)))
+;;;!! ;; (setq end-column (1+ (current-column)))
+;;;!! ;; (message "%s" (buffer-substring begin-reg end-reg))
+;;;!! ;; (x-draw-rectangle screen
+;;;!! ;; (setq last-line-drawn abs-y)
+;;;!! ;; begin-column
+;;;!! ;; (- end-column begin-column) 1))))))))))
+;;;!! ;;
+;;;!! ;;(defun mouse-erase-box ()
+;;;!! ;; (interactive)
+;;;!! ;; (if last-line-drawn
+;;;!! ;; (progn
+;;;!! ;; (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))
+;;;!!
+;;;!! ;;
+;;;!! ;; Here is how to do double clicking in lisp. About to change.
+;;;!! ;;
+;;;!!
+;;;!! (defvar double-start nil)
+;;;!! (defconst double-click-interval 300
+;;;!! "Max ticks between clicks")
+;;;!!
+;;;!! (defun double-down (event)
+;;;!! (interactive "@e")
+;;;!! (if double-start
+;;;!! (let ((interval (- (nth 4 event) double-start)))
+;;;!! (if (< interval double-click-interval)
+;;;!! (progn
+;;;!! (backward-up-list 1)
+;;;!! ;; (message "Interval %d" interval)
+;;;!! (sleep-for 1)))
+;;;!! (setq double-start nil))
+;;;!! (setq double-start (nth 4 event))))
+;;;!!
+;;;!! (defun double-up (event)
+;;;!! (interactive "@e")
+;;;!! (and double-start
+;;;!! (> (- (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))
+;;;!!
+;;;!! ;;
+;;;!! ;; This scrolls while button is depressed. Use preferable in scroll bar.
+;;;!! ;;
+;;;!!
+;;;!! (defvar scrolled-lines 0)
+;;;!! (defconst scroll-speed 1)
+;;;!!
+;;;!! (defun incr-scroll-down (event)
+;;;!! (interactive "@e")
+;;;!! (setq scrolled-lines 0)
+;;;!! (incremental-scroll scroll-speed))
+;;;!!
+;;;!! (defun incr-scroll-up (event)
+;;;!! (interactive "@e")
+;;;!! (setq scrolled-lines 0)
+;;;!! (incremental-scroll (- scroll-speed)))
+;;;!!
+;;;!! (defun incremental-scroll (n)
+;;;!! (while (= (x-mouse-events) 0)
+;;;!! (setq scrolled-lines (1+ (* scroll-speed scrolled-lines)))
+;;;!! (scroll-down n)
+;;;!! (sit-for 300 t)))
+;;;!!
+;;;!! (defun incr-scroll-stop (event)
+;;;!! (interactive "@e")
+;;;!! (message "Scrolled %d lines" scrolled-lines)
+;;;!! (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)))
+;;;!!
+;;;!! ;;
+;;;!! ;; Some playthings suitable for picture mode? They need work.
+;;;!! ;;
+;;;!!
+;;;!! (defun mouse-kill-rectangle (event)
+;;;!! "Kill the rectangle between point and the mouse cursor."
+;;;!! (interactive "@e")
+;;;!! (let ((point-save (point)))
+;;;!! (save-excursion
+;;;!! (mouse-set-point event)
+;;;!! (push-mark nil t)
+;;;!! (if (> point-save (point))
+;;;!! (kill-rectangle (point) point-save)
+;;;!! (kill-rectangle point-save (point))))))
+;;;!!
+;;;!! (defun mouse-open-rectangle (event)
+;;;!! "Kill the rectangle between point and the mouse cursor."
+;;;!! (interactive "@e")
+;;;!! (let ((point-save (point)))
+;;;!! (save-excursion
+;;;!! (mouse-set-point event)
+;;;!! (push-mark nil t)
+;;;!! (if (> point-save (point))
+;;;!! (open-rectangle (point) point-save)
+;;;!! (open-rectangle point-save (point))))))
+;;;!!
+;;;!! ;; Must be a better way to do this.
+;;;!!
+;;;!! (defun mouse-multiple-insert (n char)
+;;;!! (while (> n 0)
+;;;!! (insert char)
+;;;!! (setq n (1- n))))
+;;;!!
+;;;!! ;; What this could do is not finalize until button was released.
+;;;!!
+;;;!! (defun mouse-move-text (event)
+;;;!! "Move text from point to cursor position, inserting spaces."
+;;;!! (interactive "@e")
+;;;!! (let* ((relative-coordinate
+;;;!! (coordinates-in-window-p (car event) (selected-window))))
+;;;!! (if (consp relative-coordinate)
+;;;!! (cond ((> (current-column) (car relative-coordinate))
+;;;!! (delete-char
+;;;!! (- (car relative-coordinate) (current-column))))
+;;;!! ((< (current-column) (car relative-coordinate))
+;;;!! (mouse-multiple-insert
+;;;!! (- (car relative-coordinate) (current-column)) " "))
+;;;!! ((= (current-column) (car relative-coordinate)) (ding))))))
+\f
+;; Choose a completion with the mouse.
+
+;; Delete the longest partial match for STRING
+;; that can be found before POINT.
+(defun mouse-delete-max-match (string)
+ (let ((len (min (length string)
+ (- (point-max) (point-min)))))
+ (goto-char (max (point-min) (- (point) (length string))))
+ (while (and (> len 0)
+ (let ((tail (buffer-substring (point)
+ (+ (point) len))))
+ (not (string= tail (substring string 0 len)))))
+ (setq len (1- len))
+ (forward-char 1))
+ (delete-char len)))
+
+(defun mouse-choose-completion (event)
+ "Click on an alternative in the `*Completions*' buffer to choose it."
+ (interactive "e")
+ (let ((buffer (window-buffer))
+ choice)
+ (save-excursion
+ (set-buffer (window-buffer (posn-window (event-start event))))
+ (save-excursion
+ (goto-char (posn-point (event-start event)))
+ (skip-chars-backward "^ \t\n")
+ (let ((beg (point)))
+ (skip-chars-forward "^ \t\n")
+ (setq choice (buffer-substring beg (point))))))
+ (set-buffer buffer)
+ (mouse-delete-max-match choice)
+ (insert choice)
+ (and (equal buffer (window-buffer (minibuffer-window)))
+ (minibuffer-complete-and-exit))))
+\f
+;; Font selection.
+
+(defun font-menu-add-default ()
+ (let* ((default (cdr (assq 'font (frame-parameters (selected-frame)))))
+ (font-alist x-fixed-font-alist)
+ (elt (or (assoc "Misc" font-alist) (nth 1 font-alist))))
+ (if (assoc "Default" elt)
+ (delete (assoc "Default" elt) elt))
+ (setcdr elt
+ (cons (list "Default"
+ (cdr (assq 'font (frame-parameters (selected-frame)))))
+ (cdr elt)))))
+
+(defvar x-fixed-font-alist
+ '("Font menu"
+ ("Misc"
+ ("6x10" "-misc-fixed-medium-r-normal--10-100-75-75-c-60-*-1")
+ ("6x12" "-misc-fixed-medium-r-semicondensed--12-110-75-75-c-60-*-1")
+ ("6x13" "-misc-fixed-medium-r-semicondensed--13-120-75-75-c-60-*-1")
+ ("lucida 13"
+ "-b&h-lucidatypewriter-medium-r-normal-sans-0-0-0-0-m-0-*-1")
+ ("7x13" "-misc-fixed-medium-r-normal--13-120-75-75-c-70-*-1")
+ ("7x14" "-misc-fixed-medium-r-normal--14-130-75-75-c-70-*-1")
+ ("9x15" "-misc-fixed-medium-r-normal--15-140-*-*-c-*-*-1")
+ ("")
+ ("clean 8x8" "-schumacher-clean-medium-r-normal--*-80-*-*-c-*-*-1")
+ ("clean 8x14" "-schumacher-clean-medium-r-normal--*-140-*-*-c-*-*-1")
+ ("clean 8x10" "-schumacher-clean-medium-r-normal--*-100-*-*-c-*-*-1")
+ ("clean 8x16" "-schumacher-clean-medium-r-normal--*-160-*-*-c-*-*-1")
+ ("")
+ ("sony 8x16" "-sony-fixed-medium-r-normal--16-120-100-100-c-80-*-1")
+ ("")
+ ("fixed" "fixed")
+ ("10x20" "10x20")
+ ("11x18" "11x18")
+ ("12x24" "12x24"))
+;;; We don't seem to have these; who knows what they are.
+;;; ("fg-18" "fg-18")
+;;; ("fg-25" "fg-25")
+;;; ("lucidasanstypewriter-12" "lucidasanstypewriter-12")
+;;; ("lucidasanstypewriter-bold-14" "lucidasanstypewriter-bold-14")
+;;; ("lucidasanstypewriter-bold-24" "lucidasanstypewriter-bold-24")
+;;; ("lucidatypewriter-bold-r-24" "-b&h-lucidatypewriter-bold-r-normal-sans-24-240-75-75-m-140-iso8859-1")
+;;; ("fixed-medium-20" "-misc-fixed-medium-*-*-*-20-*-*-*-*-*-*-*")
+ ("Courier"
+ ("8" "-adobe-courier-medium-r-normal--*-80-*-*-m-*-iso8859-1")
+ ("10" "-adobe-courier-medium-r-normal--*-100-*-*-m-*-iso8859-1")
+ ("12" "-adobe-courier-medium-r-normal--*-120-*-*-m-*-iso8859-1")
+ ("14" "-adobe-courier-medium-r-normal--*-140-*-*-m-*-iso8859-1")
+ ("18" "-adobe-courier-medium-r-normal--*-180-*-*-m-*-iso8859-1")
+ ("24" "-adobe-courier-medium-r-normal--*-240-*-*-m-*-iso8859-1")
+ ("8 bold" "-adobe-courier-bold-r-normal--*-80-*-*-m-*-iso8859-1")
+ ("10 bold" "-adobe-courier-bold-r-normal--*-100-*-*-m-*-iso8859-1")
+ ("12 bold" "-adobe-courier-bold-r-normal--*-120-*-*-m-*-iso8859-1")
+ ("14 bold" "-adobe-courier-bold-r-normal--*-140-*-*-m-*-iso8859-1")
+ ("18 bold" "-adobe-courier-bold-r-normal--*-180-*-*-m-*-iso8859-1")
+ ("24 bold" "-adobe-courier-bold-r-normal--*-240-*-*-m-*-iso8859-1")
+ ("8 slant" "-adobe-courier-medium-o-normal--*-80-*-*-m-*-iso8859-1")
+ ("10 slant" "-adobe-courier-medium-o-normal--*-100-*-*-m-*-iso8859-1")
+ ("12 slant" "-adobe-courier-medium-o-normal--*-120-*-*-m-*-iso8859-1")
+ ("14 slant" "-adobe-courier-medium-o-normal--*-140-*-*-m-*-iso8859-1")
+ ("18 slant" "-adobe-courier-medium-o-normal--*-180-*-*-m-*-iso8859-1")
+ ("24 slant" "-adobe-courier-medium-o-normal--*-240-*-*-m-*-iso8859-1")
+ ("8 bold slant" "-adobe-courier-bold-o-normal--*-80-*-*-m-*-iso8859-1")
+ ("10 bold slant" "-adobe-courier-bold-o-normal--*-100-*-*-m-*-iso8859-1")
+ ("12 bold slant" "-adobe-courier-bold-o-normal--*-120-*-*-m-*-iso8859-1")
+ ("14 bold slant" "-adobe-courier-bold-o-normal--*-140-*-*-m-*-iso8859-1")
+ ("18 bold slant" "-adobe-courier-bold-o-normal--*-180-*-*-m-*-iso8859-1")
+ ("24 bold slant" "-adobe-courier-bold-o-normal--*-240-*-*-m-*-iso8859-1"))
+ )
+ "X fonts suitable for use in Emacs.")
+
+(defun mouse-set-font (&optional font)
+ "Select an emacs font from a list of known good fonts"
+ (interactive
+ (x-popup-menu last-nonmenu-event x-fixed-font-alist))
+ (if font
+ (progn (modify-frame-parameters (selected-frame)
+ (list (cons 'font font)))
+ ;; Update some standard faces too.
+ (set-face-font 'bold nil (selected-frame))
+ (make-face-bold 'bold (selected-frame) t)
+ (set-face-font 'italic nil (selected-frame))
+ (make-face-italic 'italic (selected-frame) t)
+ (set-face-font 'bold-italic nil (selected-frame))
+ (make-face-bold-italic 'bold-italic (selected-frame) t)
+ ;; Update any nonstandard faces whose definition is
+ ;; "a bold/italic/bold&italic version of the frame's font".
+ (let ((rest global-face-data))
+ (while rest
+ (condition-case nil
+ (if (listp (face-font (cdr (car rest))))
+ (let ((bold (memq 'bold (face-font (cdr (car rest)))))
+ (italic (memq 'italic (face-font (cdr (car rest))))))
+ (if (and bold italic)
+ (make-face-bold-italic (car (car rest)) (selected-frame))
+ (if bold
+ (make-face-bold (car (car rest)) (selected-frame))
+ (if italic
+ (make-face-italic (car (car rest)) (selected-frame)))))))
+ (error nil))
+ (setq rest (cdr rest))))
+ )))
+\f
+;;; Bindings for mouse commands.
+
+(define-key global-map [down-mouse-1] 'mouse-drag-region)
+(global-set-key [mouse-1] 'mouse-set-point)
+(global-set-key [drag-mouse-1] 'mouse-set-region)
+
+;; These are tested for in mouse-drag-region.
+(global-set-key [double-mouse-1] 'mouse-set-point)
+(global-set-key [triple-mouse-1] 'mouse-set-point)
+
+(global-set-key [mouse-2] 'mouse-yank-at-click)
+(global-set-key [mouse-3] 'mouse-save-then-kill)
+
+;; By binding these to down-going events, we let the user use the up-going
+;; event to make the selection, saving a click.
+(global-set-key [C-down-mouse-1] 'mouse-buffer-menu)
+(global-set-key [C-down-mouse-3] 'mouse-set-font)
+
+;; Replaced with dragging mouse-1
+;; (global-set-key [S-mouse-1] 'mouse-set-mark)
+
+(global-set-key [mode-line mouse-1] 'mouse-delete-other-windows)
+(global-set-key [mode-line mouse-3] 'mouse-delete-window)
+(global-set-key [mode-line S-mouse-2] 'mouse-split-window-horizontally)
+\f
+;; Define the mouse help menu tree.
+
+(defvar help-menu-map '(keymap "Help"))
+(global-set-key [C-down-mouse-2] help-menu-map)
+
+(defvar help-apropos-map (make-sparse-keymap "Is there a command that..."))
+(defvar help-keys-map (make-sparse-keymap "Key Commands <==> Functions"))
+(defvar help-manual-map (make-sparse-keymap "Manual and tutorial"))
+(defvar help-misc-map (make-sparse-keymap "Odds and ends"))
+(defvar help-modes-map (make-sparse-keymap "Modes"))
+(defvar help-admin-map (make-sparse-keymap "Administrivia"))
+
+(define-key help-menu-map [apropos]
+ (cons "@Is there a command that..." help-apropos-map))
+(define-key help-menu-map [keys]
+ (cons "@Key Commands <==> Functions" help-keys-map))
+(define-key help-menu-map [manuals]
+ (cons "@Manual and tutorial" help-manual-map))
+(define-key help-menu-map [misc]
+ (cons "@Odds and ends" help-misc-map))
+(define-key help-menu-map [modes]
+ (cons "@Modes" help-modes-map))
+(define-key help-menu-map [admin]
+ (cons "@Administrivia" help-admin-map))
+
+(define-key help-apropos-map "c" '("Command Apropos" . command-apropos))
+(define-key help-apropos-map "a" '("Apropos" . apropos))
+
+(define-key help-keys-map "b"
+ '("List all keystroke commands" . describe-bindings))
+(define-key help-keys-map "c"
+ '("Describe key briefly" . describe-key-briefly))
+(define-key help-keys-map "k"
+ '("Describe key verbose" . describe-key))
+(define-key help-keys-map "f"
+ '("Describe Lisp function" . describe-function))
+(define-key help-keys-map "w"
+ '("Where is this command" . where-is))
+
+(define-key help-manual-map "i" '("Info system" . info))
+(define-key help-manual-map "t"
+ '("Invoke Emacs tutorial" . help-with-tutorial))
+
+(define-key help-misc-map "l" '("Last 100 Keystrokes" . view-lossage))
+(define-key help-misc-map "s" '("Describe syntax table" . describe-syntax))
+
+(define-key help-modes-map "m"
+ '("Describe current major mode" . describe-mode))
+(define-key help-modes-map "b"
+ '("List all keystroke commands" . describe-bindings))
+
+(define-key help-admin-map "n"
+ '("View Emacs news" . view-emacs-news))
+(define-key help-admin-map "l"
+ '("View Emacs copying conditions" . describe-copying))
+(define-key help-admin-map "d"
+ '("Describe distribution" . describe-distribution))
+(define-key help-admin-map "w"
+ '("Describe (non)warranty" . describe-no-warranty))
+
+(provide 'mouse)
+
+;;; mouse.el ends here
HCoop / bpt / emacs.git / blobdiff