1;;; mouse.el --- window system-independent mouse support 2 3;; Copyright (C) 1993, 1994, 1995, 1999, 2000, 2001, 2002, 2003, 4;; 2004, 2005, 2006, 2007 Free Software Foundation, Inc. 5 6;; Maintainer: FSF 7;; Keywords: hardware, mouse 8 9;; This file is part of GNU Emacs. 10 11;; GNU Emacs is free software; you can redistribute it and/or modify 12;; it under the terms of the GNU General Public License as published by 13;; the Free Software Foundation; either version 2, or (at your option) 14;; any later version. 15 16;; GNU Emacs is distributed in the hope that it will be useful, 17;; but WITHOUT ANY WARRANTY; without even the implied warranty of 18;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19;; GNU General Public License for more details. 20 21;; You should have received a copy of the GNU General Public License 22;; along with GNU Emacs; see the file COPYING. If not, write to the 23;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, 24;; Boston, MA 02110-1301, USA. 25 26;;; Commentary: 27 28;; This package provides various useful commands (including help 29;; system access) through the mouse. All this code assumes that mouse 30;; interpretation has been abstracted into Emacs input events. 31;; 32;; The code is rather X-dependent. 33 34;;; Code: 35 36;;; Utility functions. 37 38;;; Indent track-mouse like progn. 39(put 'track-mouse 'lisp-indent-function 0) 40 41(defcustom mouse-yank-at-point nil 42 "*If non-nil, mouse yank commands yank at point instead of at click." 43 :type 'boolean 44 :group 'mouse) 45 46(defcustom mouse-drag-copy-region t 47 "*If non-nil, mouse drag copies region to kill-ring." 48 :type 'boolean 49 :version "22.1" 50 :group 'mouse) 51 52(defcustom mouse-1-click-follows-link 450 53 "Non-nil means that clicking Mouse-1 on a link follows the link. 54 55With the default setting, an ordinary Mouse-1 click on a link 56performs the same action as Mouse-2 on that link, while a longer 57Mouse-1 click \(hold down the Mouse-1 button for more than 450 58milliseconds) performs the original Mouse-1 binding \(which 59typically sets point where you click the mouse). 60 61If value is an integer, the time elapsed between pressing and 62releasing the mouse button determines whether to follow the link 63or perform the normal Mouse-1 action (typically set point). 64The absolute numeric value specifices the maximum duration of a 65\"short click\" in milliseconds. A positive value means that a 66short click follows the link, and a longer click performs the 67normal action. A negative value gives the opposite behavior. 68 69If value is `double', a double click follows the link. 70 71Otherwise, a single Mouse-1 click unconditionally follows the link. 72 73Note that dragging the mouse never follows the link. 74 75This feature only works in modes that specifically identify 76clickable text as links, so it may not work with some external 77packages. See `mouse-on-link-p' for details." 78 :version "22.1" 79 :type '(choice (const :tag "Disabled" nil) 80 (const :tag "Double click" double) 81 (number :tag "Single click time limit" :value 450) 82 (other :tag "Single click" t)) 83 :group 'mouse) 84 85(defcustom mouse-1-click-in-non-selected-windows t 86 "*If non-nil, a Mouse-1 click also follows links in non-selected windows. 87 88If nil, a Mouse-1 click on a link in a non-selected window performs 89the normal mouse-1 binding, typically selects the window and sets 90point at the click position." 91 :type 'boolean 92 :version "22.1" 93 :group 'mouse) 94 95 96 97;; Provide a mode-specific menu on a mouse button. 98 99(defun popup-menu (menu &optional position prefix) 100 "Popup the given menu and call the selected option. 101MENU can be a keymap, an easymenu-style menu or a list of keymaps as for 102`x-popup-menu'. 103POSITION can be a click event or ((XOFFSET YOFFSET) WINDOW) and defaults to 104 the current mouse position. 105PREFIX is the prefix argument (if any) to pass to the command." 106 (let* ((map (cond 107 ((keymapp menu) menu) 108 ((and (listp menu) (keymapp (car menu))) menu) 109 (t (let* ((map (easy-menu-create-menu (car menu) (cdr menu))) 110 (filter (when (symbolp map) 111 (plist-get (get map 'menu-prop) :filter)))) 112 (if filter (funcall filter (symbol-function map)) map))))) 113 event cmd) 114 (unless position 115 (let ((mp (mouse-pixel-position))) 116 (setq position (list (list (cadr mp) (cddr mp)) (car mp))))) 117 ;; The looping behavior was taken from lmenu's popup-menu-popup 118 (while (and map (setq event 119 ;; map could be a prefix key, in which case 120 ;; we need to get its function cell 121 ;; definition. 122 (x-popup-menu position (indirect-function map)))) 123 ;; Strangely x-popup-menu returns a list. 124 ;; mouse-major-mode-menu was using a weird: 125 ;; (key-binding (apply 'vector (append '(menu-bar) menu-prefix events))) 126 (setq cmd 127 (if (and (not (keymapp map)) (listp map)) 128 ;; We were given a list of keymaps. Search them all 129 ;; in sequence until a first binding is found. 130 (let ((mouse-click (apply 'vector event)) 131 binding) 132 (while (and map (null binding)) 133 (setq binding (lookup-key (car map) mouse-click)) 134 (if (numberp binding) ; `too long' 135 (setq binding nil)) 136 (setq map (cdr map))) 137 binding) 138 ;; We were given a single keymap. 139 (lookup-key map (apply 'vector event)))) 140 ;; Clear out echoing, which perhaps shows a prefix arg. 141 (message "") 142 ;; Maybe try again but with the submap. 143 (setq map (if (keymapp cmd) cmd))) 144 ;; If the user did not cancel by refusing to select, 145 ;; and if the result is a command, run it. 146 (when (and (null map) (commandp cmd)) 147 (setq prefix-arg prefix) 148 ;; `setup-specified-language-environment', for instance, 149 ;; expects this to be set from a menu keymap. 150 (setq last-command-event (car (last event))) 151 ;; mouse-major-mode-menu was using `command-execute' instead. 152 (call-interactively cmd)))) 153 154(defvar mouse-major-mode-menu-prefix) ; dynamically bound 155 156(defun mouse-major-mode-menu (event &optional prefix) 157 "Pop up a mode-specific menu of mouse commands. 158Default to the Edit menu if the major mode doesn't define a menu." 159 ;; Switch to the window clicked on, because otherwise 160 ;; the mode's commands may not make sense. 161 (interactive "@e\nP") 162 ;; Let the mode update its menus first. 163 (run-hooks 'activate-menubar-hook 'menu-bar-update-hook) 164 (let* (;; This is where mouse-major-mode-menu-prefix 165 ;; returns the prefix we should use (after menu-bar). 166 ;; It is either nil or (SOME-SYMBOL). 167 (mouse-major-mode-menu-prefix nil) 168 ;; Keymap from which to inherit; may be null. 169 (ancestor (mouse-major-mode-menu-1 170 (and (current-local-map) 171 (local-key-binding [menu-bar])))) 172 ;; Make a keymap in which our last command leads to a menu or 173 ;; default to the edit menu. 174 (newmap (if ancestor 175 (make-sparse-keymap (concat mode-name " Mode")) 176 menu-bar-edit-menu))) 177 (if ancestor 178 ;; Make our menu inherit from the desired keymap which we want 179 ;; to display as the menu now. 180 (set-keymap-parent newmap ancestor)) 181 (popup-menu newmap event prefix))) 182 183 184;; Compute and cache the equivalent keys in MENU and all its submenus. 185;;;(defun mouse-major-mode-menu-compute-equiv-keys (menu) 186;;; (and (eq (car menu) 'keymap) 187;;; (x-popup-menu nil menu)) 188;;; (while menu 189;;; (and (consp (car menu)) 190;;; (consp (cdr (car menu))) 191;;; (let ((tail (cdr (car menu)))) 192;;; (while (and (consp tail) 193;;; (not (eq (car tail) 'keymap))) 194;;; (setq tail (cdr tail))) 195;;; (if (consp tail) 196;;; (mouse-major-mode-menu-compute-equiv-keys tail)))) 197;;; (setq menu (cdr menu)))) 198 199;; Given a mode's menu bar keymap, 200;; if it defines exactly one menu bar menu, 201;; return just that menu. 202;; Otherwise return a menu for all of them. 203(defun mouse-major-mode-menu-1 (menubar) 204 (if menubar 205 (let ((tail menubar) 206 submap) 207 (while tail 208 (if (consp (car tail)) 209 (if submap 210 (setq submap t) 211 (setq submap (car tail)))) 212 (setq tail (cdr tail))) 213 (if (eq submap t) 214 menubar 215 (setq mouse-major-mode-menu-prefix (list (car submap))) 216 (lookup-key menubar (vector (car submap))))))) 217 218(defun mouse-popup-menubar (event prefix) 219 "Pop up a menu equivalent to the menu bar for keyboard EVENT with PREFIX. 220The contents are the items that would be in the menu bar whether or 221not it is actually displayed." 222 (interactive "@e \nP") 223 (run-hooks 'activate-menubar-hook 'menu-bar-update-hook) 224 (let* ((local-menu (and (current-local-map) 225 (lookup-key (current-local-map) [menu-bar]))) 226 (global-menu (lookup-key global-map [menu-bar])) 227 ;; If a keymap doesn't have a prompt string (a lazy 228 ;; programmer didn't bother to provide one), create it and 229 ;; insert it into the keymap; each keymap gets its own 230 ;; prompt. This is required for non-toolkit versions to 231 ;; display non-empty menu pane names. 232 (minor-mode-menus 233 (mapcar 234 (function 235 (lambda (menu) 236 (let* ((minor-mode (car menu)) 237 (menu (cdr menu)) 238 (title-or-map (cadr menu))) 239 (or (stringp title-or-map) 240 (setq menu 241 (cons 'keymap 242 (cons (concat 243 (capitalize (subst-char-in-string 244 ?- ?\s (symbol-name 245 minor-mode))) 246 " Menu") 247 (cdr menu))))) 248 menu))) 249 (minor-mode-key-binding [menu-bar]))) 250 (local-title-or-map (and local-menu (cadr local-menu))) 251 (global-title-or-map (cadr global-menu))) 252 (or (null local-menu) 253 (stringp local-title-or-map) 254 (setq local-menu (cons 'keymap 255 (cons (concat mode-name " Mode Menu") 256 (cdr local-menu))))) 257 (or (stringp global-title-or-map) 258 (setq global-menu (cons 'keymap 259 (cons "Global Menu" 260 (cdr global-menu))))) 261 ;; Supplying the list is faster than making a new map. 262 (popup-menu (append (list global-menu) 263 (if local-menu 264 (list local-menu)) 265 minor-mode-menus) 266 event prefix))) 267 268(defun mouse-popup-menubar-stuff (event prefix) 269 "Popup a menu like either `mouse-major-mode-menu' or `mouse-popup-menubar'. 270Use the former if the menu bar is showing, otherwise the latter." 271 (interactive "@e \nP") 272 (if (zerop (assoc-default 'menu-bar-lines (frame-parameters) 'eq 0)) 273 (mouse-popup-menubar event prefix) 274 (mouse-major-mode-menu event prefix))) 275 276;; Commands that operate on windows. 277 278(defun mouse-minibuffer-check (event) 279 (let ((w (posn-window (event-start event)))) 280 (and (window-minibuffer-p w) 281 (not (minibuffer-window-active-p w)) 282 (error "Minibuffer window is not active"))) 283 ;; Give temporary modes such as isearch a chance to turn off. 284 (run-hooks 'mouse-leave-buffer-hook)) 285 286(defun mouse-delete-window (click) 287 "Delete the window you click on. 288Do nothing if the frame has just one window. 289This command must be bound to a mouse click." 290 (interactive "e") 291 (unless (one-window-p t) 292 (mouse-minibuffer-check click) 293 (delete-window (posn-window (event-start click))))) 294 295(defun mouse-select-window (click) 296 "Select the window clicked on; don't move point." 297 (interactive "e") 298 (mouse-minibuffer-check click) 299 (let ((oframe (selected-frame)) 300 (frame (window-frame (posn-window (event-start click))))) 301 (select-window (posn-window (event-start click))) 302 (raise-frame frame) 303 (select-frame frame) 304 (or (eq frame oframe) 305 (set-mouse-position (selected-frame) (1- (frame-width)) 0)))) 306 307(defun mouse-tear-off-window (click) 308 "Delete the window clicked on, and create a new frame displaying its buffer." 309 (interactive "e") 310 (mouse-minibuffer-check click) 311 (let* ((window (posn-window (event-start click))) 312 (buf (window-buffer window)) 313 (frame (make-frame))) 314 (select-frame frame) 315 (switch-to-buffer buf) 316 (delete-window window))) 317 318(defun mouse-delete-other-windows () 319 "Delete all windows except the one you click on." 320 (interactive "@") 321 (delete-other-windows)) 322 323(defun mouse-split-window-vertically (click) 324 "Select Emacs window mouse is on, then split it vertically in half. 325The window is split at the line clicked on. 326This command must be bound to a mouse click." 327 (interactive "@e") 328 (mouse-minibuffer-check click) 329 (let ((start (event-start click))) 330 (select-window (posn-window start)) 331 (let ((new-height (1+ (cdr (posn-col-row (event-end click))))) 332 (first-line window-min-height) 333 (last-line (- (window-height) window-min-height))) 334 (if (< last-line first-line) 335 (error "Window too short to split") 336 (split-window-vertically 337 (min (max new-height first-line) last-line)))))) 338 339(defun mouse-split-window-horizontally (click) 340 "Select Emacs window mouse is on, then split it horizontally in half. 341The window is split at the column clicked on. 342This command must be bound to a mouse click." 343 (interactive "@e") 344 (mouse-minibuffer-check click) 345 (let ((start (event-start click))) 346 (select-window (posn-window start)) 347 (let ((new-width (1+ (car (posn-col-row (event-end click))))) 348 (first-col window-min-width) 349 (last-col (- (window-width) window-min-width))) 350 (if (< last-col first-col) 351 (error "Window too narrow to split") 352 (split-window-horizontally 353 (min (max new-width first-col) last-col)))))) 354 355(defun mouse-drag-window-above (window) 356 "Return the (or a) window directly above WINDOW. 357That means one whose bottom edge is at the same height as WINDOW's top edge." 358 (let ((start-top (nth 1 (window-edges window))) 359 (start-left (nth 0 (window-edges window))) 360 (start-right (nth 2 (window-edges window))) 361 (start-window window) 362 above-window) 363 (setq window (previous-window window 0)) 364 (while (and (not above-window) (not (eq window start-window))) 365 (let ((left (nth 0 (window-edges window))) 366 (right (nth 2 (window-edges window)))) 367 (when (and (= (+ (window-height window) (nth 1 (window-edges window))) 368 start-top) 369 (or (and (<= left start-left) (<= start-right right)) 370 (and (<= start-left left) (<= left start-right)) 371 (and (<= start-left right) (<= right start-right)))) 372 (setq above-window window))) 373 (setq window (previous-window window))) 374 above-window)) 375 376(defun mouse-drag-move-window-bottom (window growth) 377 "Move the bottom of WINDOW up or down by GROWTH lines. 378Move it down if GROWTH is positive, or up if GROWTH is negative. 379If this would make WINDOW too short, 380shrink the window or windows above it to make room." 381 (condition-case nil 382 (adjust-window-trailing-edge window growth nil) 383 (error nil))) 384 385(defsubst mouse-drag-move-window-top (window growth) 386 "Move the top of WINDOW up or down by GROWTH lines. 387Move it down if GROWTH is positive, or up if GROWTH is negative. 388If this would make WINDOW too short, shrink the window or windows 389above it to make room." 390 ;; Moving the top of WINDOW is actually moving the bottom of the 391 ;; window above. 392 (let ((window-above (mouse-drag-window-above window))) 393 (and window-above 394 (mouse-drag-move-window-bottom window-above (- growth))))) 395 396(defun mouse-drag-mode-line-1 (start-event mode-line-p) 397 "Change the height of a window by dragging on the mode or header line. 398START-EVENT is the starting mouse-event of the drag action. 399MODE-LINE-P non-nil means dragging a mode line; nil means a header line." 400 ;; Give temporary modes such as isearch a chance to turn off. 401 (run-hooks 'mouse-leave-buffer-hook) 402 (let* ((done nil) 403 (echo-keystrokes 0) 404 (start (event-start start-event)) 405 (start-event-window (posn-window start)) 406 (start-event-frame (window-frame start-event-window)) 407 (start-nwindows (count-windows t)) 408 (minibuffer (frame-parameter nil 'minibuffer)) 409 should-enlarge-minibuffer event mouse y top bot edges wconfig growth) 410 (track-mouse 411 (progn 412 ;; if this is the bottommost ordinary window, then to 413 ;; move its modeline the minibuffer must be enlarged. 414 (setq should-enlarge-minibuffer 415 (and minibuffer 416 mode-line-p 417 (not (one-window-p t)) 418 (= (nth 1 (window-edges minibuffer)) 419 (nth 3 (window-edges start-event-window))))) 420 421 ;; loop reading events and sampling the position of 422 ;; the mouse. 423 (while (not done) 424 (setq event (read-event) 425 mouse (mouse-position)) 426 427 ;; do nothing if 428 ;; - there is a switch-frame event. 429 ;; - the mouse isn't in the frame that we started in 430 ;; - the mouse isn't in any Emacs frame 431 ;; drag if 432 ;; - there is a mouse-movement event 433 ;; - there is a scroll-bar-movement event 434 ;; (same as mouse movement for our purposes) 435 ;; quit if 436 ;; - there is a keyboard event or some other unknown event 437 ;; unknown event. 438 (cond ((integerp event) 439 (setq done t)) 440 441 ((memq (car event) '(switch-frame select-window)) 442 nil) 443 444 ((not (memq (car event) '(mouse-movement scroll-bar-movement))) 445 (when (consp event) 446 (push event unread-command-events)) 447 (setq done t)) 448 449 ((not (eq (car mouse) start-event-frame)) 450 nil) 451 452 ((null (car (cdr mouse))) 453 nil) 454 455 (t 456 (setq y (cdr (cdr mouse)) 457 edges (window-edges start-event-window) 458 top (nth 1 edges) 459 bot (nth 3 edges)) 460 461 ;; compute size change needed 462 (cond (mode-line-p 463 (setq growth (- y bot -1))) 464 (t ; header line 465 (when (< (- bot y) window-min-height) 466 (setq y (- bot window-min-height))) 467 ;; The window's top includes the header line! 468 (setq growth (- top y)))) 469 (setq wconfig (current-window-configuration)) 470 471 ;; Check for an error case. 472 (when (and (/= growth 0) 473 (not minibuffer) 474 (one-window-p t)) 475 (error "Attempt to resize sole window")) 476 477 ;; grow/shrink minibuffer? 478 (if should-enlarge-minibuffer 479 (unless resize-mini-windows 480 (mouse-drag-move-window-bottom start-event-window growth)) 481 ;; no. grow/shrink the selected window 482 ;(message "growth = %d" growth) 483 (if mode-line-p 484 (mouse-drag-move-window-bottom start-event-window growth) 485 (mouse-drag-move-window-top start-event-window growth))) 486 487 ;; if this window's growth caused another 488 ;; window to be deleted because it was too 489 ;; short, rescind the change. 490 ;; 491 ;; if size change caused space to be stolen 492 ;; from a window above this one, rescind the 493 ;; change, but only if we didn't grow/shrink 494 ;; the minibuffer. minibuffer size changes 495 ;; can cause all windows to shrink... no way 496 ;; around it. 497 (when (or (/= start-nwindows (count-windows t)) 498 (and (not should-enlarge-minibuffer) 499 (> growth 0) 500 mode-line-p 501 (/= top (nth 1 (window-edges))))) 502 (set-window-configuration wconfig))))))))) 503 504(defun mouse-drag-mode-line (start-event) 505 "Change the height of a window by dragging on the mode line." 506 (interactive "e") 507 (mouse-drag-mode-line-1 start-event t)) 508 509(defun mouse-drag-header-line (start-event) 510 "Change the height of a window by dragging on the header line. 511Windows whose header-lines are at the top of the frame cannot be 512resized by dragging their header-line." 513 (interactive "e") 514 ;; Changing the window's size by dragging its header-line when the 515 ;; header-line is at the top of the frame is somewhat strange, 516 ;; because the header-line doesn't move, so don't do it. 517 (let* ((start (event-start start-event)) 518 (window (posn-window start)) 519 (frame (window-frame window)) 520 (first-window (frame-first-window frame))) 521 (unless (or (eq window first-window) 522 (= (nth 1 (window-edges window)) 523 (nth 1 (window-edges first-window)))) 524 (mouse-drag-mode-line-1 start-event nil)))) 525 526 527(defun mouse-drag-vertical-line-rightward-window (window) 528 "Return a window that is immediately to the right of WINDOW, or nil." 529 (let ((bottom (nth 3 (window-inside-edges window))) 530 (left (nth 0 (window-inside-edges window))) 531 best best-right 532 (try (previous-window window))) 533 (while (not (eq try window)) 534 (let ((try-top (nth 1 (window-inside-edges try))) 535 (try-bottom (nth 3 (window-inside-edges try))) 536 (try-right (nth 2 (window-inside-edges try)))) 537 (if (and (< try-top bottom) 538 (>= try-bottom bottom) 539 (< try-right left) 540 (or (null best-right) (> try-right best-right))) 541 (setq best-right try-right best try))) 542 (setq try (previous-window try))) 543 best)) 544 545(defun mouse-drag-vertical-line (start-event) 546 "Change the width of a window by dragging on the vertical line." 547 (interactive "e") 548 ;; Give temporary modes such as isearch a chance to turn off. 549 (run-hooks 'mouse-leave-buffer-hook) 550 (let* ((done nil) 551 (echo-keystrokes 0) 552 (start-event-frame (window-frame (car (car (cdr start-event))))) 553 (start-event-window (car (car (cdr start-event)))) 554 event mouse x left right edges growth 555 (which-side 556 (or (cdr (assq 'vertical-scroll-bars (frame-parameters start-event-frame))) 557 'right))) 558 (cond 559 ((one-window-p t) 560 (error "Attempt to resize sole ordinary window")) 561 ((and (eq which-side 'right) 562 (>= (nth 2 (window-inside-edges start-event-window)) 563 (frame-width start-event-frame))) 564 (error "Attempt to drag rightmost scrollbar")) 565 ((and (eq which-side 'left) 566 (= (nth 0 (window-inside-edges start-event-window)) 0)) 567 (error "Attempt to drag leftmost scrollbar"))) 568 (track-mouse 569 (progn 570 ;; loop reading events and sampling the position of 571 ;; the mouse. 572 (while (not done) 573 (setq event (read-event) 574 mouse (mouse-position)) 575 ;; do nothing if 576 ;; - there is a switch-frame event. 577 ;; - the mouse isn't in the frame that we started in 578 ;; - the mouse isn't in any Emacs frame 579 ;; drag if 580 ;; - there is a mouse-movement event 581 ;; - there is a scroll-bar-movement event 582 ;; (same as mouse movement for our purposes) 583 ;; quit if 584 ;; - there is a keyboard event or some other unknown event 585 ;; unknown event. 586 (cond ((integerp event) 587 (setq done t)) 588 ((memq (car event) '(switch-frame select-window)) 589 nil) 590 ((not (memq (car event) 591 '(mouse-movement scroll-bar-movement))) 592 (if (consp event) 593 (setq unread-command-events 594 (cons event unread-command-events))) 595 (setq done t)) 596 ((not (eq (car mouse) start-event-frame)) 597 nil) 598 ((null (car (cdr mouse))) 599 nil) 600 (t 601 (let ((window 602 ;; If the scroll bar is on the window's left, 603 ;; adjust the window on the left. 604 (if (eq which-side 'right) 605 start-event-window 606 (mouse-drag-vertical-line-rightward-window 607 start-event-window)))) 608 (setq x (- (car (cdr mouse)) 609 (if (eq which-side 'right) 0 2)) 610 edges (window-edges window) 611 left (nth 0 edges) 612 right (nth 2 edges)) 613 ;; scale back a move that would make the 614 ;; window too thin. 615 (if (< (- x left -1) window-min-width) 616 (setq x (+ left window-min-width -1))) 617 ;; compute size change needed 618 (setq growth (- x right -1)) 619 (condition-case nil 620 (adjust-window-trailing-edge window growth t) 621 (error nil)))))))))) 622 623(defun mouse-set-point (event) 624 "Move point to the position clicked on with the mouse. 625This should be bound to a mouse click event type." 626 (interactive "e") 627 (mouse-minibuffer-check event) 628 ;; Use event-end in case called from mouse-drag-region. 629 ;; If EVENT is a click, event-end and event-start give same value. 630 (posn-set-point (event-end event))) 631 632(defvar mouse-last-region-beg nil) 633(defvar mouse-last-region-end nil) 634(defvar mouse-last-region-tick nil) 635 636(defun mouse-region-match () 637 "Return non-nil if there's an active region that was set with the mouse." 638 (and (mark t) mark-active 639 (eq mouse-last-region-beg (region-beginning)) 640 (eq mouse-last-region-end (region-end)) 641 (eq mouse-last-region-tick (buffer-modified-tick)))) 642 643(defun mouse-set-region (click) 644 "Set the region to the text dragged over, and copy to kill ring. 645This should be bound to a mouse drag event." 646 (interactive "e") 647 (mouse-minibuffer-check click) 648 (let ((posn (event-start click)) 649 (end (event-end click))) 650 (select-window (posn-window posn)) 651 (if (numberp (posn-point posn)) 652 (goto-char (posn-point posn))) 653 ;; If mark is highlighted, no need to bounce the cursor. 654 ;; On X, we highlight while dragging, thus once again no need to bounce. 655 (or transient-mark-mode 656 (memq (framep (selected-frame)) '(x pc w32 mac)) 657 (sit-for 1)) 658 (push-mark) 659 (set-mark (point)) 660 (if (numberp (posn-point end)) 661 (goto-char (posn-point end))) 662 ;; Don't set this-command to kill-region, so that a following 663 ;; C-w will not double the text in the kill ring. 664 ;; Ignore last-command so we don't append to a preceding kill. 665 (when mouse-drag-copy-region 666 (let (this-command last-command deactivate-mark) 667 (copy-region-as-kill (mark) (point)))) 668 (mouse-set-region-1))) 669 670(defun mouse-set-region-1 () 671 ;; Set transient-mark-mode for a little while. 672 (if (memq transient-mark-mode '(nil identity)) 673 (setq transient-mark-mode 'only)) 674 (setq mouse-last-region-beg (region-beginning)) 675 (setq mouse-last-region-end (region-end)) 676 (setq mouse-last-region-tick (buffer-modified-tick))) 677 678(defcustom mouse-scroll-delay 0.25 679 "*The pause between scroll steps caused by mouse drags, in seconds. 680If you drag the mouse beyond the edge of a window, Emacs scrolls the 681window to bring the text beyond that edge into view, with a delay of 682this many seconds between scroll steps. Scrolling stops when you move 683the mouse back into the window, or release the button. 684This variable's value may be non-integral. 685Setting this to zero causes Emacs to scroll as fast as it can." 686 :type 'number 687 :group 'mouse) 688 689(defcustom mouse-scroll-min-lines 1 690 "*The minimum number of lines scrolled by dragging mouse out of window. 691Moving the mouse out the top or bottom edge of the window begins 692scrolling repeatedly. The number of lines scrolled per repetition 693is normally equal to the number of lines beyond the window edge that 694the mouse has moved. However, it always scrolls at least the number 695of lines specified by this variable." 696 :type 'integer 697 :group 'mouse) 698 699(defun mouse-scroll-subr (window jump &optional overlay start) 700 "Scroll the window WINDOW, JUMP lines at a time, until new input arrives. 701If OVERLAY is an overlay, let it stretch from START to the far edge of 702the newly visible text. 703Upon exit, point is at the far edge of the newly visible text." 704 (cond 705 ((and (> jump 0) (< jump mouse-scroll-min-lines)) 706 (setq jump mouse-scroll-min-lines)) 707 ((and (< jump 0) (< (- jump) mouse-scroll-min-lines)) 708 (setq jump (- mouse-scroll-min-lines)))) 709 (let ((opoint (point))) 710 (while (progn 711 (goto-char (window-start window)) 712 (if (not (zerop (vertical-motion jump window))) 713 (progn 714 (set-window-start window (point)) 715 (if (natnump jump) 716 (if (window-end window) 717 (progn 718 (goto-char (window-end window)) 719 ;; window-end doesn't reflect the window's new 720 ;; start position until the next redisplay. 721 (vertical-motion (1- jump) window)) 722 (vertical-motion (- (window-height window) 2))) 723 (goto-char (window-start window))) 724 (if overlay 725 (move-overlay overlay start (point))) 726 ;; Now that we have scrolled WINDOW properly, 727 ;; put point back where it was for the redisplay 728 ;; so that we don't mess up the selected window. 729 (or (eq window (selected-window)) 730 (goto-char opoint)) 731 (sit-for mouse-scroll-delay))))) 732 (or (eq window (selected-window)) 733 (goto-char opoint)))) 734 735;; Create an overlay and immediately delete it, to get "overlay in no buffer". 736(defconst mouse-drag-overlay 737 (let ((ol (make-overlay (point-min) (point-min)))) 738 (delete-overlay ol) 739 (overlay-put ol 'face 'region) 740 ol)) 741 742(defvar mouse-selection-click-count 0) 743 744(defvar mouse-selection-click-count-buffer nil) 745 746(defun mouse-drag-region (start-event) 747 "Set the region to the text that the mouse is dragged over. 748Highlight the drag area as you move the mouse. 749This must be bound to a button-down mouse event. 750In Transient Mark mode, the highlighting remains as long as the mark 751remains active. Otherwise, it remains until the next input event. 752 753If the click is in the echo area, display the `*Messages*' buffer." 754 (interactive "e") 755 (let ((w (posn-window (event-start start-event)))) 756 (if (and (window-minibuffer-p w) 757 (not (minibuffer-window-active-p w))) 758 (save-excursion 759 ;; Swallow the up-event. 760 (read-event) 761 (set-buffer (get-buffer-create "*Messages*")) 762 (goto-char (point-max)) 763 (display-buffer (current-buffer))) 764 ;; Give temporary modes such as isearch a chance to turn off. 765 (run-hooks 'mouse-leave-buffer-hook) 766 (mouse-drag-track start-event t)))) 767 768 769(defun mouse-posn-property (pos property) 770 "Look for a property at click position. 771POS may be either a buffer position or a click position like 772those returned from `event-start'. If the click position is on 773a string, the text property PROPERTY is examined. 774If this is nil or the click is not on a string, then 775the corresponding buffer position is searched for PROPERTY. 776If PROPERTY is encountered in one of those places, 777its value is returned." 778 (if (consp pos) 779 (let ((w (posn-window pos)) (pt (posn-point pos)) 780 (str (posn-string pos))) 781 (or (and str 782 (get-text-property (cdr str) property (car str))) 783 (and pt 784 (get-char-property pt property w)))) 785 (get-char-property pos property))) 786 787(defun mouse-on-link-p (pos) 788 "Return non-nil if POS is on a link in the current buffer. 789POS must be a buffer position in the current buffer or a mouse 790event location in the selected window (see `event-start'). 791However, if `mouse-1-click-in-non-selected-windows' is non-nil, 792POS may be a mouse event location in any window. 793 794A clickable link is identified by one of the following methods: 795 796- If the character at POS has a non-nil `follow-link' text or 797overlay property, the value of that property determines what to do. 798 799- If there is a local key-binding or a keybinding at position POS 800for the `follow-link' event, the binding of that event determines 801what to do. 802 803The resulting value determine whether POS is inside a link: 804 805- If the value is `mouse-face', POS is inside a link if there 806is a non-nil `mouse-face' property at POS. Return t in this case. 807 808- If the value is a function, FUNC, POS is inside a link if 809the call \(FUNC POS) returns non-nil. Return the return value 810from that call. Arg is \(posn-point POS) if POS is a mouse event. 811 812- Otherwise, return the value itself. 813 814The return value is interpreted as follows: 815 816- If it is a string, the mouse-1 event is translated into the 817first character of the string, i.e. the action of the mouse-1 818click is the local or global binding of that character. 819 820- If it is a vector, the mouse-1 event is translated into the 821first element of that vector, i.e. the action of the mouse-1 822click is the local or global binding of that event. 823 824- Otherwise, the mouse-1 event is translated into a mouse-2 event 825at the same position." 826 (let ((action 827 (and (or (not (consp pos)) 828 mouse-1-click-in-non-selected-windows 829 (eq (selected-window) (posn-window pos))) 830 (or (mouse-posn-property pos 'follow-link) 831 (key-binding [follow-link] nil t pos))))) 832 (cond 833 ((eq action 'mouse-face) 834 (and (mouse-posn-property pos 'mouse-face) t)) 835 ((functionp action) 836 ;; FIXME: This seems questionable if the click is not in a buffer. 837 ;; Should we instead decide that `action' takes a `posn'? 838 (if (consp pos) 839 (with-current-buffer (window-buffer (posn-window pos)) 840 (funcall action (posn-point pos))) 841 (funcall action pos))) 842 (t action)))) 843 844(defun mouse-fixup-help-message (msg) 845 "Fix help message MSG for `mouse-1-click-follows-link'." 846 (let (mp pos) 847 (if (and mouse-1-click-follows-link 848 (stringp msg) 849 (save-match-data 850 (string-match "^mouse-2" msg)) 851 (setq mp (mouse-pixel-position)) 852 (consp (setq pos (cdr mp))) 853 (car pos) (>= (car pos) 0) 854 (cdr pos) (>= (cdr pos) 0) 855 (setq pos (posn-at-x-y (car pos) (cdr pos) (car mp))) 856 (windowp (posn-window pos))) 857 (with-current-buffer (window-buffer (posn-window pos)) 858 (if (mouse-on-link-p pos) 859 (setq msg (concat 860 (cond 861 ((eq mouse-1-click-follows-link 'double) "double-") 862 ((and (integerp mouse-1-click-follows-link) 863 (< mouse-1-click-follows-link 0)) "Long ") 864 (t "")) 865 "mouse-1" (substring msg 7))))))) 866 msg) 867 868(defun mouse-move-drag-overlay (ol start end mode) 869 (unless (= start end) 870 ;; Go to START first, so that when we move to END, if it's in the middle 871 ;; of intangible text, point jumps in the direction away from START. 872 ;; Don't do it if START=END otherwise a single click risks selecting 873 ;; a region if it's on intangible text. This exception was originally 874 ;; only applied on entry to mouse-drag-region, which had the problem 875 ;; that a tiny move during a single-click would cause the intangible 876 ;; text to be selected. 877 (goto-char start) 878 (goto-char end) 879 (setq end (point))) 880 (let ((range (mouse-start-end start end mode))) 881 (move-overlay ol (car range) (nth 1 range)))) 882 883(defun mouse-drag-track (start-event &optional 884 do-mouse-drag-region-post-process) 885 "Track mouse drags by highlighting area between point and cursor. 886The region will be defined with mark and point, and the overlay 887will be deleted after return. DO-MOUSE-DRAG-REGION-POST-PROCESS 888should only be used by mouse-drag-region." 889 (mouse-minibuffer-check start-event) 890 (setq mouse-selection-click-count-buffer (current-buffer)) 891 (let* ((original-window (selected-window)) 892 ;; We've recorded what we needed from the current buffer and 893 ;; window, now let's jump to the place of the event, where things 894 ;; are happening. 895 (_ (mouse-set-point start-event)) 896 (echo-keystrokes 0) 897 (start-posn (event-start start-event)) 898 (start-point (posn-point start-posn)) 899 (start-window (posn-window start-posn)) 900 (start-window-start (window-start start-window)) 901 (start-hscroll (window-hscroll start-window)) 902 (bounds (window-edges start-window)) 903 (make-cursor-line-fully-visible nil) 904 (top (nth 1 bounds)) 905 (bottom (if (window-minibuffer-p start-window) 906 (nth 3 bounds) 907 ;; Don't count the mode line. 908 (1- (nth 3 bounds)))) 909 (on-link (and mouse-1-click-follows-link 910 (or mouse-1-click-in-non-selected-windows 911 (eq start-window original-window)) 912 ;; Use start-point before the intangibility 913 ;; treatment, in case we click on a link inside an 914 ;; intangible text. 915 (mouse-on-link-p start-posn))) 916 (click-count (1- (event-click-count start-event))) 917 (remap-double-click (and on-link 918 (eq mouse-1-click-follows-link 'double) 919 (= click-count 1))) 920 ;; Suppress automatic hscrolling, because that is a nuisance 921 ;; when setting point near the right fringe (but see below). 922 (automatic-hscrolling-saved automatic-hscrolling) 923 (automatic-hscrolling nil)) 924 (setq mouse-selection-click-count click-count) 925 ;; In case the down click is in the middle of some intangible text, 926 ;; use the end of that text, and put it in START-POINT. 927 (if (< (point) start-point) 928 (goto-char start-point)) 929 (setq start-point (point)) 930 (if remap-double-click ;; Don't expand mouse overlay in links 931 (setq click-count 0)) 932 (mouse-move-drag-overlay mouse-drag-overlay start-point start-point 933 click-count) 934 (overlay-put mouse-drag-overlay 'window start-window) 935 (deactivate-mark) 936 (let (event end end-point last-end-point) 937 (track-mouse 938 (while (progn 939 (setq event (read-event)) 940 (or (mouse-movement-p event) 941 (memq (car-safe event) '(switch-frame select-window)))) 942 (if (memq (car-safe event) '(switch-frame select-window)) 943 nil 944 ;; Automatic hscrolling did not occur during the call to 945 ;; `read-event'; but if the user subsequently drags the 946 ;; mouse, go ahead and hscroll. 947 (let ((automatic-hscrolling automatic-hscrolling-saved)) 948 (redisplay)) 949 (setq end (event-end event) 950 end-point (posn-point end)) 951 (if (numberp end-point) 952 (setq last-end-point end-point)) 953 954 (cond 955 ;; Are we moving within the original window? 956 ((and (eq (posn-window end) start-window) 957 (integer-or-marker-p end-point)) 958 (mouse-move-drag-overlay mouse-drag-overlay start-point end-point click-count)) 959 960 (t 961 (let ((mouse-row (cdr (cdr (mouse-position))))) 962 (cond 963 ((null mouse-row)) 964 ((< mouse-row top) 965 (mouse-scroll-subr start-window (- mouse-row top) 966 mouse-drag-overlay start-point)) 967 ((>= mouse-row bottom) 968 (mouse-scroll-subr start-window (1+ (- mouse-row bottom)) 969 mouse-drag-overlay start-point))))))))) 970 971 ;; In case we did not get a mouse-motion event 972 ;; for the final move of the mouse before a drag event 973 ;; pretend that we did get one. 974 (when (and (memq 'drag (event-modifiers (car-safe event))) 975 (setq end (event-end event) 976 end-point (posn-point end)) 977 (eq (posn-window end) start-window) 978 (integer-or-marker-p end-point)) 979 (mouse-move-drag-overlay mouse-drag-overlay start-point end-point click-count)) 980 981 ;; Handle the terminating event 982 (if (consp event) 983 (let* ((fun (key-binding (vector (car event)))) 984 (do-multi-click (and (> (event-click-count event) 0) 985 (functionp fun) 986 (not (memq fun 987 '(mouse-set-point 988 mouse-set-region)))))) 989 ;; Run the binding of the terminating up-event, if possible. 990 (if (and (not (= (overlay-start mouse-drag-overlay) 991 (overlay-end mouse-drag-overlay))) 992 (not do-multi-click)) 993 (let* ((stop-point 994 (if (numberp (posn-point (event-end event))) 995 (posn-point (event-end event)) 996 last-end-point)) 997 ;; The end that comes from where we ended the drag. 998 ;; Point goes here. 999 (region-termination 1000 (if (and stop-point (< stop-point start-point)) 1001 (overlay-start mouse-drag-overlay) 1002 (overlay-end mouse-drag-overlay))) 1003 ;; The end that comes from where we started the drag. 1004 ;; Mark goes there. 1005 (region-commencement 1006 (- (+ (overlay-end mouse-drag-overlay) 1007 (overlay-start mouse-drag-overlay)) 1008 region-termination)) 1009 last-command this-command) 1010 (push-mark region-commencement t t) 1011 (goto-char region-termination) 1012 (if (not do-mouse-drag-region-post-process) 1013 ;; Skip all post-event handling, return immediately. 1014 (delete-overlay mouse-drag-overlay) 1015 ;; Don't let copy-region-as-kill set deactivate-mark. 1016 (when mouse-drag-copy-region 1017 (let (deactivate-mark) 1018 (copy-region-as-kill (point) (mark t)))) 1019 (let ((buffer (current-buffer))) 1020 (mouse-show-mark) 1021 ;; mouse-show-mark can call read-event, 1022 ;; and that means the Emacs server could switch buffers 1023 ;; under us. If that happened, 1024 ;; avoid trying to use the region. 1025 (and (mark t) mark-active 1026 (eq buffer (current-buffer)) 1027 (mouse-set-region-1))))) 1028 ;; Run the binding of the terminating up-event. 1029 ;; If a multiple click is not bound to mouse-set-point, 1030 ;; cancel the effects of mouse-move-drag-overlay to 1031 ;; avoid producing wrong results. 1032 (if do-multi-click (goto-char start-point)) 1033 (delete-overlay mouse-drag-overlay) 1034 (when (and (functionp fun) 1035 (= start-hscroll (window-hscroll start-window)) 1036 ;; Don't run the up-event handler if the 1037 ;; window start changed in a redisplay after 1038 ;; the mouse-set-point for the down-mouse 1039 ;; event at the beginning of this function. 1040 ;; When the window start has changed, the 1041 ;; up-mouse event will contain a different 1042 ;; position due to the new window contents, 1043 ;; and point is set again. 1044 (or end-point 1045 (= (window-start start-window) 1046 start-window-start))) 1047 (when (and on-link 1048 (or (not end-point) (= end-point start-point)) 1049 (consp event) 1050 (or remap-double-click 1051 (and 1052 (not (eq mouse-1-click-follows-link 'double)) 1053 (= click-count 0) 1054 (= (event-click-count event) 1) 1055 (or (not (integerp mouse-1-click-follows-link)) 1056 (let ((t0 (posn-timestamp (event-start start-event))) 1057 (t1 (posn-timestamp (event-end event)))) 1058 (and (integerp t0) (integerp t1) 1059 (if (> mouse-1-click-follows-link 0) 1060 (<= (- t1 t0) mouse-1-click-follows-link) 1061 (< (- t0 t1) mouse-1-click-follows-link)))))))) 1062 ;; If we rebind to mouse-2, reselect previous selected window, 1063 ;; so that the mouse-2 event runs in the same 1064 ;; situation as if user had clicked it directly. 1065 ;; Fixes the bug reported by juri@jurta.org on 2005-12-27. 1066 (if (or (vectorp on-link) (stringp on-link)) 1067 (setq event (aref on-link 0)) 1068 (select-window original-window) 1069 (setcar event 'mouse-2) 1070 ;; If this mouse click has never been done by 1071 ;; the user, it doesn't have the necessary 1072 ;; property to be interpreted correctly. 1073 (put 'mouse-2 'event-kind 'mouse-click))) 1074 (push event unread-command-events)))) 1075 1076 ;; Case where the end-event is not a cons cell (it's just a boring 1077 ;; char-key-press). 1078 (delete-overlay mouse-drag-overlay))))) 1079 1080;; Commands to handle xterm-style multiple clicks. 1081(defun mouse-skip-word (dir) 1082 "Skip over word, over whitespace, or over identical punctuation. 1083If DIR is positive skip forward; if negative, skip backward." 1084 (let* ((char (following-char)) 1085 (syntax (char-to-string (char-syntax char)))) 1086 (cond ((string= syntax "w") 1087 ;; Here, we can't use skip-syntax-forward/backward because 1088 ;; they don't pay attention to word-separating-categories, 1089 ;; and thus they will skip over a true word boundary. So, 1090 ;; we simularte the original behaviour by using 1091 ;; forward-word. 1092 (if (< dir 0) 1093 (if (not (looking-at "\\<")) 1094 (forward-word -1)) 1095 (if (or (looking-at "\\<") (not (looking-at "\\>"))) 1096 (forward-word 1)))) 1097 ((string= syntax " ") 1098 (if (< dir 0) 1099 (skip-syntax-backward syntax) 1100 (skip-syntax-forward syntax))) 1101 ((string= syntax "_") 1102 (if (< dir 0) 1103 (skip-syntax-backward "w_") 1104 (skip-syntax-forward "w_"))) 1105 ((< dir 0) 1106 (while (and (not (bobp)) (= (preceding-char) char)) 1107 (forward-char -1))) 1108 (t 1109 (while (and (not (eobp)) (= (following-char) char)) 1110 (forward-char 1)))))) 1111 1112(defun mouse-start-end (start end mode) 1113 "Return a list of region bounds based on START and END according to MODE. 1114If MODE is 0 then set point to (min START END), mark to (max START END). 1115If MODE is 1 then set point to start of word at (min START END), 1116mark to end of word at (max START END). 1117If MODE is 2 then do the same for lines." 1118 (if (> start end) 1119 (let ((temp start)) 1120 (setq start end 1121 end temp))) 1122 (setq mode (mod mode 3)) 1123 (cond ((= mode 0) 1124 (list start end)) 1125 ((and (= mode 1) 1126 (= start end) 1127 (char-after start) 1128 (= (char-syntax (char-after start)) ?\()) 1129 (list start 1130 (save-excursion 1131 (goto-char start) 1132 (forward-sexp 1) 1133 (point)))) 1134 ((and (= mode 1) 1135 (= start end) 1136 (char-after start) 1137 (= (char-syntax (char-after start)) ?\))) 1138 (list (save-excursion 1139 (goto-char (1+ start)) 1140 (backward-sexp 1) 1141 (point)) 1142 (1+ start))) 1143 ((and (= mode 1) 1144 (= start end) 1145 (char-after start) 1146 (= (char-syntax (char-after start)) ?\")) 1147 (let ((open (or (eq start (point-min)) 1148 (save-excursion 1149 (goto-char (- start 1)) 1150 (looking-at "\\s(\\|\\s \\|\\s>"))))) 1151 (if open 1152 (list start 1153 (save-excursion 1154 (condition-case nil 1155 (progn 1156 (goto-char start) 1157 (forward-sexp 1) 1158 (point)) 1159 (error end)))) 1160 (list (save-excursion 1161 (condition-case nil 1162 (progn 1163 (goto-char (1+ start)) 1164 (backward-sexp 1) 1165 (point)) 1166 (error end))) 1167 (1+ start))))) 1168 ((= mode 1) 1169 (list (save-excursion 1170 (goto-char start) 1171 (mouse-skip-word -1) 1172 (point)) 1173 (save-excursion 1174 (goto-char end) 1175 (mouse-skip-word 1) 1176 (point)))) 1177 ((= mode 2) 1178 (list (save-excursion 1179 (goto-char start) 1180 (beginning-of-line 1) 1181 (point)) 1182 (save-excursion 1183 (goto-char end) 1184 (forward-line 1) 1185 (point)))))) 1186 1187;; Subroutine: set the mark where CLICK happened, 1188;; but don't do anything else. 1189(defun mouse-set-mark-fast (click) 1190 (mouse-minibuffer-check click) 1191 (let ((posn (event-start click))) 1192 (select-window (posn-window posn)) 1193 (if (numberp (posn-point posn)) 1194 (push-mark (posn-point posn) t t)))) 1195 1196(defun mouse-undouble-last-event (events) 1197 (let* ((index (1- (length events))) 1198 (last (nthcdr index events)) 1199 (event (car last)) 1200 (basic (event-basic-type event)) 1201 (old-modifiers (event-modifiers event)) 1202 (modifiers (delq 'double (delq 'triple (copy-sequence old-modifiers)))) 1203 (new 1204 (if (consp event) 1205 ;; Use reverse, not nreverse, since event-modifiers 1206 ;; does not copy the list it returns. 1207 (cons (event-convert-list (reverse (cons basic modifiers))) 1208 (cdr event)) 1209 event))) 1210 (setcar last new) 1211 (if (and (not (equal modifiers old-modifiers)) 1212 (key-binding (apply 'vector events))) 1213 t 1214 (setcar last event) 1215 nil))) 1216 1217;; Momentarily show where the mark is, if highlighting doesn't show it. 1218 1219(defcustom mouse-region-delete-keys '([delete] [deletechar] [backspace]) 1220 "List of keys that should cause the mouse region to be deleted." 1221 :group 'mouse 1222 :type '(repeat key-sequence)) 1223 1224(defun mouse-show-mark () 1225 (let ((inhibit-quit t) 1226 (echo-keystrokes 0) 1227 event events key ignore 1228 (x-lost-selection-functions 1229 (when (boundp 'x-lost-selection-functions) 1230 (copy-sequence x-lost-selection-functions)))) 1231 (add-hook 'x-lost-selection-functions 1232 (lambda (seltype) 1233 (when (eq seltype 'PRIMARY) 1234 (setq ignore t) 1235 (throw 'mouse-show-mark t)))) 1236 (if transient-mark-mode 1237 (delete-overlay mouse-drag-overlay) 1238 (move-overlay mouse-drag-overlay (point) (mark t))) 1239 (catch 'mouse-show-mark 1240 ;; In this loop, execute scroll bar and switch-frame events. 1241 ;; Should we similarly handle `select-window' events? --Stef 1242 ;; Also ignore down-events that are undefined. 1243 (while (progn (setq event (read-event)) 1244 (setq events (append events (list event))) 1245 (setq key (apply 'vector events)) 1246 (or (and (consp event) 1247 (eq (car event) 'switch-frame)) 1248 (and (consp event) 1249 (eq (posn-point (event-end event)) 1250 'vertical-scroll-bar)) 1251 (and (memq 'down (event-modifiers event)) 1252 (not (key-binding key)) 1253 (not (mouse-undouble-last-event events)) 1254 (not (member key mouse-region-delete-keys))))) 1255 (and (consp event) 1256 (or (eq (car event) 'switch-frame) 1257 (eq (posn-point (event-end event)) 1258 'vertical-scroll-bar)) 1259 (let ((keys (vector 'vertical-scroll-bar event))) 1260 (and (key-binding keys) 1261 (progn 1262 (call-interactively (key-binding keys) 1263 nil keys) 1264 (setq events nil))))))) 1265 ;; If we lost the selection, just turn off the highlighting. 1266 (unless ignore 1267 ;; For certain special keys, delete the region. 1268 (if (member key mouse-region-delete-keys) 1269 (progn 1270 ;; Since notionally this is a separate command, 1271 ;; run all the hooks that would be run if it were 1272 ;; executed separately. 1273 (run-hooks 'post-command-hook) 1274 (setq last-command this-command) 1275 (setq this-original-command 'delete-region) 1276 (setq this-command (or (command-remapping this-original-command) 1277 this-original-command)) 1278 (run-hooks 'pre-command-hook) 1279 (call-interactively this-command)) 1280 ;; Otherwise, unread the key so it gets executed normally. 1281 (setq unread-command-events 1282 (nconc events unread-command-events)))) 1283 (setq quit-flag nil) 1284 (unless transient-mark-mode 1285 (delete-overlay mouse-drag-overlay)))) 1286 1287(defun mouse-set-mark (click) 1288 "Set mark at the position clicked on with the mouse. 1289Display cursor at that position for a second. 1290This must be bound to a mouse click." 1291 (interactive "e") 1292 (mouse-minibuffer-check click) 1293 (select-window (posn-window (event-start click))) 1294 ;; We don't use save-excursion because that preserves the mark too. 1295 (let ((point-save (point))) 1296 (unwind-protect 1297 (progn (mouse-set-point click) 1298 (push-mark nil t t) 1299 (or transient-mark-mode 1300 (sit-for 1))) 1301 (goto-char point-save)))) 1302 1303(defun mouse-kill (click) 1304 "Kill the region between point and the mouse click. 1305The text is saved in the kill ring, as with \\[kill-region]." 1306 (interactive "e") 1307 (mouse-minibuffer-check click) 1308 (let* ((posn (event-start click)) 1309 (click-posn (posn-point posn))) 1310 (select-window (posn-window posn)) 1311 (if (numberp click-posn) 1312 (kill-region (min (point) click-posn) 1313 (max (point) click-posn))))) 1314 1315(defun mouse-yank-at-click (click arg) 1316 "Insert the last stretch of killed text at the position clicked on. 1317Also move point to one end of the text thus inserted (normally the end), 1318and set mark at the beginning. 1319Prefix arguments are interpreted as with \\[yank]. 1320If `mouse-yank-at-point' is non-nil, insert at point 1321regardless of where you click." 1322 (interactive "e\nP") 1323 ;; Give temporary modes such as isearch a chance to turn off. 1324 (run-hooks 'mouse-leave-buffer-hook) 1325 (or mouse-yank-at-point (mouse-set-point click)) 1326 (setq this-command 'yank) 1327 (setq mouse-selection-click-count 0) 1328 (yank arg)) 1329 1330(defun mouse-kill-ring-save (click) 1331 "Copy the region between point and the mouse click in the kill ring. 1332This does not delete the region; it acts like \\[kill-ring-save]." 1333 (interactive "e") 1334 (mouse-set-mark-fast click) 1335 (let (this-command last-command) 1336 (kill-ring-save (point) (mark t))) 1337 (mouse-show-mark)) 1338 1339;;; This function used to delete the text between point and the mouse 1340;;; whenever it was equal to the front of the kill ring, but some 1341;;; people found that confusing. 1342 1343;;; A list (TEXT START END), describing the text and position of the last 1344;;; invocation of mouse-save-then-kill. 1345(defvar mouse-save-then-kill-posn nil) 1346 1347(defun mouse-save-then-kill-delete-region (beg end) 1348 ;; We must make our own undo boundaries 1349 ;; because they happen automatically only for the current buffer. 1350 (undo-boundary) 1351 (if (or (= beg end) (eq buffer-undo-list t)) 1352 ;; If we have no undo list in this buffer, 1353 ;; just delete. 1354 (delete-region beg end) 1355 ;; Delete, but make the undo-list entry share with the kill ring. 1356 ;; First, delete just one char, so in case buffer is being modified 1357 ;; for the first time, the undo list records that fact. 1358 (let (before-change-functions after-change-functions) 1359 (delete-region beg 1360 (+ beg (if (> end beg) 1 -1)))) 1361 (let ((buffer-undo-list buffer-undo-list)) 1362 ;; Undo that deletion--but don't change the undo list! 1363 (let (before-change-functions after-change-functions) 1364 (primitive-undo 1 buffer-undo-list)) 1365 ;; Now delete the rest of the specified region, 1366 ;; but don't record it. 1367 (setq buffer-undo-list t) 1368 (if (/= (length (car kill-ring)) (- (max end beg) (min end beg))) 1369 (error "Lossage in mouse-save-then-kill-delete-region")) 1370 (delete-region beg end)) 1371 (let ((tail buffer-undo-list)) 1372 ;; Search back in buffer-undo-list for the string 1373 ;; that came from deleting one character. 1374 (while (and tail (not (stringp (car (car tail))))) 1375 (setq tail (cdr tail))) 1376 ;; Replace it with an entry for the entire deleted text. 1377 (and tail 1378 (setcar tail (cons (car kill-ring) (min beg end)))))) 1379 (undo-boundary)) 1380 1381(defun mouse-save-then-kill (click) 1382 "Save text to point in kill ring; the second time, kill the text. 1383If the text between point and the mouse is the same as what's 1384at the front of the kill ring, this deletes the text. 1385Otherwise, it adds the text to the kill ring, like \\[kill-ring-save], 1386which prepares for a second click to delete the text. 1387 1388If you have selected words or lines, this command extends the 1389selection through the word or line clicked on. If you do this 1390again in a different position, it extends the selection again. 1391If you do this twice in the same position, the selection is killed." 1392 (interactive "e") 1393 (let ((before-scroll 1394 (with-current-buffer (window-buffer (posn-window (event-start click))) 1395 point-before-scroll))) 1396 (mouse-minibuffer-check click) 1397 (let ((click-posn (posn-point (event-start click))) 1398 ;; Don't let a subsequent kill command append to this one: 1399 ;; prevent setting this-command to kill-region. 1400 (this-command this-command)) 1401 (if (and (with-current-buffer 1402 (window-buffer (posn-window (event-start click))) 1403 (and (mark t) (> (mod mouse-selection-click-count 3) 0) 1404 ;; Don't be fooled by a recent click in some other buffer. 1405 (eq mouse-selection-click-count-buffer 1406 (current-buffer))))) 1407 (if (not (and (eq last-command 'mouse-save-then-kill) 1408 (equal click-posn 1409 (car (cdr-safe (cdr-safe mouse-save-then-kill-posn)))))) 1410 ;; Find both ends of the object selected by this click. 1411 (let* ((range 1412 (mouse-start-end click-posn click-posn 1413 mouse-selection-click-count))) 1414 ;; Move whichever end is closer to the click. 1415 ;; That's what xterm does, and it seems reasonable. 1416 (if (< (abs (- click-posn (mark t))) 1417 (abs (- click-posn (point)))) 1418 (set-mark (car range)) 1419 (goto-char (nth 1 range))) 1420 ;; We have already put the old region in the kill ring. 1421 ;; Replace it with the extended region. 1422 ;; (It would be annoying to make a separate entry.) 1423 (kill-new (buffer-substring (point) (mark t)) t) 1424 (mouse-set-region-1) 1425 ;; Arrange for a repeated mouse-3 to kill this region. 1426 (setq mouse-save-then-kill-posn 1427 (list (car kill-ring) (point) click-posn)) 1428 (mouse-show-mark)) 1429 ;; If we click this button again without moving it, 1430 ;; that time kill. 1431 (mouse-save-then-kill-delete-region (mark) (point)) 1432 (setq mouse-selection-click-count 0) 1433 (setq mouse-save-then-kill-posn nil)) 1434 (if (and (eq last-command 'mouse-save-then-kill) 1435 mouse-save-then-kill-posn 1436 (eq (car mouse-save-then-kill-posn) (car kill-ring)) 1437 (equal (cdr mouse-save-then-kill-posn) (list (point) click-posn))) 1438 ;; If this is the second time we've called 1439 ;; mouse-save-then-kill, delete the text from the buffer. 1440 (progn 1441 (mouse-save-then-kill-delete-region (point) (mark)) 1442 ;; After we kill, another click counts as "the first time". 1443 (setq mouse-save-then-kill-posn nil)) 1444 ;; This is not a repetition. 1445 ;; We are adjusting an old selection or creating a new one. 1446 (if (or (and (eq last-command 'mouse-save-then-kill) 1447 mouse-save-then-kill-posn) 1448 (and mark-active transient-mark-mode) 1449 (and (memq last-command 1450 '(mouse-drag-region mouse-set-region)) 1451 (or mark-even-if-inactive 1452 (not transient-mark-mode)))) 1453 ;; We have a selection or suitable region, so adjust it. 1454 (let* ((posn (event-start click)) 1455 (new (posn-point posn))) 1456 (select-window (posn-window posn)) 1457 (if (numberp new) 1458 (progn 1459 ;; Move whichever end of the region is closer to the click. 1460 ;; That is what xterm does, and it seems reasonable. 1461 (if (<= (abs (- new (point))) (abs (- new (mark t)))) 1462 (goto-char new) 1463 (set-mark new)) 1464 (setq deactivate-mark nil))) 1465 (kill-new (buffer-substring (point) (mark t)) t)) 1466 ;; Set the mark where point is, then move where clicked. 1467 (mouse-set-mark-fast click) 1468 (if before-scroll 1469 (goto-char before-scroll)) 1470 (exchange-point-and-mark) ;Why??? --Stef 1471 (kill-new (buffer-substring (point) (mark t)))) 1472 (mouse-show-mark) 1473 (mouse-set-region-1) 1474 (setq mouse-save-then-kill-posn 1475 (list (car kill-ring) (point) click-posn))))))) 1476 1477(global-set-key [M-mouse-1] 'mouse-start-secondary) 1478(global-set-key [M-drag-mouse-1] 'mouse-set-secondary) 1479(global-set-key [M-down-mouse-1] 'mouse-drag-secondary) 1480(global-set-key [M-mouse-3] 'mouse-secondary-save-then-kill) 1481(global-set-key [M-mouse-2] 'mouse-yank-secondary) 1482 1483(defconst mouse-secondary-overlay 1484 (let ((ol (make-overlay (point-min) (point-min)))) 1485 (delete-overlay ol) 1486 (overlay-put ol 'face 'secondary-selection) 1487 ol) 1488 "An overlay which records the current secondary selection. 1489It is deleted when there is no secondary selection.") 1490 1491(defvar mouse-secondary-click-count 0) 1492 1493;; A marker which records the specified first end for a secondary selection. 1494;; May be nil. 1495(defvar mouse-secondary-start nil) 1496 1497(defun mouse-start-secondary (click) 1498 "Set one end of the secondary selection to the position clicked on. 1499Use \\[mouse-secondary-save-then-kill] to set the other end 1500and complete the secondary selection." 1501 (interactive "e") 1502 (mouse-minibuffer-check click) 1503 (let ((posn (event-start click))) 1504 (with-current-buffer (window-buffer (posn-window posn)) 1505 ;; Cancel any preexisting secondary selection. 1506 (delete-overlay mouse-secondary-overlay) 1507 (if (numberp (posn-point posn)) 1508 (progn 1509 (or mouse-secondary-start 1510 (setq mouse-secondary-start (make-marker))) 1511 (move-marker mouse-secondary-start (posn-point posn))))))) 1512 1513(defun mouse-set-secondary (click) 1514 "Set the secondary selection to the text that the mouse is dragged over. 1515This must be bound to a mouse drag event." 1516 (interactive "e") 1517 (mouse-minibuffer-check click) 1518 (let ((posn (event-start click)) 1519 beg 1520 (end (event-end click))) 1521 (with-current-buffer (window-buffer (posn-window posn)) 1522 (if (numberp (posn-point posn)) 1523 (setq beg (posn-point posn))) 1524 (move-overlay mouse-secondary-overlay beg (posn-point end)) 1525 (x-set-selection 1526 'SECONDARY 1527 (buffer-substring (overlay-start mouse-secondary-overlay) 1528 (overlay-end mouse-secondary-overlay)))))) 1529 1530(defun mouse-drag-secondary (start-event) 1531 "Set the secondary selection to the text that the mouse is dragged over. 1532Highlight the drag area as you move the mouse. 1533This must be bound to a button-down mouse event. 1534The function returns a non-nil value if it creates a secondary selection." 1535 (interactive "e") 1536 (mouse-minibuffer-check start-event) 1537 (let* ((echo-keystrokes 0) 1538 (start-posn (event-start start-event)) 1539 (start-point (posn-point start-posn)) 1540 (start-window (posn-window start-posn)) 1541 (bounds (window-edges start-window)) 1542 (top (nth 1 bounds)) 1543 (bottom (if (window-minibuffer-p start-window) 1544 (nth 3 bounds) 1545 ;; Don't count the mode line. 1546 (1- (nth 3 bounds)))) 1547 (click-count (1- (event-click-count start-event)))) 1548 (with-current-buffer (window-buffer start-window) 1549 (setq mouse-secondary-click-count click-count) 1550 (if (> (mod click-count 3) 0) 1551 ;; Double or triple press: make an initial selection 1552 ;; of one word or line. 1553 (let ((range (mouse-start-end start-point start-point click-count))) 1554 (set-marker mouse-secondary-start nil) 1555 ;; Why the double move? --Stef 1556 ;; (move-overlay mouse-secondary-overlay 1 1 1557 ;; (window-buffer start-window)) 1558 (move-overlay mouse-secondary-overlay (car range) (nth 1 range) 1559 (window-buffer start-window))) 1560 ;; Single-press: cancel any preexisting secondary selection. 1561 (or mouse-secondary-start 1562 (setq mouse-secondary-start (make-marker))) 1563 (set-marker mouse-secondary-start start-point) 1564 (delete-overlay mouse-secondary-overlay)) 1565 (let (event end end-point) 1566 (track-mouse 1567 (while (progn 1568 (setq event (read-event)) 1569 (or (mouse-movement-p event) 1570 (memq (car-safe event) '(switch-frame select-window)))) 1571 1572 (if (memq (car-safe event) '(switch-frame select-window)) 1573 nil 1574 (setq end (event-end event) 1575 end-point (posn-point end)) 1576 (cond 1577 ;; Are we moving within the original window? 1578 ((and (eq (posn-window end) start-window) 1579 (integer-or-marker-p end-point)) 1580 (let ((range (mouse-start-end start-point end-point 1581 click-count))) 1582 (if (or (/= start-point end-point) 1583 (null (marker-position mouse-secondary-start))) 1584 (progn 1585 (set-marker mouse-secondary-start nil) 1586 (move-overlay mouse-secondary-overlay 1587 (car range) (nth 1 range)))))) 1588 (t 1589 (let ((mouse-row (cdr (cdr (mouse-position))))) 1590 (cond 1591 ((null mouse-row)) 1592 ((< mouse-row top) 1593 (mouse-scroll-subr start-window (- mouse-row top) 1594 mouse-secondary-overlay start-point)) 1595 ((>= mouse-row bottom) 1596 (mouse-scroll-subr start-window (1+ (- mouse-row bottom)) 1597 mouse-secondary-overlay start-point))))))))) 1598 1599 (if (consp event) 1600 (if (marker-position mouse-secondary-start) 1601 (save-window-excursion 1602 (delete-overlay mouse-secondary-overlay) 1603 (x-set-selection 'SECONDARY nil) 1604 (select-window start-window) 1605 (save-excursion 1606 (goto-char mouse-secondary-start) 1607 (sit-for 1) 1608 nil)) 1609 (x-set-selection 1610 'SECONDARY 1611 (buffer-substring (overlay-start mouse-secondary-overlay) 1612 (overlay-end mouse-secondary-overlay))))))))) 1613 1614(defun mouse-yank-secondary (click) 1615 "Insert the secondary selection at the position clicked on. 1616Move point to the end of the inserted text. 1617If `mouse-yank-at-point' is non-nil, insert at point 1618regardless of where you click." 1619 (interactive "e") 1620 ;; Give temporary modes such as isearch a chance to turn off. 1621 (run-hooks 'mouse-leave-buffer-hook) 1622 (or mouse-yank-at-point (mouse-set-point click)) 1623 (insert (x-get-selection 'SECONDARY))) 1624 1625(defun mouse-kill-secondary () 1626 "Kill the text in the secondary selection. 1627This is intended more as a keyboard command than as a mouse command 1628but it can work as either one. 1629 1630The current buffer (in case of keyboard use), or the buffer clicked on, 1631must be the one that the secondary selection is in. This requirement 1632is to prevent accidents." 1633 (interactive) 1634 (let* ((keys (this-command-keys)) 1635 (click (elt keys (1- (length keys))))) 1636 (or (eq (overlay-buffer mouse-secondary-overlay) 1637 (if (listp click) 1638 (window-buffer (posn-window (event-start click))) 1639 (current-buffer))) 1640 (error "Select or click on the buffer where the secondary selection is"))) 1641 (let (this-command) 1642 (with-current-buffer (overlay-buffer mouse-secondary-overlay) 1643 (kill-region (overlay-start mouse-secondary-overlay) 1644 (overlay-end mouse-secondary-overlay)))) 1645 (delete-overlay mouse-secondary-overlay) 1646;;; (x-set-selection 'SECONDARY nil) 1647 ) 1648 1649(defun mouse-secondary-save-then-kill (click) 1650 "Save text to point in kill ring; the second time, kill the text. 1651You must use this in a buffer where you have recently done \\[mouse-start-secondary]. 1652If the text between where you did \\[mouse-start-secondary] and where 1653you use this command matches the text at the front of the kill ring, 1654this command deletes the text. 1655Otherwise, it adds the text to the kill ring, like \\[kill-ring-save], 1656which prepares for a second click with this command to delete the text. 1657 1658If you have already made a secondary selection in that buffer, 1659this command extends or retracts the selection to where you click. 1660If you do this again in a different position, it extends or retracts 1661again. If you do this twice in the same position, it kills the selection." 1662 (interactive "e") 1663 (mouse-minibuffer-check click) 1664 (let ((posn (event-start click)) 1665 (click-posn (posn-point (event-start click))) 1666 ;; Don't let a subsequent kill command append to this one: 1667 ;; prevent setting this-command to kill-region. 1668 (this-command this-command)) 1669 (or (eq (window-buffer (posn-window posn)) 1670 (or (overlay-buffer mouse-secondary-overlay) 1671 (if mouse-secondary-start 1672 (marker-buffer mouse-secondary-start)))) 1673 (error "Wrong buffer")) 1674 (with-current-buffer (window-buffer (posn-window posn)) 1675 (if (> (mod mouse-secondary-click-count 3) 0) 1676 (if (not (and (eq last-command 'mouse-secondary-save-then-kill) 1677 (equal click-posn 1678 (car (cdr-safe (cdr-safe mouse-save-then-kill-posn)))))) 1679 ;; Find both ends of the object selected by this click. 1680 (let* ((range 1681 (mouse-start-end click-posn click-posn 1682 mouse-secondary-click-count))) 1683 ;; Move whichever end is closer to the click. 1684 ;; That's what xterm does, and it seems reasonable. 1685 (if (< (abs (- click-posn (overlay-start mouse-secondary-overlay))) 1686 (abs (- click-posn (overlay-end mouse-secondary-overlay)))) 1687 (move-overlay mouse-secondary-overlay (car range) 1688 (overlay-end mouse-secondary-overlay)) 1689 (move-overlay mouse-secondary-overlay 1690 (overlay-start mouse-secondary-overlay) 1691 (nth 1 range))) 1692 ;; We have already put the old region in the kill ring. 1693 ;; Replace it with the extended region. 1694 ;; (It would be annoying to make a separate entry.) 1695 (kill-new (buffer-substring 1696 (overlay-start mouse-secondary-overlay) 1697 (overlay-end mouse-secondary-overlay)) t) 1698 ;; Arrange for a repeated mouse-3 to kill this region. 1699 (setq mouse-save-then-kill-posn 1700 (list (car kill-ring) (point) click-posn))) 1701 ;; If we click this button again without moving it, 1702 ;; that time kill. 1703 (progn 1704 (mouse-save-then-kill-delete-region 1705 (overlay-start mouse-secondary-overlay) 1706 (overlay-end mouse-secondary-overlay)) 1707 (setq mouse-save-then-kill-posn nil) 1708 (setq mouse-secondary-click-count 0) 1709 (delete-overlay mouse-secondary-overlay))) 1710 (if (and (eq last-command 'mouse-secondary-save-then-kill) 1711 mouse-save-then-kill-posn 1712 (eq (car mouse-save-then-kill-posn) (car kill-ring)) 1713 (equal (cdr mouse-save-then-kill-posn) (list (point) click-posn))) 1714 ;; If this is the second time we've called 1715 ;; mouse-secondary-save-then-kill, delete the text from the buffer. 1716 (progn 1717 (mouse-save-then-kill-delete-region 1718 (overlay-start mouse-secondary-overlay) 1719 (overlay-end mouse-secondary-overlay)) 1720 (setq mouse-save-then-kill-posn nil) 1721 (delete-overlay mouse-secondary-overlay)) 1722 (if (overlay-start mouse-secondary-overlay) 1723 ;; We have a selection, so adjust it. 1724 (progn 1725 (if (numberp click-posn) 1726 (progn 1727 ;; Move whichever end of the region is closer to the click. 1728 ;; That is what xterm does, and it seems reasonable. 1729 (if (< (abs (- click-posn (overlay-start mouse-secondary-overlay))) 1730 (abs (- click-posn (overlay-end mouse-secondary-overlay)))) 1731 (move-overlay mouse-secondary-overlay click-posn 1732 (overlay-end mouse-secondary-overlay)) 1733 (move-overlay mouse-secondary-overlay 1734 (overlay-start mouse-secondary-overlay) 1735 click-posn)) 1736 (setq deactivate-mark nil))) 1737 (if (eq last-command 'mouse-secondary-save-then-kill) 1738 ;; If the front of the kill ring comes from 1739 ;; an immediately previous use of this command, 1740 ;; replace it with the extended region. 1741 ;; (It would be annoying to make a separate entry.) 1742 (kill-new (buffer-substring 1743 (overlay-start mouse-secondary-overlay) 1744 (overlay-end mouse-secondary-overlay)) t) 1745 (let (deactivate-mark) 1746 (copy-region-as-kill (overlay-start mouse-secondary-overlay) 1747 (overlay-end mouse-secondary-overlay))))) 1748 (if mouse-secondary-start 1749 ;; All we have is one end of a selection, 1750 ;; so put the other end here. 1751 (let ((start (+ 0 mouse-secondary-start))) 1752 (kill-ring-save start click-posn) 1753 (move-overlay mouse-secondary-overlay start click-posn)))) 1754 (setq mouse-save-then-kill-posn 1755 (list (car kill-ring) (point) click-posn)))) 1756 (if (overlay-buffer mouse-secondary-overlay) 1757 (x-set-selection 'SECONDARY 1758 (buffer-substring 1759 (overlay-start mouse-secondary-overlay) 1760 (overlay-end mouse-secondary-overlay))))))) 1761 1762(defcustom mouse-buffer-menu-maxlen 20 1763 "*Number of buffers in one pane (submenu) of the buffer menu. 1764If we have lots of buffers, divide them into groups of 1765`mouse-buffer-menu-maxlen' and make a pane (or submenu) for each one." 1766 :type 'integer 1767 :group 'mouse) 1768 1769(defcustom mouse-buffer-menu-mode-mult 4 1770 "*Group the buffers by the major mode groups on \\[mouse-buffer-menu]? 1771This number which determines (in a hairy way) whether \\[mouse-buffer-menu] 1772will split the buffer menu by the major modes (see 1773`mouse-buffer-menu-mode-groups') or just by menu length. 1774Set to 1 (or even 0!) if you want to group by major mode always, and to 1775a large number if you prefer a mixed multitude. The default is 4." 1776 :type 'integer 1777 :group 'mouse 1778 :version "20.3") 1779 1780(defvar mouse-buffer-menu-mode-groups 1781 '(("Info\\|Help\\|Apropos\\|Man" . "Help") 1782 ("\\bVM\\b\\|\\bMH\\b\\|Message\\|Mail\\|Group\\|Score\\|Summary\\|Article" 1783 . "Mail/News") 1784 ("\\<C\\>" . "C") 1785 ("ObjC" . "C") 1786 ("Text" . "Text") 1787 ("Outline" . "Text") 1788 ("\\(HT\\|SG\\|X\\|XHT\\)ML" . "SGML") 1789 ("log\\|diff\\|vc\\|cvs" . "Version Control") ; "Change Management"? 1790 ("Lisp" . "Lisp")) 1791 "How to group various major modes together in \\[mouse-buffer-menu]. 1792Each element has the form (REGEXP . GROUPNAME). 1793If the major mode's name string matches REGEXP, use GROUPNAME instead.") 1794 1795(defun mouse-buffer-menu (event) 1796 "Pop up a menu of buffers for selection with the mouse. 1797This switches buffers in the window that you clicked on, 1798and selects that window." 1799 (interactive "e") 1800 (mouse-minibuffer-check event) 1801 (let ((buffers (buffer-list)) alist menu split-by-major-mode sum-of-squares) 1802 ;; Make an alist of elements that look like (MENU-ITEM . BUFFER). 1803 (let ((tail buffers)) 1804 (while tail 1805 ;; Divide all buffers into buckets for various major modes. 1806 ;; Each bucket looks like (MODE NAMESTRING BUFFERS...). 1807 (with-current-buffer (car tail) 1808 (let* ((adjusted-major-mode major-mode) elt) 1809 (let ((tail mouse-buffer-menu-mode-groups)) 1810 (while tail 1811 (if (string-match (car (car tail)) mode-name) 1812 (setq adjusted-major-mode (cdr (car tail)))) 1813 (setq tail (cdr tail)))) 1814 (setq elt (assoc adjusted-major-mode split-by-major-mode)) 1815 (if (null elt) 1816 (setq elt (list adjusted-major-mode 1817 (if (stringp adjusted-major-mode) 1818 adjusted-major-mode 1819 mode-name)) 1820 split-by-major-mode (cons elt split-by-major-mode))) 1821 (or (memq (car tail) (cdr (cdr elt))) 1822 (setcdr (cdr elt) (cons (car tail) (cdr (cdr elt))))))) 1823 (setq tail (cdr tail)))) 1824 ;; Compute the sum of squares of sizes of the major-mode buckets. 1825 (let ((tail split-by-major-mode)) 1826 (setq sum-of-squares 0) 1827 (while tail 1828 (setq sum-of-squares 1829 (+ sum-of-squares 1830 (let ((len (length (cdr (cdr (car tail)))))) (* len len)))) 1831 (setq tail (cdr tail)))) 1832 (if (< (* sum-of-squares mouse-buffer-menu-mode-mult) 1833 (* (length buffers) (length buffers))) 1834 ;; Subdividing by major modes really helps, so let's do it. 1835 (let (subdivided-menus (buffers-left (length buffers))) 1836 ;; Sort the list to put the most popular major modes first. 1837 (setq split-by-major-mode 1838 (sort split-by-major-mode 1839 (function (lambda (elt1 elt2) 1840 (> (length elt1) (length elt2)))))) 1841 ;; Make a separate submenu for each major mode 1842 ;; that has more than one buffer, 1843 ;; unless all the remaining buffers are less than 1/10 of them. 1844 (while (and split-by-major-mode 1845 (and (> (length (car split-by-major-mode)) 3) 1846 (> (* buffers-left 10) (length buffers)))) 1847 (let ((this-mode-list (mouse-buffer-menu-alist 1848 (cdr (cdr (car split-by-major-mode)))))) 1849 (and this-mode-list 1850 (setq subdivided-menus 1851 (cons (cons 1852 (nth 1 (car split-by-major-mode)) 1853 this-mode-list) 1854 subdivided-menus)))) 1855 (setq buffers-left 1856 (- buffers-left (length (cdr (car split-by-major-mode))))) 1857 (setq split-by-major-mode (cdr split-by-major-mode))) 1858 ;; If any major modes are left over, 1859 ;; make a single submenu for them. 1860 (if split-by-major-mode 1861 (let ((others-list 1862 (mouse-buffer-menu-alist 1863 ;; we don't need split-by-major-mode any more, 1864 ;; so we can ditch it with nconc. 1865 (apply 'nconc (mapcar 'cddr split-by-major-mode))))) 1866 (and others-list 1867 (setq subdivided-menus 1868 (cons (cons "Others" others-list) 1869 subdivided-menus))))) 1870 (setq menu (cons "Buffer Menu" (nreverse subdivided-menus)))) 1871 (progn 1872 (setq alist (mouse-buffer-menu-alist buffers)) 1873 (setq menu (cons "Buffer Menu" 1874 (mouse-buffer-menu-split "Select Buffer" alist))))) 1875 (let ((buf (x-popup-menu event menu)) 1876 (window (posn-window (event-start event)))) 1877 (when buf 1878 (select-window 1879 (if (framep window) (frame-selected-window window) 1880 window)) 1881 (switch-to-buffer buf))))) 1882 1883(defun mouse-buffer-menu-alist (buffers) 1884 (let (tail 1885 (maxlen 0) 1886 head) 1887 (setq buffers 1888 (sort buffers 1889 (function (lambda (elt1 elt2) 1890 (string< (buffer-name elt1) (buffer-name elt2)))))) 1891 (setq tail buffers) 1892 (while tail 1893 (or (eq ?\s (aref (buffer-name (car tail)) 0)) 1894 (setq maxlen 1895 (max maxlen 1896 (length (buffer-name (car tail)))))) 1897 (setq tail (cdr tail))) 1898 (setq tail buffers) 1899 (while tail 1900 (let ((elt (car tail))) 1901 (if (/= (aref (buffer-name elt) 0) ?\s) 1902 (setq head 1903 (cons 1904 (cons 1905 (format 1906 (format "%%%ds %%s%%s %%s" maxlen) 1907 (buffer-name elt) 1908 (if (buffer-modified-p elt) "*" " ") 1909 (save-excursion 1910 (set-buffer elt) 1911 (if buffer-read-only "%" " ")) 1912 (or (buffer-file-name elt) 1913 (save-excursion 1914 (set-buffer elt) 1915 (if list-buffers-directory 1916 (expand-file-name 1917 list-buffers-directory))) 1918 "")) 1919 elt) 1920 head)))) 1921 (setq tail (cdr tail))) 1922 ;; Compensate for the reversal that the above loop does. 1923 (nreverse head))) 1924 1925(defun mouse-buffer-menu-split (title alist) 1926 ;; If we have lots of buffers, divide them into groups of 20 1927 ;; and make a pane (or submenu) for each one. 1928 (if (> (length alist) (/ (* mouse-buffer-menu-maxlen 3) 2)) 1929 (let ((alist alist) sublists next 1930 (i 1)) 1931 (while alist 1932 ;; Pull off the next mouse-buffer-menu-maxlen buffers 1933 ;; and make them the next element of sublist. 1934 (setq next (nthcdr mouse-buffer-menu-maxlen alist)) 1935 (if next 1936 (setcdr (nthcdr (1- mouse-buffer-menu-maxlen) alist) 1937 nil)) 1938 (setq sublists (cons (cons (format "Buffers %d" i) alist) 1939 sublists)) 1940 (setq i (1+ i)) 1941 (setq alist next)) 1942 (nreverse sublists)) 1943 ;; Few buffers--put them all in one pane. 1944 (list (cons title alist)))) 1945 1946;;; These need to be rewritten for the new scroll bar implementation. 1947 1948;;;!! ;; Commands for the scroll bar. 1949;;;!! 1950;;;!! (defun mouse-scroll-down (click) 1951;;;!! (interactive "@e") 1952;;;!! (scroll-down (1+ (cdr (mouse-coords click))))) 1953;;;!! 1954;;;!! (defun mouse-scroll-up (click) 1955;;;!! (interactive "@e") 1956;;;!! (scroll-up (1+ (cdr (mouse-coords click))))) 1957;;;!! 1958;;;!! (defun mouse-scroll-down-full () 1959;;;!! (interactive "@") 1960;;;!! (scroll-down nil)) 1961;;;!! 1962;;;!! (defun mouse-scroll-up-full () 1963;;;!! (interactive "@") 1964;;;!! (scroll-up nil)) 1965;;;!! 1966;;;!! (defun mouse-scroll-move-cursor (click) 1967;;;!! (interactive "@e") 1968;;;!! (move-to-window-line (1+ (cdr (mouse-coords click))))) 1969;;;!! 1970;;;!! (defun mouse-scroll-absolute (event) 1971;;;!! (interactive "@e") 1972;;;!! (let* ((pos (car event)) 1973;;;!! (position (car pos)) 1974;;;!! (length (car (cdr pos)))) 1975;;;!! (if (<= length 0) (setq length 1)) 1976;;;!! (let* ((scale-factor (max 1 (/ length (/ 8000000 (buffer-size))))) 1977;;;!! (newpos (* (/ (* (/ (buffer-size) scale-factor) 1978;;;!! position) 1979;;;!! length) 1980;;;!! scale-factor))) 1981;;;!! (goto-char newpos) 1982;;;!! (recenter '(4))))) 1983;;;!! 1984;;;!! (defun mouse-scroll-left (click) 1985;;;!! (interactive "@e") 1986;;;!! (scroll-left (1+ (car (mouse-coords click))))) 1987;;;!! 1988;;;!! (defun mouse-scroll-right (click) 1989;;;!! (interactive "@e") 1990;;;!! (scroll-right (1+ (car (mouse-coords click))))) 1991;;;!! 1992;;;!! (defun mouse-scroll-left-full () 1993;;;!! (interactive "@") 1994;;;!! (scroll-left nil)) 1995;;;!! 1996;;;!! (defun mouse-scroll-right-full () 1997;;;!! (interactive "@") 1998;;;!! (scroll-right nil)) 1999;;;!! 2000;;;!! (defun mouse-scroll-move-cursor-horizontally (click) 2001;;;!! (interactive "@e") 2002;;;!! (move-to-column (1+ (car (mouse-coords click))))) 2003;;;!! 2004;;;!! (defun mouse-scroll-absolute-horizontally (event) 2005;;;!! (interactive "@e") 2006;;;!! (let* ((pos (car event)) 2007;;;!! (position (car pos)) 2008;;;!! (length (car (cdr pos)))) 2009;;;!! (set-window-hscroll (selected-window) 33))) 2010;;;!! 2011;;;!! (global-set-key [scroll-bar mouse-1] 'mouse-scroll-up) 2012;;;!! (global-set-key [scroll-bar mouse-2] 'mouse-scroll-absolute) 2013;;;!! (global-set-key [scroll-bar mouse-3] 'mouse-scroll-down) 2014;;;!! 2015;;;!! (global-set-key [vertical-slider mouse-1] 'mouse-scroll-move-cursor) 2016;;;!! (global-set-key [vertical-slider mouse-2] 'mouse-scroll-move-cursor) 2017;;;!! (global-set-key [vertical-slider mouse-3] 'mouse-scroll-move-cursor) 2018;;;!! 2019;;;!! (global-set-key [thumbup mouse-1] 'mouse-scroll-up-full) 2020;;;!! (global-set-key [thumbup mouse-2] 'mouse-scroll-up-full) 2021;;;!! (global-set-key [thumbup mouse-3] 'mouse-scroll-up-full) 2022;;;!! 2023;;;!! (global-set-key [thumbdown mouse-1] 'mouse-scroll-down-full) 2024;;;!! (global-set-key [thumbdown mouse-2] 'mouse-scroll-down-full) 2025;;;!! (global-set-key [thumbdown mouse-3] 'mouse-scroll-down-full) 2026;;;!! 2027;;;!! (global-set-key [horizontal-scroll-bar mouse-1] 'mouse-scroll-left) 2028;;;!! (global-set-key [horizontal-scroll-bar mouse-2] 2029;;;!! 'mouse-scroll-absolute-horizontally) 2030;;;!! (global-set-key [horizontal-scroll-bar mouse-3] 'mouse-scroll-right) 2031;;;!! 2032;;;!! (global-set-key [horizontal-slider mouse-1] 2033;;;!! 'mouse-scroll-move-cursor-horizontally) 2034;;;!! (global-set-key [horizontal-slider mouse-2] 2035;;;!! 'mouse-scroll-move-cursor-horizontally) 2036;;;!! (global-set-key [horizontal-slider mouse-3] 2037;;;!! 'mouse-scroll-move-cursor-horizontally) 2038;;;!! 2039;;;!! (global-set-key [thumbleft mouse-1] 'mouse-scroll-left-full) 2040;;;!! (global-set-key [thumbleft mouse-2] 'mouse-scroll-left-full) 2041;;;!! (global-set-key [thumbleft mouse-3] 'mouse-scroll-left-full) 2042;;;!! 2043;;;!! (global-set-key [thumbright mouse-1] 'mouse-scroll-right-full) 2044;;;!! (global-set-key [thumbright mouse-2] 'mouse-scroll-right-full) 2045;;;!! (global-set-key [thumbright mouse-3] 'mouse-scroll-right-full) 2046;;;!! 2047;;;!! (global-set-key [horizontal-scroll-bar S-mouse-2] 2048;;;!! 'mouse-split-window-horizontally) 2049;;;!! (global-set-key [mode-line S-mouse-2] 2050;;;!! 'mouse-split-window-horizontally) 2051;;;!! (global-set-key [vertical-scroll-bar S-mouse-2] 2052;;;!! 'mouse-split-window) 2053 2054;;;!! ;;;; 2055;;;!! ;;;; Here are experimental things being tested. Mouse events 2056;;;!! ;;;; are of the form: 2057;;;!! ;;;; ((x y) window screen-part key-sequence timestamp) 2058;;;!! ;; 2059;;;!! ;;;; 2060;;;!! ;;;; Dynamically track mouse coordinates 2061;;;!! ;;;; 2062;;;!! ;; 2063;;;!! ;;(defun track-mouse (event) 2064;;;!! ;; "Track the coordinates, absolute and relative, of the mouse." 2065;;;!! ;; (interactive "@e") 2066;;;!! ;; (while mouse-grabbed 2067;;;!! ;; (let* ((pos (read-mouse-position (selected-screen))) 2068;;;!! ;; (abs-x (car pos)) 2069;;;!! ;; (abs-y (cdr pos)) 2070;;;!! ;; (relative-coordinate (coordinates-in-window-p 2071;;;!! ;; (list (car pos) (cdr pos)) 2072;;;!! ;; (selected-window)))) 2073;;;!! ;; (if (consp relative-coordinate) 2074;;;!! ;; (message "mouse: [%d %d], (%d %d)" abs-x abs-y 2075;;;!! ;; (car relative-coordinate) 2076;;;!! ;; (car (cdr relative-coordinate))) 2077;;;!! ;; (message "mouse: [%d %d]" abs-x abs-y))))) 2078;;;!! 2079;;;!! ;; 2080;;;!! ;; Dynamically put a box around the line indicated by point 2081;;;!! ;; 2082;;;!! ;; 2083;;;!! ;;(require 'backquote) 2084;;;!! ;; 2085;;;!! ;;(defun mouse-select-buffer-line (event) 2086;;;!! ;; (interactive "@e") 2087;;;!! ;; (let ((relative-coordinate 2088;;;!! ;; (coordinates-in-window-p (car event) (selected-window))) 2089;;;!! ;; (abs-y (car (cdr (car event))))) 2090;;;!! ;; (if (consp relative-coordinate) 2091;;;!! ;; (progn 2092;;;!! ;; (save-excursion 2093;;;!! ;; (move-to-window-line (car (cdr relative-coordinate))) 2094;;;!! ;; (x-draw-rectangle 2095;;;!! ;; (selected-screen) 2096;;;!! ;; abs-y 0 2097;;;!! ;; (save-excursion 2098;;;!! ;; (move-to-window-line (car (cdr relative-coordinate))) 2099;;;!! ;; (end-of-line) 2100;;;!! ;; (push-mark nil t) 2101;;;!! ;; (beginning-of-line) 2102;;;!! ;; (- (region-end) (region-beginning))) 1)) 2103;;;!! ;; (sit-for 1) 2104;;;!! ;; (x-erase-rectangle (selected-screen)))))) 2105;;;!! ;; 2106;;;!! ;;(defvar last-line-drawn nil) 2107;;;!! ;;(defvar begin-delim "[^ \t]") 2108;;;!! ;;(defvar end-delim "[^ \t]") 2109;;;!! ;; 2110;;;!! ;;(defun mouse-boxing (event) 2111;;;!! ;; (interactive "@e") 2112;;;!! ;; (save-excursion 2113;;;!! ;; (let ((screen (selected-screen))) 2114;;;!! ;; (while (= (x-mouse-events) 0) 2115;;;!! ;; (let* ((pos (read-mouse-position screen)) 2116;;;!! ;; (abs-x (car pos)) 2117;;;!! ;; (abs-y (cdr pos)) 2118;;;!! ;; (relative-coordinate 2119;;;!! ;; (coordinates-in-window-p `(,abs-x ,abs-y) 2120;;;!! ;; (selected-window))) 2121;;;!! ;; (begin-reg nil) 2122;;;!! ;; (end-reg nil) 2123;;;!! ;; (end-column nil) 2124;;;!! ;; (begin-column nil)) 2125;;;!! ;; (if (and (consp relative-coordinate) 2126;;;!! ;; (or (not last-line-drawn) 2127;;;!! ;; (not (= last-line-drawn abs-y)))) 2128;;;!! ;; (progn 2129;;;!! ;; (move-to-window-line (car (cdr relative-coordinate))) 2130;;;!! ;; (if (= (following-char) 10) 2131;;;!! ;; () 2132;;;!! ;; (progn 2133;;;!! ;; (setq begin-reg (1- (re-search-forward end-delim))) 2134;;;!! ;; (setq begin-column (1- (current-column))) 2135;;;!! ;; (end-of-line) 2136;;;!! ;; (setq end-reg (1+ (re-search-backward begin-delim))) 2137;;;!! ;; (setq end-column (1+ (current-column))) 2138;;;!! ;; (message "%s" (buffer-substring begin-reg end-reg)) 2139;;;!! ;; (x-draw-rectangle screen 2140;;;!! ;; (setq last-line-drawn abs-y) 2141;;;!! ;; begin-column 2142;;;!! ;; (- end-column begin-column) 1)))))))))) 2143;;;!! ;; 2144;;;!! ;;(defun mouse-erase-box () 2145;;;!! ;; (interactive) 2146;;;!! ;; (if last-line-drawn 2147;;;!! ;; (progn 2148;;;!! ;; (x-erase-rectangle (selected-screen)) 2149;;;!! ;; (setq last-line-drawn nil)))) 2150;;;!! 2151;;;!! ;;; (defun test-x-rectangle () 2152;;;!! ;;; (use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap))) 2153;;;!! ;;; (define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing) 2154;;;!! ;;; (define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box)) 2155;;;!! 2156;;;!! ;; 2157;;;!! ;; Here is how to do double clicking in lisp. About to change. 2158;;;!! ;; 2159;;;!! 2160;;;!! (defvar double-start nil) 2161;;;!! (defconst double-click-interval 300 2162;;;!! "Max ticks between clicks") 2163;;;!! 2164;;;!! (defun double-down (event) 2165;;;!! (interactive "@e") 2166;;;!! (if double-start 2167;;;!! (let ((interval (- (nth 4 event) double-start))) 2168;;;!! (if (< interval double-click-interval) 2169;;;!! (progn 2170;;;!! (backward-up-list 1) 2171;;;!! ;; (message "Interval %d" interval) 2172;;;!! (sleep-for 1))) 2173;;;!! (setq double-start nil)) 2174;;;!! (setq double-start (nth 4 event)))) 2175;;;!! 2176;;;!! (defun double-up (event) 2177;;;!! (interactive "@e") 2178;;;!! (and double-start 2179;;;!! (> (- (nth 4 event ) double-start) double-click-interval) 2180;;;!! (setq double-start nil))) 2181;;;!! 2182;;;!! ;;; (defun x-test-doubleclick () 2183;;;!! ;;; (use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap))) 2184;;;!! ;;; (define-key doubleclick-test-map mouse-button-left 'double-down) 2185;;;!! ;;; (define-key doubleclick-test-map mouse-button-left-up 'double-up)) 2186;;;!! 2187;;;!! ;; 2188;;;!! ;; This scrolls while button is depressed. Use preferable in scroll bar. 2189;;;!! ;; 2190;;;!! 2191;;;!! (defvar scrolled-lines 0) 2192;;;!! (defconst scroll-speed 1) 2193;;;!! 2194;;;!! (defun incr-scroll-down (event) 2195;;;!! (interactive "@e") 2196;;;!! (setq scrolled-lines 0) 2197;;;!! (incremental-scroll scroll-speed)) 2198;;;!! 2199;;;!! (defun incr-scroll-up (event) 2200;;;!! (interactive "@e") 2201;;;!! (setq scrolled-lines 0) 2202;;;!! (incremental-scroll (- scroll-speed))) 2203;;;!! 2204;;;!! (defun incremental-scroll (n) 2205;;;!! (while (= (x-mouse-events) 0) 2206;;;!! (setq scrolled-lines (1+ (* scroll-speed scrolled-lines))) 2207;;;!! (scroll-down n) 2208;;;!! (sit-for 300 t))) 2209;;;!! 2210;;;!! (defun incr-scroll-stop (event) 2211;;;!! (interactive "@e") 2212;;;!! (message "Scrolled %d lines" scrolled-lines) 2213;;;!! (setq scrolled-lines 0) 2214;;;!! (sleep-for 1)) 2215;;;!! 2216;;;!! ;;; (defun x-testing-scroll () 2217;;;!! ;;; (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix))) 2218;;;!! ;;; (define-key scrolling-map mouse-button-left 'incr-scroll-down) 2219;;;!! ;;; (define-key scrolling-map mouse-button-right 'incr-scroll-up) 2220;;;!! ;;; (define-key scrolling-map mouse-button-left-up 'incr-scroll-stop) 2221;;;!! ;;; (define-key scrolling-map mouse-button-right-up 'incr-scroll-stop))) 2222;;;!! 2223;;;!! ;; 2224;;;!! ;; Some playthings suitable for picture mode? They need work. 2225;;;!! ;; 2226;;;!! 2227;;;!! (defun mouse-kill-rectangle (event) 2228;;;!! "Kill the rectangle between point and the mouse cursor." 2229;;;!! (interactive "@e") 2230;;;!! (let ((point-save (point))) 2231;;;!! (save-excursion 2232;;;!! (mouse-set-point event) 2233;;;!! (push-mark nil t) 2234;;;!! (if (> point-save (point)) 2235;;;!! (kill-rectangle (point) point-save) 2236;;;!! (kill-rectangle point-save (point)))))) 2237;;;!! 2238;;;!! (defun mouse-open-rectangle (event) 2239;;;!! "Kill the rectangle between point and the mouse cursor." 2240;;;!! (interactive "@e") 2241;;;!! (let ((point-save (point))) 2242;;;!! (save-excursion 2243;;;!! (mouse-set-point event) 2244;;;!! (push-mark nil t) 2245;;;!! (if (> point-save (point)) 2246;;;!! (open-rectangle (point) point-save) 2247;;;!! (open-rectangle point-save (point)))))) 2248;;;!! 2249;;;!! ;; Must be a better way to do this. 2250;;;!! 2251;;;!! (defun mouse-multiple-insert (n char) 2252;;;!! (while (> n 0) 2253;;;!! (insert char) 2254;;;!! (setq n (1- n)))) 2255;;;!! 2256;;;!! ;; What this could do is not finalize until button was released. 2257;;;!! 2258;;;!! (defun mouse-move-text (event) 2259;;;!! "Move text from point to cursor position, inserting spaces." 2260;;;!! (interactive "@e") 2261;;;!! (let* ((relative-coordinate 2262;;;!! (coordinates-in-window-p (car event) (selected-window)))) 2263;;;!! (if (consp relative-coordinate) 2264;;;!! (cond ((> (current-column) (car relative-coordinate)) 2265;;;!! (delete-char 2266;;;!! (- (car relative-coordinate) (current-column)))) 2267;;;!! ((< (current-column) (car relative-coordinate)) 2268;;;!! (mouse-multiple-insert 2269;;;!! (- (car relative-coordinate) (current-column)) " ")) 2270;;;!! ((= (current-column) (car relative-coordinate)) (ding)))))) 2271 2272;; Choose a completion with the mouse. 2273 2274(defun mouse-choose-completion (event) 2275 "Click on an alternative in the `*Completions*' buffer to choose it." 2276 (interactive "e") 2277 ;; Give temporary modes such as isearch a chance to turn off. 2278 (run-hooks 'mouse-leave-buffer-hook) 2279 (let ((buffer (window-buffer)) 2280 choice 2281 base-size) 2282 (save-excursion 2283 (set-buffer (window-buffer (posn-window (event-start event)))) 2284 (if completion-reference-buffer 2285 (setq buffer completion-reference-buffer)) 2286 (setq base-size completion-base-size) 2287 (save-excursion 2288 (goto-char (posn-point (event-start event))) 2289 (let (beg end) 2290 (if (and (not (eobp)) (get-text-property (point) 'mouse-face)) 2291 (setq end (point) beg (1+ (point)))) 2292 (if (null beg) 2293 (error "No completion here")) 2294 (setq beg (previous-single-property-change beg 'mouse-face)) 2295 (setq end (or (next-single-property-change end 'mouse-face) 2296 (point-max))) 2297 (setq choice (buffer-substring-no-properties beg end))))) 2298 (let ((owindow (selected-window))) 2299 (select-window (posn-window (event-start event))) 2300 (if (and (one-window-p t 'selected-frame) 2301 (window-dedicated-p (selected-window))) 2302 ;; This is a special buffer's frame 2303 (iconify-frame (selected-frame)) 2304 (or (window-dedicated-p (selected-window)) 2305 (bury-buffer))) 2306 (select-window owindow)) 2307 (choose-completion-string choice buffer base-size))) 2308 2309;; Font selection. 2310 2311(defun font-menu-add-default () 2312 (let* ((default (cdr (assq 'font (frame-parameters (selected-frame))))) 2313 (font-alist x-fixed-font-alist) 2314 (elt (or (assoc "Misc" font-alist) (nth 1 font-alist)))) 2315 (if (assoc "Default" elt) 2316 (delete (assoc "Default" elt) elt)) 2317 (setcdr elt 2318 (cons (list "Default" default) 2319 (cdr elt))))) 2320 2321(defvar x-fixed-font-alist 2322 '("Font menu" 2323 ("Misc" 2324 ;; For these, we specify the pixel height and width. 2325 ("fixed" "fixed") 2326 ("6x10" "-misc-fixed-medium-r-normal--10-*-*-*-c-60-iso8859-1" "6x10") 2327 ("6x12" 2328 "-misc-fixed-medium-r-semicondensed--12-*-*-*-c-60-iso8859-1" "6x12") 2329 ("6x13" 2330 "-misc-fixed-medium-r-semicondensed--13-*-*-*-c-60-iso8859-1" "6x13") 2331 ("7x13" "-misc-fixed-medium-r-normal--13-*-*-*-c-70-iso8859-1" "7x13") 2332 ("7x14" "-misc-fixed-medium-r-normal--14-*-*-*-c-70-iso8859-1" "7x14") 2333 ("8x13" "-misc-fixed-medium-r-normal--13-*-*-*-c-80-iso8859-1" "8x13") 2334 ("9x15" "-misc-fixed-medium-r-normal--15-*-*-*-c-90-iso8859-1" "9x15") 2335 ("10x20" "-misc-fixed-medium-r-normal--20-*-*-*-c-100-iso8859-1" "10x20") 2336 ("11x18" "-misc-fixed-medium-r-normal--18-*-*-*-c-110-iso8859-1" "11x18") 2337 ("12x24" "-misc-fixed-medium-r-normal--24-*-*-*-c-120-iso8859-1" "12x24") 2338 ("") 2339 ("clean 5x8" 2340 "-schumacher-clean-medium-r-normal--8-*-*-*-c-50-iso8859-1") 2341 ("clean 6x8" 2342 "-schumacher-clean-medium-r-normal--8-*-*-*-c-60-iso8859-1") 2343 ("clean 8x8" 2344 "-schumacher-clean-medium-r-normal--8-*-*-*-c-80-iso8859-1") 2345 ("clean 8x10" 2346 "-schumacher-clean-medium-r-normal--10-*-*-*-c-80-iso8859-1") 2347 ("clean 8x14" 2348 "-schumacher-clean-medium-r-normal--14-*-*-*-c-80-iso8859-1") 2349 ("clean 8x16" 2350 "-schumacher-clean-medium-r-normal--16-*-*-*-c-80-iso8859-1") 2351 ("") 2352 ("sony 8x16" "-sony-fixed-medium-r-normal--16-*-*-*-c-80-iso8859-1") 2353;;; We don't seem to have these; who knows what they are. 2354;;; ("fg-18" "fg-18") 2355;;; ("fg-25" "fg-25") 2356 ("lucidasanstypewriter-12" "-b&h-lucidatypewriter-medium-r-normal-sans-*-120-*-*-*-*-iso8859-1") 2357 ("lucidasanstypewriter-bold-14" "-b&h-lucidatypewriter-bold-r-normal-sans-*-140-*-*-*-*-iso8859-1") 2358 ("lucidasanstypewriter-bold-24" 2359 "-b&h-lucidatypewriter-bold-r-normal-sans-*-240-*-*-*-*-iso8859-1") 2360;;; ("lucidatypewriter-bold-r-24" "-b&h-lucidatypewriter-bold-r-normal-sans-24-240-75-75-m-140-iso8859-1") 2361;;; ("fixed-medium-20" "-misc-fixed-medium-*-*-*-20-*-*-*-*-*-*-*") 2362 ) 2363 ("Courier" 2364 ;; For these, we specify the point height. 2365 ("8" "-adobe-courier-medium-r-normal--*-80-*-*-m-*-iso8859-1") 2366 ("10" "-adobe-courier-medium-r-normal--*-100-*-*-m-*-iso8859-1") 2367 ("12" "-adobe-courier-medium-r-normal--*-120-*-*-m-*-iso8859-1") 2368 ("14" "-adobe-courier-medium-r-normal--*-140-*-*-m-*-iso8859-1") 2369 ("18" "-adobe-courier-medium-r-normal--*-180-*-*-m-*-iso8859-1") 2370 ("24" "-adobe-courier-medium-r-normal--*-240-*-*-m-*-iso8859-1") 2371 ("8 bold" "-adobe-courier-bold-r-normal--*-80-*-*-m-*-iso8859-1") 2372 ("10 bold" "-adobe-courier-bold-r-normal--*-100-*-*-m-*-iso8859-1") 2373 ("12 bold" "-adobe-courier-bold-r-normal--*-120-*-*-m-*-iso8859-1") 2374 ("14 bold" "-adobe-courier-bold-r-normal--*-140-*-*-m-*-iso8859-1") 2375 ("18 bold" "-adobe-courier-bold-r-normal--*-180-*-*-m-*-iso8859-1") 2376 ("24 bold" "-adobe-courier-bold-r-normal--*-240-*-*-m-*-iso8859-1") 2377 ("8 slant" "-adobe-courier-medium-o-normal--*-80-*-*-m-*-iso8859-1") 2378 ("10 slant" "-adobe-courier-medium-o-normal--*-100-*-*-m-*-iso8859-1") 2379 ("12 slant" "-adobe-courier-medium-o-normal--*-120-*-*-m-*-iso8859-1") 2380 ("14 slant" "-adobe-courier-medium-o-normal--*-140-*-*-m-*-iso8859-1") 2381 ("18 slant" "-adobe-courier-medium-o-normal--*-180-*-*-m-*-iso8859-1") 2382 ("24 slant" "-adobe-courier-medium-o-normal--*-240-*-*-m-*-iso8859-1") 2383 ("8 bold slant" "-adobe-courier-bold-o-normal--*-80-*-*-m-*-iso8859-1") 2384 ("10 bold slant" "-adobe-courier-bold-o-normal--*-100-*-*-m-*-iso8859-1") 2385 ("12 bold slant" "-adobe-courier-bold-o-normal--*-120-*-*-m-*-iso8859-1") 2386 ("14 bold slant" "-adobe-courier-bold-o-normal--*-140-*-*-m-*-iso8859-1") 2387 ("18 bold slant" "-adobe-courier-bold-o-normal--*-180-*-*-m-*-iso8859-1") 2388 ("24 bold slant" "-adobe-courier-bold-o-normal--*-240-*-*-m-*-iso8859-1")) 2389 ) 2390 "X fonts suitable for use in Emacs.") 2391 2392(defun mouse-set-font (&rest fonts) 2393 "Select an Emacs font from a list of known good fonts and fontsets." 2394 (interactive 2395 (progn (unless (display-multi-font-p) 2396 (error "Cannot change fonts on this display")) 2397 (x-popup-menu 2398 (if (listp last-nonmenu-event) 2399 last-nonmenu-event 2400 (list '(0 0) (selected-window))) 2401 ;; Append list of fontsets currently defined. 2402 (append x-fixed-font-alist (list (generate-fontset-menu)))))) 2403 (if fonts 2404 (let (font) 2405 (while fonts 2406 (condition-case nil 2407 (progn 2408 (set-default-font (car fonts)) 2409 (setq font (car fonts)) 2410 (setq fonts nil)) 2411 (error 2412 (setq fonts (cdr fonts))))) 2413 (if (null font) 2414 (error "Font not found"))))) 2415 2416;;; Bindings for mouse commands. 2417 2418(define-key global-map [down-mouse-1] 'mouse-drag-region) 2419(global-set-key [mouse-1] 'mouse-set-point) 2420(global-set-key [drag-mouse-1] 'mouse-set-region) 2421 2422;; These are tested for in mouse-drag-region. 2423(global-set-key [double-mouse-1] 'mouse-set-point) 2424(global-set-key [triple-mouse-1] 'mouse-set-point) 2425 2426;; Clicking on the fringes causes hscrolling: 2427(global-set-key [left-fringe mouse-1] 'mouse-set-point) 2428(global-set-key [right-fringe mouse-1] 'mouse-set-point) 2429 2430(global-set-key [mouse-2] 'mouse-yank-at-click) 2431;; Allow yanking also when the corresponding cursor is "in the fringe". 2432(global-set-key [right-fringe mouse-2] 'mouse-yank-at-click) 2433(global-set-key [left-fringe mouse-2] 'mouse-yank-at-click) 2434(global-set-key [mouse-3] 'mouse-save-then-kill) 2435(global-set-key [right-fringe mouse-3] 'mouse-save-then-kill) 2436(global-set-key [left-fringe mouse-3] 'mouse-save-then-kill) 2437 2438;; By binding these to down-going events, we let the user use the up-going 2439;; event to make the selection, saving a click. 2440(global-set-key [C-down-mouse-1] 'mouse-buffer-menu) 2441(if (not (eq system-type 'ms-dos)) 2442 (global-set-key [S-down-mouse-1] 'mouse-set-font)) 2443;; C-down-mouse-2 is bound in facemenu.el. 2444(global-set-key [C-down-mouse-3] 'mouse-popup-menubar-stuff) 2445 2446 2447;; Replaced with dragging mouse-1 2448;; (global-set-key [S-mouse-1] 'mouse-set-mark) 2449 2450;; Binding mouse-1 to mouse-select-window when on mode-, header-, or 2451;; vertical-line prevents Emacs from signaling an error when the mouse 2452;; button is released after dragging these lines, on non-toolkit 2453;; versions. 2454(global-set-key [mode-line mouse-1] 'mouse-select-window) 2455(global-set-key [mode-line drag-mouse-1] 'mouse-select-window) 2456(global-set-key [mode-line down-mouse-1] 'mouse-drag-mode-line) 2457(global-set-key [header-line down-mouse-1] 'mouse-drag-header-line) 2458(global-set-key [header-line mouse-1] 'mouse-select-window) 2459(global-set-key [mode-line mouse-2] 'mouse-delete-other-windows) 2460(global-set-key [mode-line mouse-3] 'mouse-delete-window) 2461(global-set-key [mode-line C-mouse-2] 'mouse-split-window-horizontally) 2462(global-set-key [vertical-scroll-bar C-mouse-2] 'mouse-split-window-vertically) 2463(global-set-key [vertical-line C-mouse-2] 'mouse-split-window-vertically) 2464(global-set-key [vertical-line down-mouse-1] 'mouse-drag-vertical-line) 2465(global-set-key [vertical-line mouse-1] 'mouse-select-window) 2466 2467(provide 'mouse) 2468 2469;; This file contains the functionality of the old mldrag.el. 2470(defalias 'mldrag-drag-mode-line 'mouse-drag-mode-line) 2471(defalias 'mldrag-drag-vertical-line 'mouse-drag-vertical-line) 2472(make-obsolete 'mldrag-drag-mode-line 'mouse-drag-mode-line "21.1") 2473(make-obsolete 'mldrag-drag-vertical-line 'mouse-drag-vertical-line "21.1") 2474(provide 'mldrag) 2475 2476;; arch-tag: 9a710ce1-914a-4923-9b81-697f7bf82ab3 2477;;; mouse.el ends here 2478