lisp/mouse.el

   1 ;;; mouse.el --- window system-independent mouse support.
   2
   3 ;;; Copyright (C) 1993, 1994, 1995 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: FSF
   6 ;; Keywords: hardware
   7
   8 ;;; This file is part of GNU Emacs.
   9
  10 ;;; GNU Emacs is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 2, or (at your option)
  13 ;;; any later version.
  14
  15 ;;; GNU Emacs is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with GNU Emacs; see the file COPYING.  If not, write to
  22 ;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  23
  24 ;;; Commentary:
  25
  26 ;; This package provides various useful commands (including help
  27 ;; system access) through the mouse.  All this code assumes that mouse
  28 ;; interpretation has been abstracted into Emacs input events.
  29 ;;
  30 ;; The code is rather X-dependent.
  31
  32 ;;; Code:
  33
  34 ;;; Utility functions.
  35
  36 ;;; Indent track-mouse like progn.
  37 (put 'track-mouse 'lisp-indent-function 0)
  38
  39 (defvar mouse-yank-at-point nil
  40   "*If non-nil, mouse yank commands yank at point instead of at click.")
  41 \f
  42 ;; Provide a mode-specific menu on a mouse button.
  43
  44 (defun mouse-major-mode-menu (event)
  45   "Pop up a mode-specific menu of mouse commands."
  46   ;; Switch to the window clicked on, because otherwise
  47   ;; the mode's commands may not make sense.
  48   (interactive "@e")
  49   (let ((newmap (make-sparse-keymap))
  50         (unread-command-events (list event)))
  51     ;; Make a keymap in which our last command leads to a menu
  52     (define-key newmap (vector (car event))
  53       (nconc (make-sparse-keymap "Menu")
  54              (mouse-major-mode-menu-1
  55               (and (current-local-map)
  56                    (lookup-key (current-local-map) [menu-bar])))))
  57     (mouse-major-mode-menu-compute-equiv-keys newmap)
  58     (command-execute
  59      ;; Make NEWMAP override the usual definition
  60      ;; of the mouse button that got us here.
  61      ;; Then read the user's menu choice.
  62      (let ((minor-mode-map-alist
  63             (cons (cons t newmap) minor-mode-map-alist)))
  64        (lookup-key newmap (read-key-sequence ""))))))
  65
  66 ;; Compute and cache the equivalent keys in MENU and all its submenus.
  67 (defun mouse-major-mode-menu-compute-equiv-keys (menu)
  68   (and (eq (car menu) 'keymap)
  69        (x-popup-menu nil menu))
  70   (while menu
  71     (and (consp (car menu))
  72          (consp (cdr (car menu)))
  73          (let ((tail (cdr (car menu))))
  74            (while (and (consp tail)
  75                        (not (eq (car tail) 'keymap)))
  76              (setq tail (cdr tail)))
  77            (if (consp tail)
  78                (mouse-major-mode-menu-compute-equiv-keys tail))))
  79     (setq menu (cdr menu))))
  80
  81 ;; Given a mode's menu bar keymap,
  82 ;; if it defines exactly one menu bar menu,
  83 ;; return just that menu.
  84 ;; Otherwise return a menu for all of them.
  85 (defun mouse-major-mode-menu-1 (menubar)
  86   (if menubar
  87       (let ((tail menubar)
  88             submap)
  89         (while tail
  90           (if (consp (car tail))
  91               (if submap
  92                   (setq submap t)
  93                 (setq submap (cdr (car tail)))))
  94           (setq tail (cdr tail)))
  95         (if (eq submap t) menubar
  96           submap))))
  97 \f
  98 ;; Commands that operate on windows.
  99
 100 (defun mouse-minibuffer-check (event)
 101   (let ((w (posn-window (event-start event))))
 102     (and (window-minibuffer-p w)
 103          (not (minibuffer-window-active-p w))
 104          (error "Minibuffer window is not active")))
 105   ;; Give temporary modes such as isearch a chance to turn off.
 106   (run-hooks 'mouse-leave-buffer-hook))
 107
 108 (defun mouse-delete-window (click)
 109   "Delete the window you click on.
 110 This must be bound to a mouse click."
 111   (interactive "e")
 112   (mouse-minibuffer-check click)
 113   (delete-window (posn-window (event-start click))))
 114
 115 (defun mouse-select-window (click)
 116   "Select the window clicked on; don't move point."
 117   (interactive "e")
 118   (mouse-minibuffer-check click)
 119   (let ((oframe (selected-frame))
 120         (frame (window-frame (posn-window (event-start click)))))
 121     (select-window (posn-window (event-start click)))
 122     (raise-frame frame)
 123     (select-frame frame)
 124     (or (eq frame oframe)
 125         (set-mouse-position (selected-frame) (1- (frame-width)) 0))
 126     (unfocus-frame)))
 127
 128 (defun mouse-tear-off-window (click)
 129   "Delete the window clicked on, and create a new frame displaying its buffer."
 130   (interactive "e")
 131   (mouse-minibuffer-check click)
 132   (let* ((window (posn-window (event-start click)))
 133          (buf (window-buffer window))
 134          (frame (make-frame)))
 135     (select-frame frame)
 136     (switch-to-buffer buf)
 137     (delete-window window)))
 138
 139 (defun mouse-delete-other-windows ()
 140   "Delete all window except the one you click on."
 141   (interactive "@")
 142   (delete-other-windows))
 143
 144 (defun mouse-split-window-vertically (click)
 145   "Select Emacs window mouse is on, then split it vertically in half.
 146 The window is split at the line clicked on.
 147 This command must be bound to a mouse click."
 148   (interactive "@e")
 149   (mouse-minibuffer-check click)
 150   (let ((start (event-start click)))
 151     (select-window (posn-window start))
 152     (let ((new-height (1+ (cdr (posn-col-row (event-end click)))))
 153           (first-line window-min-height)
 154           (last-line (- (window-height) window-min-height)))
 155       (if (< last-line first-line)
 156           (error "Window too short to split")
 157         (split-window-vertically
 158          (min (max new-height first-line) last-line))))))
 159
 160 (defun mouse-split-window-horizontally (click)
 161   "Select Emacs window mouse is on, then split it horizontally in half.
 162 The window is split at the column clicked on.
 163 This command must be bound to a mouse click."
 164   (interactive "@e")
 165   (mouse-minibuffer-check click)
 166   (let ((start (event-start click)))
 167     (select-window (posn-window start))
 168     (let ((new-width (1+ (car (posn-col-row (event-end click)))))
 169           (first-col window-min-width)
 170           (last-col (- (window-width) window-min-width)))
 171       (if (< last-col first-col)
 172           (error "Window too narrow to split")
 173         (split-window-horizontally
 174          (min (max new-width first-col) last-col))))))
 175
 176 (defun mouse-drag-mode-line (start-event)
 177   "Change the height of a window by dragging on the mode line."
 178   (interactive "e")
 179   ;; Give temporary modes such as isearch a chance to turn off.
 180   (run-hooks 'mouse-leave-buffer-hook)
 181   (let ((done nil)
 182         (echo-keystrokes 0)
 183         (start-event-frame (window-frame (car (car (cdr start-event)))))
 184         (start-event-window (car (car (cdr start-event))))
 185         (start-nwindows (count-windows t))
 186         (old-selected-window (selected-window))
 187         should-enlarge-minibuffer
 188         event mouse minibuffer y top bot edges wconfig params growth)
 189     (setq params (frame-parameters))
 190     (if (and (not (setq minibuffer (cdr (assq 'minibuffer params))))
 191              (one-window-p t))
 192         (error "Attempt to resize sole window"))
 193     (track-mouse
 194       (progn
 195         ;; enlarge-window only works on the selected window, so
 196         ;; we must select the window where the start event originated.
 197         ;; unwind-protect will restore the old selected window later.
 198         (select-window start-event-window)
 199         ;; if this is the bottommost ordinary window, then to
 200         ;; move its modeline the minibuffer must be enlarged.
 201         (setq should-enlarge-minibuffer
 202               (and minibuffer
 203                    (not (one-window-p t))
 204                    (= (nth 1 (window-edges minibuffer))
 205                       (nth 3 (window-edges)))))
 206         ;; loop reading events and sampling the position of
 207         ;; the mouse.
 208         (while (not done)
 209           (setq event (read-event)
 210                 mouse (mouse-position))
 211           ;; do nothing if
 212           ;;   - there is a switch-frame event.
 213           ;;   - the mouse isn't in the frame that we started in
 214           ;;   - the mouse isn't in any Emacs frame
 215           ;; drag if
 216           ;;   - there is a mouse-movement event
 217           ;;   - there is a scroll-bar-movement event
 218           ;;     (same as mouse movement for our purposes)
 219           ;; quit if
 220           ;;   - there is a keyboard event or some other unknown event
 221           ;;     unknown event.
 222           (cond ((integerp event)
 223                  (setq done t))
 224                 ((eq (car event) 'switch-frame)
 225                  nil)
 226                 ((not (memq (car event)
 227                             '(mouse-movement scroll-bar-movement)))
 228                  (if (consp event)
 229                      (setq unread-command-events
 230                            (cons event unread-command-events)))
 231                  (setq done t))
 232                 ((not (eq (car mouse) start-event-frame))
 233                  nil)
 234                 ((null (car (cdr mouse)))
 235                  nil)
 236                 (t
 237                  (setq y (cdr (cdr mouse))
 238                        edges (window-edges)
 239                        top (nth 1 edges)
 240                        bot (nth 3 edges))
 241                  ;; scale back a move that would make the
 242                  ;; window too short.
 243                  (cond ((< (- y top -1) window-min-height)
 244                         (setq y (+ top window-min-height -1))))
 245                  ;; compute size change needed
 246                  (setq growth (- y bot -1)
 247                        wconfig (current-window-configuration))
 248                  ;; grow/shrink minibuffer?
 249                  (if should-enlarge-minibuffer
 250                      (progn
 251                        ;; yes.  briefly select minibuffer so
 252                        ;; enlarge-window will affect the
 253                        ;; correct window.
 254                        (select-window minibuffer)
 255                        ;; scale back shrinkage if it would
 256                        ;; make the minibuffer less than 1
 257                        ;; line tall.
 258                        (if (and (> growth 0)
 259                                 (< (- (window-height minibuffer)
 260                                       growth)
 261                                    1))
 262                            (setq growth (1- (window-height minibuffer))))
 263                        (enlarge-window (- growth))
 264                        (select-window start-event-window))
 265                    ;; no.  grow/shrink the selected window
 266                    (enlarge-window growth))
 267                  ;; if this window's growth caused another
 268                  ;; window to be deleted because it was too
 269                  ;; short, rescind the change.
 270                  ;;
 271                  ;; if size change caused space to be stolen
 272                  ;; from a window above this one, rescind the
 273                  ;; change, but only if we didn't grow/srhink
 274                  ;; the minibuffer.  minibuffer size changes
 275                  ;; can cause all windows to shrink... no way
 276                  ;; around it.
 277                  (if (or (/= start-nwindows (count-windows t))
 278                          (and (not should-enlarge-minibuffer)
 279                               (/= top (nth 1 (window-edges)))))
 280                      (set-window-configuration wconfig)))))))))
 281 \f
 282 (defun mouse-set-point (event)
 283   "Move point to the position clicked on with the mouse.
 284 This should be bound to a mouse click event type."
 285   (interactive "e")
 286   (mouse-minibuffer-check event)
 287   ;; Use event-end in case called from mouse-drag-region.
 288   ;; If EVENT is a click, event-end and event-start give same value.
 289   (let ((posn (event-end event)))
 290     (if (not (windowp (posn-window posn)))
 291         (error "Cursor not in text area of window"))
 292     (select-window (posn-window posn))
 293     (if (numberp (posn-point posn))
 294         (goto-char (posn-point posn)))))
 295
 296 (defvar mouse-last-region-beg nil)
 297 (defvar mouse-last-region-end nil)
 298 (defvar mouse-last-region-tick nil)
 299
 300 (defun mouse-region-match ()
 301   "Return non-nil if there's an active region that was set with the mouse."
 302   (and (mark t) mark-active
 303        (eq mouse-last-region-beg (region-beginning))
 304        (eq mouse-last-region-end (region-end))
 305        (eq mouse-last-region-tick (buffer-modified-tick))))
 306
 307 (defun mouse-set-region (click)
 308   "Set the region to the text dragged over, and copy to kill ring.
 309 This should be bound to a mouse drag event."
 310   (interactive "e")
 311   (mouse-minibuffer-check click)
 312   (let ((posn (event-start click))
 313         (end (event-end click)))
 314     (select-window (posn-window posn))
 315     (if (numberp (posn-point posn))
 316         (goto-char (posn-point posn)))
 317     ;; If mark is highlighted, no need to bounce the cursor.
 318     (or (and transient-mark-mode
 319              (framep (selected-frame)))
 320         (sit-for 1))
 321     (push-mark)
 322     (set-mark (point))
 323     (if (numberp (posn-point end))
 324         (goto-char (posn-point end)))
 325     ;; Don't set this-command to kill-region, so that a following
 326     ;; C-w will not double the text in the kill ring.
 327     (let (this-command)
 328       (copy-region-as-kill (mark) (point)))
 329     (mouse-set-region-1)))
 330
 331 (defun mouse-set-region-1 ()
 332   (setq mouse-last-region-beg (region-beginning))
 333   (setq mouse-last-region-end (region-end))
 334   (setq mouse-last-region-tick (buffer-modified-tick)))
 335
 336 (defvar mouse-scroll-delay 0.25
 337   "*The pause between scroll steps caused by mouse drags, in seconds.
 338 If you drag the mouse beyond the edge of a window, Emacs scrolls the
 339 window to bring the text beyond that edge into view, with a delay of
 340 this many seconds between scroll steps.  Scrolling stops when you move
 341 the mouse back into the window, or release the button.
 342 This variable's value may be non-integral.
 343 Setting this to zero causes Emacs to scroll as fast as it can.")
 344
 345 (defun mouse-scroll-subr (window jump &optional overlay start)
 346   "Scroll the window WINDOW, JUMP lines at a time, until new input arrives.
 347 If OVERLAY is an overlay, let it stretch from START to the far edge of
 348 the newly visible text.
 349 Upon exit, point is at the far edge of the newly visible text."
 350   (let ((opoint (point)))
 351     (while (progn
 352              (goto-char (window-start window))
 353              (if (not (zerop (vertical-motion jump window)))
 354                  (progn
 355                    (set-window-start window (point))
 356                    (if (natnump jump)
 357                        (progn
 358                          (goto-char (window-end window))
 359                          ;; window-end doesn't reflect the window's new
 360                          ;; start position until the next redisplay.  Hurrah.
 361                          (vertical-motion (1- jump) window))
 362                      (goto-char (window-start window)))
 363                    (if overlay
 364                        (move-overlay overlay start (point)))
 365                    ;; Now that we have scrolled WINDOW properly,
 366                    ;; put point back where it was for the redisplay
 367                    ;; so that we don't mess up the selected window.
 368                    (or (eq window (selected-window))
 369                        (goto-char opoint))
 370                    (sit-for mouse-scroll-delay)))))
 371     (or (eq window (selected-window))
 372         (goto-char opoint))))
 373
 374 ;; Create an overlay and immediately delete it, to get "overlay in no buffer".
 375 (defvar mouse-drag-overlay (make-overlay 1 1))
 376 (delete-overlay mouse-drag-overlay)
 377 (overlay-put mouse-drag-overlay 'face 'region)
 378
 379 (defvar mouse-selection-click-count 0)
 380
 381 (defun mouse-drag-region (start-event)
 382   "Set the region to the text that the mouse is dragged over.
 383 Highlight the drag area as you move the mouse.
 384 This must be bound to a button-down mouse event.
 385 In Transient Mark mode, the highlighting remains once you
 386 release the mouse button.  Otherwise, it does not."
 387   (interactive "e")
 388   (mouse-minibuffer-check start-event)
 389   (let* ((start-posn (event-start start-event))
 390          (start-point (posn-point start-posn))
 391          (start-window (posn-window start-posn))
 392          (start-frame (window-frame start-window))
 393          (bounds (window-edges start-window))
 394          (top (nth 1 bounds))
 395          (bottom (if (window-minibuffer-p start-window)
 396                      (nth 3 bounds)
 397                    ;; Don't count the mode line.
 398                    (1- (nth 3 bounds))))
 399          (click-count (1- (event-click-count start-event))))
 400     (setq mouse-selection-click-count click-count)
 401     (mouse-set-point start-event)
 402     (let ((range (mouse-start-end start-point start-point click-count)))
 403       (move-overlay mouse-drag-overlay (car range) (nth 1 range)
 404                     (window-buffer start-window)))
 405     (deactivate-mark)
 406     (let (event end end-point)
 407       (track-mouse
 408         (while (progn
 409                  (setq event (read-event))
 410                  (or (mouse-movement-p event)
 411                      (eq (car-safe event) 'switch-frame)))
 412           (if (eq (car-safe event) 'switch-frame)
 413               nil
 414             (setq end (event-end event)
 415                   end-point (posn-point end))
 416
 417             (cond
 418              ;; Are we moving within the original window?
 419              ((and (eq (posn-window end) start-window)
 420                    (integer-or-marker-p end-point))
 421               (goto-char end-point)
 422               (let ((range (mouse-start-end start-point (point) click-count)))
 423                 (move-overlay mouse-drag-overlay (car range) (nth 1 range))))
 424
 425              (t
 426               (let ((mouse-row (cdr (cdr (mouse-position)))))
 427                 (cond
 428                  ((null mouse-row))
 429                  ((< mouse-row top)
 430                   (mouse-scroll-subr start-window (- mouse-row top)
 431                                      mouse-drag-overlay start-point))
 432                  ((>= mouse-row bottom)
 433                   (mouse-scroll-subr start-window (1+ (- mouse-row bottom))
 434                                      mouse-drag-overlay start-point)))))))))
 435       (if (consp event)
 436           (let ((fun (key-binding (vector (car event)))))
 437             ;; Run the binding of the terminating up-event, if possible.
 438             ;; In the case of a multiple click, it gives the wrong results,
 439             ;; because it would fail to set up a region.
 440             (if (and (= (mod mouse-selection-click-count 3) 0) (fboundp fun))
 441                 (progn
 442                   (setq this-command fun)
 443                   ;; Delete the overlay before calling the function,
 444                   ;; because delete-overlay increases buffer-modified-tick.
 445                   (delete-overlay mouse-drag-overlay)
 446                   (funcall fun event))
 447               (if (not (= (overlay-start mouse-drag-overlay)
 448                           (overlay-end mouse-drag-overlay)))
 449                   (let (last-command this-command)
 450                     (push-mark (overlay-start mouse-drag-overlay) t t)
 451                     (goto-char (overlay-end mouse-drag-overlay))
 452                     (delete-overlay mouse-drag-overlay)
 453                     (copy-region-as-kill (point) (mark t))
 454                     (mouse-set-region-1))
 455                 (goto-char (overlay-end mouse-drag-overlay))
 456                 (setq this-command 'mouse-set-point)
 457                 (delete-overlay mouse-drag-overlay))))
 458         (delete-overlay mouse-drag-overlay)))))
 459 \f
 460 ;; Commands to handle xterm-style multiple clicks.
 461
 462 (defun mouse-skip-word (dir)
 463   "Skip over word, over whitespace, or over identical punctuation.
 464 If DIR is positive skip forward; if negative, skip backward."
 465   (let* ((char (following-char))
 466          (syntax (char-to-string (char-syntax char))))
 467     (if (or (string= syntax "w") (string= syntax " "))
 468         (if (< dir 0)
 469             (skip-syntax-backward syntax)
 470           (skip-syntax-forward syntax))
 471       (if (< dir 0)
 472           (while (and (not (bobp)) (= (preceding-char) char))
 473             (forward-char -1))
 474         (while (and (not (eobp)) (= (following-char) char))
 475           (forward-char 1))))))
 476
 477 ;; Return a list of region bounds based on START and END according to MODE.
 478 ;; If MODE is 0 then set point to (min START END), mark to (max START END).
 479 ;; If MODE is 1 then set point to start of word at (min START END),
 480 ;; mark to end of word at (max START END).
 481 ;; If MODE is 2 then do the same for lines.
 482 (defun mouse-start-end (start end mode)
 483   (if (> start end)
 484       (let ((temp start))
 485         (setq start end
 486               end temp)))
 487   (setq mode (mod mode 3))
 488   (cond ((= mode 0)
 489          (list start end))
 490         ((and (= mode 1)
 491               (= start end)
 492               (char-after start)
 493               (= (char-syntax (char-after start)) ?\())
 494          (list start
 495                (save-excursion
 496                  (goto-char start)
 497                  (forward-sexp 1)
 498                  (point))))
 499         ((and (= mode 1)
 500               (= start end)
 501               (char-after start)
 502               (= (char-syntax (char-after start)) ?\)))
 503          (list (save-excursion
 504                  (goto-char (1+ start))
 505                  (backward-sexp 1)
 506                  (point))
 507                (1+ start)))
 508         ((= mode 1)
 509          (list (save-excursion
 510                  (goto-char start)
 511                  (mouse-skip-word -1)
 512                  (point))
 513                (save-excursion
 514                  (goto-char end)
 515                  (mouse-skip-word 1)
 516                  (point))))
 517         ((= mode 2)
 518          (list (save-excursion
 519                  (goto-char start)
 520                  (beginning-of-line 1)
 521                  (point))
 522                (save-excursion
 523                  (goto-char end)
 524                  (forward-line 1)
 525                  (point))))))
 526 \f
 527 ;; Subroutine: set the mark where CLICK happened,
 528 ;; but don't do anything else.
 529 (defun mouse-set-mark-fast (click)
 530   (mouse-minibuffer-check click)
 531   (let ((posn (event-start click)))
 532     (select-window (posn-window posn))
 533     (if (numberp (posn-point posn))
 534         (push-mark (posn-point posn) t t))))
 535
 536 ;; Momentarily show where the mark is, if highlighting doesn't show it.
 537 (defun mouse-show-mark ()
 538   (or transient-mark-mode
 539       (save-excursion
 540         (goto-char (mark t))
 541         (sit-for 1))))
 542
 543 (defun mouse-set-mark (click)
 544   "Set mark at the position clicked on with the mouse.
 545 Display cursor at that position for a second.
 546 This must be bound to a mouse click."
 547   (interactive "e")
 548   (mouse-minibuffer-check click)
 549   (select-window (posn-window (event-start click)))
 550   ;; We don't use save-excursion because that preserves the mark too.
 551   (let ((point-save (point)))
 552     (unwind-protect
 553         (progn (mouse-set-point click)
 554                (push-mark nil t t)
 555                (or transient-mark-mode
 556                    (sit-for 1)))
 557       (goto-char point-save))))
 558
 559 (defun mouse-kill (click)
 560   "Kill the region between point and the mouse click.
 561 The text is saved in the kill ring, as with \\[kill-region]."
 562   (interactive "e")
 563   (mouse-minibuffer-check click)
 564   (let* ((posn (event-start click))
 565          (click-posn (posn-point posn)))
 566     (select-window (posn-window posn))
 567     (if (numberp click-posn)
 568         (kill-region (min (point) click-posn)
 569                      (max (point) click-posn)))))
 570
 571 (defun mouse-yank-at-click (click arg)
 572   "Insert the last stretch of killed text at the position clicked on.
 573 Also move point to one end of the text thus inserted (normally the end).
 574 Prefix arguments are interpreted as with \\[yank].
 575 If `mouse-yank-at-point' is non-nil, insert at point
 576 regardless of where you click."
 577   (interactive "e\nP")
 578   ;; Give temporary modes such as isearch a chance to turn off.
 579   (run-hooks 'mouse-leave-buffer-hook)
 580   (or mouse-yank-at-point (mouse-set-point click))
 581   (setq this-command 'yank)
 582   (yank arg))
 583
 584 (defun mouse-kill-ring-save (click)
 585   "Copy the region between point and the mouse click in the kill ring.
 586 This does not delete the region; it acts like \\[kill-ring-save]."
 587   (interactive "e")
 588   (mouse-set-mark-fast click)
 589   (let (this-command last-command)
 590     (kill-ring-save (point) (mark t)))
 591   (mouse-show-mark))
 592
 593 ;;; This function used to delete the text between point and the mouse
 594 ;;; whenever it was equal to the front of the kill ring, but some
 595 ;;; people found that confusing.
 596
 597 ;;; A list (TEXT START END), describing the text and position of the last
 598 ;;; invocation of mouse-save-then-kill.
 599 (defvar mouse-save-then-kill-posn nil)
 600
 601 (defun mouse-save-then-kill-delete-region (beg end)
 602   ;; We must make our own undo boundaries
 603   ;; because they happen automatically only for the current buffer.
 604   (undo-boundary)
 605   (if (or (= beg end) (eq buffer-undo-list t))
 606       ;; If we have no undo list in this buffer,
 607       ;; just delete.
 608       (delete-region beg end)
 609     ;; Delete, but make the undo-list entry share with the kill ring.
 610     ;; First, delete just one char, so in case buffer is being modified
 611     ;; for the first time, the undo list records that fact.
 612     (let (before-change-function after-change-function
 613           before-change-functions after-change-functions)
 614       (delete-region beg
 615                      (+ beg (if (> end beg) 1 -1))))
 616     (let ((buffer-undo-list buffer-undo-list))
 617       ;; Undo that deletion--but don't change the undo list!
 618       (let (before-change-function after-change-function
 619             before-change-functions after-change-functions)
 620         (primitive-undo 1 buffer-undo-list))
 621       ;; Now delete the rest of the specified region,
 622       ;; but don't record it.
 623       (setq buffer-undo-list t)
 624       (if (/= (length (car kill-ring)) (- (max end beg) (min end beg)))
 625           (error "Lossage in mouse-save-then-kill-delete-region"))
 626       (delete-region beg end))
 627     (let ((tail buffer-undo-list))
 628       ;; Search back in buffer-undo-list for the string
 629       ;; that came from deleting one character.
 630       (while (and tail (not (stringp (car (car tail)))))
 631         (setq tail (cdr tail)))
 632       ;; Replace it with an entry for the entire deleted text.
 633       (and tail
 634            (setcar tail (cons (car kill-ring) (min beg end))))))
 635   (undo-boundary))
 636
 637 (defun mouse-save-then-kill (click)
 638   "Save text to point in kill ring; the second time, kill the text.
 639 If the text between point and the mouse is the same as what's
 640 at the front of the kill ring, this deletes the text.
 641 Otherwise, it adds the text to the kill ring, like \\[kill-ring-save],
 642 which prepares for a second click to delete the text.
 643
 644 If you have selected words or lines, this command extends the
 645 selection through the word or line clicked on.  If you do this
 646 again in a different position, it extends the selection again.
 647 If you do this twice in the same position, the selection is killed."
 648   (interactive "e")
 649   (let ((before-scroll point-before-scroll))
 650     (mouse-minibuffer-check click)
 651     (let ((click-posn (posn-point (event-start click)))
 652           ;; Don't let a subsequent kill command append to this one:
 653           ;; prevent setting this-command to kill-region.
 654           (this-command this-command))
 655       (if (and (mark t) (> (mod mouse-selection-click-count 3) 0))
 656           (if (not (and (eq last-command 'mouse-save-then-kill)
 657                         (equal click-posn
 658                                (car (cdr-safe (cdr-safe mouse-save-then-kill-posn))))))
 659               ;; Find both ends of the object selected by this click.
 660               (let* ((range
 661                       (mouse-start-end click-posn click-posn
 662                                        mouse-selection-click-count)))
 663                 ;; Move whichever end is closer to the click.
 664                 ;; That's what xterm does, and it seems reasonable.
 665                 (if (< (abs (- click-posn (mark t)))
 666                        (abs (- click-posn (point))))
 667                     (set-mark (car range))
 668                   (goto-char (nth 1 range)))
 669                 ;; We have already put the old region in the kill ring.
 670                 ;; Replace it with the extended region.
 671                 ;; (It would be annoying to make a separate entry.)
 672                 (kill-new (buffer-substring (point) (mark t)) t)
 673                 (mouse-set-region-1)
 674                 ;; Arrange for a repeated mouse-3 to kill this region.
 675                 (setq mouse-save-then-kill-posn
 676                       (list (car kill-ring) (point) click-posn))
 677                 (mouse-show-mark))
 678             ;; If we click this button again without moving it,
 679             ;; that time kill.
 680             (mouse-save-then-kill-delete-region (mark) (point))
 681             (setq mouse-selection-click-count 0)
 682             (setq mouse-save-then-kill-posn nil))
 683         (if (and (eq last-command 'mouse-save-then-kill)
 684                  mouse-save-then-kill-posn
 685                  (eq (car mouse-save-then-kill-posn) (car kill-ring))
 686                  (equal (cdr mouse-save-then-kill-posn) (list (point) click-posn)))
 687             ;; If this is the second time we've called
 688             ;; mouse-save-then-kill, delete the text from the buffer.
 689             (progn
 690               (mouse-save-then-kill-delete-region (point) (mark))
 691               ;; After we kill, another click counts as "the first time".
 692               (setq mouse-save-then-kill-posn nil))
 693           (if (or (and (eq last-command 'mouse-save-then-kill)
 694                        mouse-save-then-kill-posn)
 695                   (and mark-active transient-mark-mode)
 696                   (and (memq last-command
 697                              '(mouse-drag-region mouse-set-region))
 698                        (or mark-even-if-inactive
 699                            (not transient-mark-mode))))
 700               ;; We have a selection or suitable region, so adjust it.
 701               (let* ((posn (event-start click))
 702                      (new (posn-point posn)))
 703                 (select-window (posn-window posn))
 704                 (if (numberp new)
 705                     (progn
 706                       ;; Move whichever end of the region is closer to the click.
 707                       ;; That is what xterm does, and it seems reasonable.
 708                       (if (< (abs (- new (point))) (abs (- new (mark t))))
 709                           (goto-char new)
 710                         (set-mark new))
 711                       (setq deactivate-mark nil)))
 712                 (kill-new (buffer-substring (point) (mark t)) t)
 713                 (mouse-show-mark))
 714             ;; Set the mark where point is, then move where clicked.
 715             (mouse-set-mark-fast click)
 716             (if before-scroll
 717                 (goto-char before-scroll))
 718             (exchange-point-and-mark)
 719             (kill-new (buffer-substring (point) (mark t))))
 720           (mouse-set-region-1)
 721           (setq mouse-save-then-kill-posn
 722                 (list (car kill-ring) (point) click-posn)))))))
 723 \f
 724 (global-set-key [M-mouse-1] 'mouse-start-secondary)
 725 (global-set-key [M-drag-mouse-1] 'mouse-set-secondary)
 726 (global-set-key [M-down-mouse-1] 'mouse-drag-secondary)
 727 (global-set-key [M-mouse-3] 'mouse-secondary-save-then-kill)
 728 (global-set-key [M-mouse-2] 'mouse-yank-secondary)
 729
 730 ;; An overlay which records the current secondary selection
 731 ;; or else is deleted when there is no secondary selection.
 732 ;; May be nil.
 733 (defvar mouse-secondary-overlay nil)
 734
 735 (defvar mouse-secondary-click-count 0)
 736
 737 ;; A marker which records the specified first end for a secondary selection.
 738 ;; May be nil.
 739 (defvar mouse-secondary-start nil)
 740
 741 (defun mouse-start-secondary (click)
 742   "Set one end of the secondary selection to the position clicked on.
 743 Use \\[mouse-secondary-save-then-kill] to set the other end
 744 and complete the secondary selection."
 745   (interactive "e")
 746   (mouse-minibuffer-check click)
 747   (let ((posn (event-start click)))
 748     (save-excursion
 749       (set-buffer (window-buffer (posn-window posn)))
 750       ;; Cancel any preexisting secondary selection.
 751       (if mouse-secondary-overlay
 752           (delete-overlay mouse-secondary-overlay))
 753       (if (numberp (posn-point posn))
 754           (progn
 755             (or mouse-secondary-start
 756                 (setq mouse-secondary-start (make-marker)))
 757             (move-marker mouse-secondary-start (posn-point posn)))))))
 758
 759 (defun mouse-set-secondary (click)
 760   "Set the secondary selection to the text that the mouse is dragged over.
 761 This must be bound to a mouse drag event."
 762   (interactive "e")
 763   (mouse-minibuffer-check click)
 764   (let ((posn (event-start click))
 765         beg
 766         (end (event-end click)))
 767     (save-excursion
 768       (set-buffer (window-buffer (posn-window posn)))
 769       (if (numberp (posn-point posn))
 770           (setq beg (posn-point posn)))
 771       (if mouse-secondary-overlay
 772           (move-overlay mouse-secondary-overlay beg (posn-point end))
 773         (setq mouse-secondary-overlay (make-overlay beg (posn-point end))))
 774       (overlay-put mouse-secondary-overlay 'face 'secondary-selection))))
 775
 776 (defun mouse-drag-secondary (start-event)
 777   "Set the secondary selection to the text that the mouse is dragged over.
 778 Highlight the drag area as you move the mouse.
 779 This must be bound to a button-down mouse event."
 780   (interactive "e")
 781   (mouse-minibuffer-check start-event)
 782   (let* ((start-posn (event-start start-event))
 783          (start-point (posn-point start-posn))
 784          (start-window (posn-window start-posn))
 785          (start-frame (window-frame start-window))
 786          (bounds (window-edges start-window))
 787          (top (nth 1 bounds))
 788          (bottom (if (window-minibuffer-p start-window)
 789                      (nth 3 bounds)
 790                    ;; Don't count the mode line.
 791                    (1- (nth 3 bounds))))
 792          (click-count (1- (event-click-count start-event))))
 793     (save-excursion
 794       (set-buffer (window-buffer start-window))
 795       (setq mouse-secondary-click-count click-count)
 796       (or mouse-secondary-overlay
 797           (setq mouse-secondary-overlay
 798                 (make-overlay (point) (point))))
 799       (overlay-put mouse-secondary-overlay 'face 'secondary-selection)
 800       (if (> (mod click-count 3) 0)
 801           ;; Double or triple press: make an initial selection
 802           ;; of one word or line.
 803           (let ((range (mouse-start-end start-point start-point click-count)))
 804             (set-marker mouse-secondary-start nil)
 805             (move-overlay mouse-secondary-overlay 1 1
 806                           (window-buffer start-window))
 807             (move-overlay mouse-secondary-overlay (car range) (nth 1 range)
 808                           (window-buffer start-window)))
 809         ;; Single-press: cancel any preexisting secondary selection.
 810         (or mouse-secondary-start
 811             (setq mouse-secondary-start (make-marker)))
 812         (set-marker mouse-secondary-start start-point)
 813         (delete-overlay mouse-secondary-overlay))
 814       (let (event end end-point)
 815         (track-mouse
 816           (while (progn
 817                    (setq event (read-event))
 818                    (or (mouse-movement-p event)
 819                        (eq (car-safe event) 'switch-frame)))
 820
 821             (if (eq (car-safe event) 'switch-frame)
 822                 nil
 823               (setq end (event-end event)
 824                     end-point (posn-point end))
 825               (cond
 826                ;; Are we moving within the original window?
 827                ((and (eq (posn-window end) start-window)
 828                      (integer-or-marker-p end-point))
 829                 (let ((range (mouse-start-end start-point end-point
 830                                               click-count)))
 831                   (if (or (/= start-point end-point)
 832                           (null (marker-position mouse-secondary-start)))
 833                       (progn
 834                         (set-marker mouse-secondary-start nil)
 835                         (move-overlay mouse-secondary-overlay
 836                                       (car range) (nth 1 range))))))
 837                (t
 838                 (let ((mouse-row (cdr (cdr (mouse-position)))))
 839                   (cond
 840                    ((null mouse-row))
 841                    ((< mouse-row top)
 842                     (mouse-scroll-subr start-window (- mouse-row top)
 843                                        mouse-secondary-overlay start-point))
 844                    ((>= mouse-row bottom)
 845                     (mouse-scroll-subr start-window (1+ (- mouse-row bottom))
 846                                        mouse-secondary-overlay start-point)))))))))
 847
 848         (if (consp event)
 849 ;;;              (eq (get (event-basic-type event) 'event-kind) 'mouse-click)
 850 ;;;              (eq (posn-window (event-end event)) start-window)
 851 ;;;              (numberp (posn-point (event-end event)))
 852             (if (marker-position mouse-secondary-start)
 853                 (save-window-excursion
 854                   (delete-overlay mouse-secondary-overlay)
 855                   (x-set-selection 'SECONDARY nil)
 856                   (select-window start-window)
 857                   (save-excursion
 858                     (goto-char mouse-secondary-start)
 859                     (sit-for 1)))
 860               (x-set-selection
 861                'SECONDARY
 862                (buffer-substring (overlay-start mouse-secondary-overlay)
 863                                  (overlay-end mouse-secondary-overlay)))))))))
 864
 865 (defun mouse-yank-secondary (click)
 866   "Insert the secondary selection at the position clicked on.
 867 Move point to the end of the inserted text.
 868 If `mouse-yank-at-point' is non-nil, insert at point
 869 regardless of where you click."
 870   (interactive "e")
 871   ;; Give temporary modes such as isearch a chance to turn off.
 872   (run-hooks 'mouse-leave-buffer-hook)
 873   (or mouse-yank-at-point (mouse-set-point click))
 874   (insert (x-get-selection 'SECONDARY)))
 875
 876 (defun mouse-kill-secondary ()
 877   "Kill the text in the secondary selection.
 878 This is intended more as a keyboard command than as a mouse command
 879 but it can work as either one.
 880
 881 The current buffer (in case of keyboard use), or the buffer clicked on,
 882 must be the one that the secondary selection is in.  This requirement
 883 is to prevent accidents."
 884   (interactive)
 885   (let* ((keys (this-command-keys))
 886          (click (elt keys (1- (length keys)))))
 887     (or (eq (overlay-buffer mouse-secondary-overlay)
 888             (if (listp click)
 889                 (window-buffer (posn-window (event-start click)))
 890               (current-buffer)))
 891         (error "Select or click on the buffer where the secondary selection is")))
 892   (let (this-command)
 893     (save-excursion
 894       (set-buffer (overlay-buffer mouse-secondary-overlay))
 895       (kill-region (overlay-start mouse-secondary-overlay)
 896                    (overlay-end mouse-secondary-overlay))))
 897   (delete-overlay mouse-secondary-overlay)
 898 ;;;  (x-set-selection 'SECONDARY nil)
 899   (setq mouse-secondary-overlay nil))
 900
 901 (defun mouse-secondary-save-then-kill (click)
 902   "Save text to point in kill ring; the second time, kill the text.
 903 You must use this in a buffer where you have recently done \\[mouse-start-secondary].
 904 If the text between where you did \\[mouse-start-secondary] and where
 905 you use this command matches the text at the front of the kill ring,
 906 this command deletes the text.
 907 Otherwise, it adds the text to the kill ring, like \\[kill-ring-save],
 908 which prepares for a second click with this command to delete the text.
 909
 910 If you have already made a secondary selection in that buffer,
 911 this command extends or retracts the selection to where you click.
 912 If you do this again in a different position, it extends or retracts
 913 again.  If you do this twice in the same position, it kills the selection."
 914   (interactive "e")
 915   (mouse-minibuffer-check click)
 916   (let ((posn (event-start click))
 917         (click-posn (posn-point (event-start click)))
 918         ;; Don't let a subsequent kill command append to this one:
 919         ;; prevent setting this-command to kill-region.
 920         (this-command this-command))
 921     (or (eq (window-buffer (posn-window posn))
 922             (or (and mouse-secondary-overlay
 923                      (overlay-buffer mouse-secondary-overlay))
 924                 (if mouse-secondary-start
 925                     (marker-buffer mouse-secondary-start))))
 926         (error "Wrong buffer"))
 927     (save-excursion
 928       (set-buffer (window-buffer (posn-window posn)))
 929       (if (> (mod mouse-secondary-click-count 3) 0)
 930           (if (not (and (eq last-command 'mouse-secondary-save-then-kill)
 931                         (equal click-posn
 932                                (car (cdr-safe (cdr-safe mouse-save-then-kill-posn))))))
 933               ;; Find both ends of the object selected by this click.
 934               (let* ((range
 935                       (mouse-start-end click-posn click-posn
 936                                        mouse-secondary-click-count)))
 937                 ;; Move whichever end is closer to the click.
 938                 ;; That's what xterm does, and it seems reasonable.
 939                 (if (< (abs (- click-posn (overlay-start mouse-secondary-overlay)))
 940                        (abs (- click-posn (overlay-end mouse-secondary-overlay))))
 941                     (move-overlay mouse-secondary-overlay (car range)
 942                                   (overlay-end mouse-secondary-overlay))
 943                   (move-overlay mouse-secondary-overlay
 944                                 (overlay-start mouse-secondary-overlay)
 945                                 (nth 1 range)))
 946                 ;; We have already put the old region in the kill ring.
 947                 ;; Replace it with the extended region.
 948                 ;; (It would be annoying to make a separate entry.)
 949                 (kill-new (buffer-substring
 950                            (overlay-start mouse-secondary-overlay)
 951                            (overlay-end mouse-secondary-overlay)) t)
 952                 ;; Arrange for a repeated mouse-3 to kill this region.
 953                 (setq mouse-save-then-kill-posn
 954                       (list (car kill-ring) (point) click-posn)))
 955             ;; If we click this button again without moving it,
 956             ;; that time kill.
 957             (progn
 958               (mouse-save-then-kill-delete-region
 959                (overlay-start mouse-secondary-overlay)
 960                (overlay-end mouse-secondary-overlay))
 961               (setq mouse-save-then-kill-posn nil)
 962               (setq mouse-secondary-click-count 0)
 963               (delete-overlay mouse-secondary-overlay)))
 964         (if (and (eq last-command 'mouse-secondary-save-then-kill)
 965                  mouse-save-then-kill-posn
 966                  (eq (car mouse-save-then-kill-posn) (car kill-ring))
 967                  (equal (cdr mouse-save-then-kill-posn) (list (point) click-posn)))
 968             ;; If this is the second time we've called
 969             ;; mouse-secondary-save-then-kill, delete the text from the buffer.
 970             (progn
 971               (mouse-save-then-kill-delete-region
 972                (overlay-start mouse-secondary-overlay)
 973                (overlay-end mouse-secondary-overlay))
 974               (setq mouse-save-then-kill-posn nil)
 975               (delete-overlay mouse-secondary-overlay))
 976           (if (overlay-start mouse-secondary-overlay)
 977               ;; We have a selection, so adjust it.
 978               (progn
 979                 (if (numberp click-posn)
 980                     (progn
 981                       ;; Move whichever end of the region is closer to the click.
 982                       ;; That is what xterm does, and it seems reasonable.
 983                       (if (< (abs (- click-posn (overlay-start mouse-secondary-overlay)))
 984                              (abs (- click-posn (overlay-end mouse-secondary-overlay))))
 985                           (move-overlay mouse-secondary-overlay click-posn
 986                                         (overlay-end mouse-secondary-overlay))
 987                         (move-overlay mouse-secondary-overlay
 988                                       (overlay-start mouse-secondary-overlay)
 989                                       click-posn))
 990                       (setq deactivate-mark nil)))
 991                 (if (eq last-command 'mouse-secondary-save-then-kill)
 992                     ;; If the front of the kill ring comes from
 993                     ;; an immediately previous use of this command,
 994                     ;; replace it with the extended region.
 995                     ;; (It would be annoying to make a separate entry.)
 996                     (kill-new (buffer-substring
 997                                (overlay-start mouse-secondary-overlay)
 998                                (overlay-end mouse-secondary-overlay)) t)
 999                   (copy-region-as-kill (overlay-start mouse-secondary-overlay)
1000                                        (overlay-end mouse-secondary-overlay))))
1001             (if mouse-secondary-start
1002                 ;; All we have is one end of a selection,
1003                 ;; so put the other end here.
1004                 (let ((start (+ 0 mouse-secondary-start)))
1005                   (kill-ring-save start click-posn)
1006                   (if mouse-secondary-overlay
1007                       (move-overlay mouse-secondary-overlay start click-posn)
1008                     (setq mouse-secondary-overlay (make-overlay start click-posn)))
1009                   (overlay-put mouse-secondary-overlay 'face 'secondary-selection))))
1010           (setq mouse-save-then-kill-posn
1011                 (list (car kill-ring) (point) click-posn))))
1012       (if (overlay-buffer mouse-secondary-overlay)
1013           (x-set-selection 'SECONDARY
1014                            (buffer-substring
1015                             (overlay-start mouse-secondary-overlay)
1016                             (overlay-end mouse-secondary-overlay)))))))
1017 \f
1018 (defun mouse-buffer-menu (event)
1019   "Pop up a menu of buffers for selection with the mouse.
1020 This switches buffers in the window that you clicked on,
1021 and selects that window."
1022   (interactive "e")
1023   (mouse-minibuffer-check event)
1024   (let ((menu
1025          (list "Buffer Menu"
1026                (cons "Select Buffer"
1027                      (let ((tail (buffer-list))
1028                            (maxbuf 0)
1029                            head)
1030                        (while tail
1031                          (or (eq ?\ (aref (buffer-name (car tail)) 0))
1032                              (setq maxbuf
1033                                    (max maxbuf
1034                                         (length (buffer-name (car tail))))))
1035                          (setq tail (cdr tail)))
1036                        (setq tail (buffer-list))
1037                        (while tail
1038                          (let ((elt (car tail)))
1039                            (if (not (string-match "^ "
1040                                                   (buffer-name elt)))
1041                                (setq head
1042                                 (cons
1043                                  (cons
1044                                   (format
1045                                    (format "%%%ds  %%s%%s  %%s" maxbuf)
1046                                    (buffer-name elt)
1047                                    (if (buffer-modified-p elt) "*" " ")
1048                                    (save-excursion
1049                                      (set-buffer elt)
1050                                      (if buffer-read-only "%" " "))
1051                                    (or (buffer-file-name elt)
1052                                        (save-excursion
1053                                          (set-buffer elt)
1054                                          (if list-buffers-directory
1055                                              (expand-file-name
1056                                               list-buffers-directory)))
1057                                        ""))
1058                                   elt)
1059                                  head))))
1060                          (setq tail (cdr tail)))
1061                        (reverse head))))))
1062     (let ((buf (x-popup-menu event menu))
1063           (window (posn-window (event-start event))))
1064       (if buf
1065           (progn
1066             (or (framep window) (select-window window))
1067             (switch-to-buffer buf))))))
1068 \f
1069 ;;; These need to be rewritten for the new scroll bar implementation.
1070
1071 ;;;!! ;; Commands for the scroll bar.
1072 ;;;!!
1073 ;;;!! (defun mouse-scroll-down (click)
1074 ;;;!!   (interactive "@e")
1075 ;;;!!   (scroll-down (1+ (cdr (mouse-coords click)))))
1076 ;;;!!
1077 ;;;!! (defun mouse-scroll-up (click)
1078 ;;;!!   (interactive "@e")
1079 ;;;!!   (scroll-up (1+ (cdr (mouse-coords click)))))
1080 ;;;!!
1081 ;;;!! (defun mouse-scroll-down-full ()
1082 ;;;!!   (interactive "@")
1083 ;;;!!   (scroll-down nil))
1084 ;;;!!
1085 ;;;!! (defun mouse-scroll-up-full ()
1086 ;;;!!   (interactive "@")
1087 ;;;!!   (scroll-up nil))
1088 ;;;!!
1089 ;;;!! (defun mouse-scroll-move-cursor (click)
1090 ;;;!!   (interactive "@e")
1091 ;;;!!   (move-to-window-line (1+ (cdr (mouse-coords click)))))
1092 ;;;!!
1093 ;;;!! (defun mouse-scroll-absolute (event)
1094 ;;;!!   (interactive "@e")
1095 ;;;!!   (let* ((pos (car event))
1096 ;;;!!    (position (car pos))
1097 ;;;!!    (length (car (cdr pos))))
1098 ;;;!!     (if (<= length 0) (setq length 1))
1099 ;;;!!     (let* ((scale-factor (max 1 (/ length (/ 8000000 (buffer-size)))))
1100 ;;;!!      (newpos (* (/ (* (/ (buffer-size) scale-factor)
1101 ;;;!!                       position)
1102 ;;;!!                    length)
1103 ;;;!!                 scale-factor)))
1104 ;;;!!       (goto-char newpos)
1105 ;;;!!       (recenter '(4)))))
1106 ;;;!!
1107 ;;;!! (defun mouse-scroll-left (click)
1108 ;;;!!   (interactive "@e")
1109 ;;;!!   (scroll-left (1+ (car (mouse-coords click)))))
1110 ;;;!!
1111 ;;;!! (defun mouse-scroll-right (click)
1112 ;;;!!   (interactive "@e")
1113 ;;;!!   (scroll-right (1+ (car (mouse-coords click)))))
1114 ;;;!!
1115 ;;;!! (defun mouse-scroll-left-full ()
1116 ;;;!!   (interactive "@")
1117 ;;;!!   (scroll-left nil))
1118 ;;;!!
1119 ;;;!! (defun mouse-scroll-right-full ()
1120 ;;;!!   (interactive "@")
1121 ;;;!!   (scroll-right nil))
1122 ;;;!!
1123 ;;;!! (defun mouse-scroll-move-cursor-horizontally (click)
1124 ;;;!!   (interactive "@e")
1125 ;;;!!   (move-to-column (1+ (car (mouse-coords click)))))
1126 ;;;!!
1127 ;;;!! (defun mouse-scroll-absolute-horizontally (event)
1128 ;;;!!   (interactive "@e")
1129 ;;;!!   (let* ((pos (car event))
1130 ;;;!!    (position (car pos))
1131 ;;;!!    (length (car (cdr pos))))
1132 ;;;!!   (set-window-hscroll (selected-window) 33)))
1133 ;;;!!
1134 ;;;!! (global-set-key [scroll-bar mouse-1] 'mouse-scroll-up)
1135 ;;;!! (global-set-key [scroll-bar mouse-2] 'mouse-scroll-absolute)
1136 ;;;!! (global-set-key [scroll-bar mouse-3] 'mouse-scroll-down)
1137 ;;;!!
1138 ;;;!! (global-set-key [vertical-slider mouse-1] 'mouse-scroll-move-cursor)
1139 ;;;!! (global-set-key [vertical-slider mouse-2] 'mouse-scroll-move-cursor)
1140 ;;;!! (global-set-key [vertical-slider mouse-3] 'mouse-scroll-move-cursor)
1141 ;;;!!
1142 ;;;!! (global-set-key [thumbup mouse-1] 'mouse-scroll-up-full)
1143 ;;;!! (global-set-key [thumbup mouse-2] 'mouse-scroll-up-full)
1144 ;;;!! (global-set-key [thumbup mouse-3] 'mouse-scroll-up-full)
1145 ;;;!!
1146 ;;;!! (global-set-key [thumbdown mouse-1] 'mouse-scroll-down-full)
1147 ;;;!! (global-set-key [thumbdown mouse-2] 'mouse-scroll-down-full)
1148 ;;;!! (global-set-key [thumbdown mouse-3] 'mouse-scroll-down-full)
1149 ;;;!!
1150 ;;;!! (global-set-key [horizontal-scroll-bar mouse-1] 'mouse-scroll-left)
1151 ;;;!! (global-set-key [horizontal-scroll-bar mouse-2]
1152 ;;;!!           'mouse-scroll-absolute-horizontally)
1153 ;;;!! (global-set-key [horizontal-scroll-bar mouse-3] 'mouse-scroll-right)
1154 ;;;!!
1155 ;;;!! (global-set-key [horizontal-slider mouse-1]
1156 ;;;!!           'mouse-scroll-move-cursor-horizontally)
1157 ;;;!! (global-set-key [horizontal-slider mouse-2]
1158 ;;;!!           'mouse-scroll-move-cursor-horizontally)
1159 ;;;!! (global-set-key [horizontal-slider mouse-3]
1160 ;;;!!           'mouse-scroll-move-cursor-horizontally)
1161 ;;;!!
1162 ;;;!! (global-set-key [thumbleft mouse-1] 'mouse-scroll-left-full)
1163 ;;;!! (global-set-key [thumbleft mouse-2] 'mouse-scroll-left-full)
1164 ;;;!! (global-set-key [thumbleft mouse-3] 'mouse-scroll-left-full)
1165 ;;;!!
1166 ;;;!! (global-set-key [thumbright mouse-1] 'mouse-scroll-right-full)
1167 ;;;!! (global-set-key [thumbright mouse-2] 'mouse-scroll-right-full)
1168 ;;;!! (global-set-key [thumbright mouse-3] 'mouse-scroll-right-full)
1169 ;;;!!
1170 ;;;!! (global-set-key [horizontal-scroll-bar S-mouse-2]
1171 ;;;!!           'mouse-split-window-horizontally)
1172 ;;;!! (global-set-key [mode-line S-mouse-2]
1173 ;;;!!           'mouse-split-window-horizontally)
1174 ;;;!! (global-set-key [vertical-scroll-bar S-mouse-2]
1175 ;;;!!           'mouse-split-window)
1176 \f
1177 ;;;!! ;;;;
1178 ;;;!! ;;;; Here are experimental things being tested.  Mouse events
1179 ;;;!! ;;;; are of the form:
1180 ;;;!! ;;;;      ((x y) window screen-part key-sequence timestamp)
1181 ;;;!! ;;
1182 ;;;!! ;;;;
1183 ;;;!! ;;;; Dynamically track mouse coordinates
1184 ;;;!! ;;;;
1185 ;;;!! ;;
1186 ;;;!! ;;(defun track-mouse (event)
1187 ;;;!! ;;  "Track the coordinates, absolute and relative, of the mouse."
1188 ;;;!! ;;  (interactive "@e")
1189 ;;;!! ;;  (while mouse-grabbed
1190 ;;;!! ;;    (let* ((pos (read-mouse-position (selected-screen)))
1191 ;;;!! ;;           (abs-x (car pos))
1192 ;;;!! ;;           (abs-y (cdr pos))
1193 ;;;!! ;;           (relative-coordinate (coordinates-in-window-p
1194 ;;;!! ;;                                 (list (car pos) (cdr pos))
1195 ;;;!! ;;                                 (selected-window))))
1196 ;;;!! ;;      (if (consp relative-coordinate)
1197 ;;;!! ;;          (message "mouse: [%d %d], (%d %d)" abs-x abs-y
1198 ;;;!! ;;                   (car relative-coordinate)
1199 ;;;!! ;;                   (car (cdr relative-coordinate)))
1200 ;;;!! ;;        (message "mouse: [%d %d]" abs-x abs-y)))))
1201 ;;;!!
1202 ;;;!! ;;
1203 ;;;!! ;; Dynamically put a box around the line indicated by point
1204 ;;;!! ;;
1205 ;;;!! ;;
1206 ;;;!! ;;(require 'backquote)
1207 ;;;!! ;;
1208 ;;;!! ;;(defun mouse-select-buffer-line (event)
1209 ;;;!! ;;  (interactive "@e")
1210 ;;;!! ;;  (let ((relative-coordinate
1211 ;;;!! ;;         (coordinates-in-window-p (car event) (selected-window)))
1212 ;;;!! ;;        (abs-y (car (cdr (car event)))))
1213 ;;;!! ;;    (if (consp relative-coordinate)
1214 ;;;!! ;;        (progn
1215 ;;;!! ;;          (save-excursion
1216 ;;;!! ;;            (move-to-window-line (car (cdr relative-coordinate)))
1217 ;;;!! ;;            (x-draw-rectangle
1218 ;;;!! ;;             (selected-screen)
1219 ;;;!! ;;             abs-y 0
1220 ;;;!! ;;             (save-excursion
1221 ;;;!! ;;                 (move-to-window-line (car (cdr relative-coordinate)))
1222 ;;;!! ;;                 (end-of-line)
1223 ;;;!! ;;                 (push-mark nil t)
1224 ;;;!! ;;                 (beginning-of-line)
1225 ;;;!! ;;                 (- (region-end) (region-beginning))) 1))
1226 ;;;!! ;;          (sit-for 1)
1227 ;;;!! ;;          (x-erase-rectangle (selected-screen))))))
1228 ;;;!! ;;
1229 ;;;!! ;;(defvar last-line-drawn nil)
1230 ;;;!! ;;(defvar begin-delim "[^ \t]")
1231 ;;;!! ;;(defvar end-delim   "[^ \t]")
1232 ;;;!! ;;
1233 ;;;!! ;;(defun mouse-boxing (event)
1234 ;;;!! ;;  (interactive "@e")
1235 ;;;!! ;;  (save-excursion
1236 ;;;!! ;;    (let ((screen (selected-screen)))
1237 ;;;!! ;;      (while (= (x-mouse-events) 0)
1238 ;;;!! ;;        (let* ((pos (read-mouse-position screen))
1239 ;;;!! ;;               (abs-x (car pos))
1240 ;;;!! ;;               (abs-y (cdr pos))
1241 ;;;!! ;;               (relative-coordinate
1242 ;;;!! ;;                (coordinates-in-window-p (` ((, abs-x) (, abs-y)))
1243 ;;;!! ;;                                         (selected-window)))
1244 ;;;!! ;;               (begin-reg nil)
1245 ;;;!! ;;               (end-reg nil)
1246 ;;;!! ;;               (end-column nil)
1247 ;;;!! ;;               (begin-column nil))
1248 ;;;!! ;;          (if (and (consp relative-coordinate)
1249 ;;;!! ;;                   (or (not last-line-drawn)
1250 ;;;!! ;;                       (not (= last-line-drawn abs-y))))
1251 ;;;!! ;;              (progn
1252 ;;;!! ;;                (move-to-window-line (car (cdr relative-coordinate)))
1253 ;;;!! ;;                (if (= (following-char) 10)
1254 ;;;!! ;;                    ()
1255 ;;;!! ;;                  (progn
1256 ;;;!! ;;                    (setq begin-reg (1- (re-search-forward end-delim)))
1257 ;;;!! ;;                    (setq begin-column (1- (current-column)))
1258 ;;;!! ;;                    (end-of-line)
1259 ;;;!! ;;                    (setq end-reg (1+ (re-search-backward begin-delim)))
1260 ;;;!! ;;                    (setq end-column (1+ (current-column)))
1261 ;;;!! ;;                    (message "%s" (buffer-substring begin-reg end-reg))
1262 ;;;!! ;;                    (x-draw-rectangle screen
1263 ;;;!! ;;                                      (setq last-line-drawn abs-y)
1264 ;;;!! ;;                                      begin-column
1265 ;;;!! ;;                                      (- end-column begin-column) 1))))))))))
1266 ;;;!! ;;
1267 ;;;!! ;;(defun mouse-erase-box ()
1268 ;;;!! ;;  (interactive)
1269 ;;;!! ;;  (if last-line-drawn
1270 ;;;!! ;;      (progn
1271 ;;;!! ;;        (x-erase-rectangle (selected-screen))
1272 ;;;!! ;;        (setq last-line-drawn nil))))
1273 ;;;!!
1274 ;;;!! ;;; (defun test-x-rectangle ()
1275 ;;;!! ;;;   (use-local-mouse-map (setq rectangle-test-map (make-sparse-keymap)))
1276 ;;;!! ;;;   (define-key rectangle-test-map mouse-motion-button-left 'mouse-boxing)
1277 ;;;!! ;;;   (define-key rectangle-test-map mouse-button-left-up 'mouse-erase-box))
1278 ;;;!!
1279 ;;;!! ;;
1280 ;;;!! ;; Here is how to do double clicking in lisp.  About to change.
1281 ;;;!! ;;
1282 ;;;!!
1283 ;;;!! (defvar double-start nil)
1284 ;;;!! (defconst double-click-interval 300
1285 ;;;!!   "Max ticks between clicks")
1286 ;;;!!
1287 ;;;!! (defun double-down (event)
1288 ;;;!!   (interactive "@e")
1289 ;;;!!   (if double-start
1290 ;;;!!       (let ((interval (- (nth 4 event) double-start)))
1291 ;;;!!   (if (< interval double-click-interval)
1292 ;;;!!       (progn
1293 ;;;!!         (backward-up-list 1)
1294 ;;;!!         ;;      (message "Interval %d" interval)
1295 ;;;!!         (sleep-for 1)))
1296 ;;;!!   (setq double-start nil))
1297 ;;;!!     (setq double-start (nth 4 event))))
1298 ;;;!!
1299 ;;;!! (defun double-up (event)
1300 ;;;!!   (interactive "@e")
1301 ;;;!!   (and double-start
1302 ;;;!!        (> (- (nth 4 event ) double-start) double-click-interval)
1303 ;;;!!        (setq double-start nil)))
1304 ;;;!!
1305 ;;;!! ;;; (defun x-test-doubleclick ()
1306 ;;;!! ;;;   (use-local-mouse-map (setq doubleclick-test-map (make-sparse-keymap)))
1307 ;;;!! ;;;   (define-key doubleclick-test-map mouse-button-left 'double-down)
1308 ;;;!! ;;;   (define-key doubleclick-test-map mouse-button-left-up 'double-up))
1309 ;;;!!
1310 ;;;!! ;;
1311 ;;;!! ;; This scrolls while button is depressed.  Use preferable in scroll bar.
1312 ;;;!! ;;
1313 ;;;!!
1314 ;;;!! (defvar scrolled-lines 0)
1315 ;;;!! (defconst scroll-speed 1)
1316 ;;;!!
1317 ;;;!! (defun incr-scroll-down (event)
1318 ;;;!!   (interactive "@e")
1319 ;;;!!   (setq scrolled-lines 0)
1320 ;;;!!   (incremental-scroll scroll-speed))
1321 ;;;!!
1322 ;;;!! (defun incr-scroll-up (event)
1323 ;;;!!   (interactive "@e")
1324 ;;;!!   (setq scrolled-lines 0)
1325 ;;;!!   (incremental-scroll (- scroll-speed)))
1326 ;;;!!
1327 ;;;!! (defun incremental-scroll (n)
1328 ;;;!!   (while (= (x-mouse-events) 0)
1329 ;;;!!     (setq scrolled-lines (1+ (* scroll-speed scrolled-lines)))
1330 ;;;!!     (scroll-down n)
1331 ;;;!!     (sit-for 300 t)))
1332 ;;;!!
1333 ;;;!! (defun incr-scroll-stop (event)
1334 ;;;!!   (interactive "@e")
1335 ;;;!!   (message "Scrolled %d lines" scrolled-lines)
1336 ;;;!!   (setq scrolled-lines 0)
1337 ;;;!!   (sleep-for 1))
1338 ;;;!!
1339 ;;;!! ;;; (defun x-testing-scroll ()
1340 ;;;!! ;;;   (let ((scrolling-map (function mouse-vertical-scroll-bar-prefix)))
1341 ;;;!! ;;;     (define-key scrolling-map mouse-button-left 'incr-scroll-down)
1342 ;;;!! ;;;     (define-key scrolling-map mouse-button-right 'incr-scroll-up)
1343 ;;;!! ;;;     (define-key scrolling-map mouse-button-left-up 'incr-scroll-stop)
1344 ;;;!! ;;;     (define-key scrolling-map mouse-button-right-up 'incr-scroll-stop)))
1345 ;;;!!
1346 ;;;!! ;;
1347 ;;;!! ;; Some playthings suitable for picture mode?  They need work.
1348 ;;;!! ;;
1349 ;;;!!
1350 ;;;!! (defun mouse-kill-rectangle (event)
1351 ;;;!!   "Kill the rectangle between point and the mouse cursor."
1352 ;;;!!   (interactive "@e")
1353 ;;;!!   (let ((point-save (point)))
1354 ;;;!!     (save-excursion
1355 ;;;!!       (mouse-set-point event)
1356 ;;;!!       (push-mark nil t)
1357 ;;;!!       (if (> point-save (point))
1358 ;;;!!     (kill-rectangle (point) point-save)
1359 ;;;!!   (kill-rectangle point-save (point))))))
1360 ;;;!!
1361 ;;;!! (defun mouse-open-rectangle (event)
1362 ;;;!!   "Kill the rectangle between point and the mouse cursor."
1363 ;;;!!   (interactive "@e")
1364 ;;;!!   (let ((point-save (point)))
1365 ;;;!!     (save-excursion
1366 ;;;!!       (mouse-set-point event)
1367 ;;;!!       (push-mark nil t)
1368 ;;;!!       (if (> point-save (point))
1369 ;;;!!     (open-rectangle (point) point-save)
1370 ;;;!!   (open-rectangle point-save (point))))))
1371 ;;;!!
1372 ;;;!! ;; Must be a better way to do this.
1373 ;;;!!
1374 ;;;!! (defun mouse-multiple-insert (n char)
1375 ;;;!!   (while (> n 0)
1376 ;;;!!     (insert char)
1377 ;;;!!     (setq n (1- n))))
1378 ;;;!!
1379 ;;;!! ;; What this could do is not finalize until button was released.
1380 ;;;!!
1381 ;;;!! (defun mouse-move-text (event)
1382 ;;;!!   "Move text from point to cursor position, inserting spaces."
1383 ;;;!!   (interactive "@e")
1384 ;;;!!   (let* ((relative-coordinate
1385 ;;;!!     (coordinates-in-window-p (car event) (selected-window))))
1386 ;;;!!     (if (consp relative-coordinate)
1387 ;;;!!   (cond ((> (current-column) (car relative-coordinate))
1388 ;;;!!          (delete-char
1389 ;;;!!           (- (car relative-coordinate) (current-column))))
1390 ;;;!!         ((< (current-column) (car relative-coordinate))
1391 ;;;!!          (mouse-multiple-insert
1392 ;;;!!           (- (car relative-coordinate) (current-column)) " "))
1393 ;;;!!         ((= (current-column) (car relative-coordinate)) (ding))))))
1394 \f
1395 ;; Choose a completion with the mouse.
1396
1397 (defun mouse-choose-completion (event)
1398   "Click on an alternative in the `*Completions*' buffer to choose it."
1399   (interactive "e")
1400   ;; Give temporary modes such as isearch a chance to turn off.
1401   (run-hooks 'mouse-leave-buffer-hook)
1402   (let ((buffer (window-buffer))
1403         choice
1404         base-size)
1405     (save-excursion
1406       (set-buffer (window-buffer (posn-window (event-start event))))
1407       (if completion-reference-buffer
1408           (setq buffer completion-reference-buffer))
1409       (setq base-size completion-base-size)
1410       (save-excursion
1411         (goto-char (posn-point (event-start event)))
1412         (let (beg end)
1413           (if (and (not (eobp)) (get-text-property (point) 'mouse-face))
1414               (setq end (point) beg (1+ (point))))
1415           (if (null beg)
1416               (error "No completion here"))
1417           (setq beg (previous-single-property-change beg 'mouse-face))
1418           (setq end (or (next-single-property-change end 'mouse-face)
1419                         (point-max)))
1420           (setq choice (buffer-substring beg end)))))
1421     (let ((owindow (selected-window)))
1422       (select-window (posn-window (event-start event)))
1423       (if (and (one-window-p t 'selected-frame)
1424                (window-dedicated-p (selected-window)))
1425           ;; This is a special buffer's frame
1426           (iconify-frame (selected-frame))
1427         (or (window-dedicated-p (selected-window))
1428             (bury-buffer)))
1429       (select-window owindow))
1430     (choose-completion-string choice buffer base-size)))
1431 \f
1432 ;; Font selection.
1433
1434 (defun font-menu-add-default ()
1435   (let* ((default (cdr (assq 'font (frame-parameters (selected-frame)))))
1436          (font-alist x-fixed-font-alist)
1437          (elt (or (assoc "Misc" font-alist) (nth 1 font-alist))))
1438     (if (assoc "Default" elt)
1439         (delete (assoc "Default" elt) elt))
1440     (setcdr elt
1441             (cons (list "Default"
1442                         (cdr (assq 'font (frame-parameters (selected-frame)))))
1443                   (cdr elt)))))
1444
1445 (defvar x-fixed-font-alist
1446   '("Font menu"
1447     ("Misc"
1448      ;; For these, we specify the pixel height and width.
1449      ("fixed" "fixed")
1450      ("6x10" "-misc-fixed-medium-r-normal--10-*-*-*-c-60-iso8859-1" "6x10")
1451      ("6x12"
1452       "-misc-fixed-medium-r-semicondensed--12-*-*-*-c-60-iso8859-1" "6x12")
1453      ("6x13"
1454       "-misc-fixed-medium-r-semicondensed--13-*-*-*-c-60-iso8859-1" "6x13")
1455      ("7x13" "-misc-fixed-medium-r-normal--13-*-*-*-c-70-iso8859-1" "7x13")
1456      ("7x14" "-misc-fixed-medium-r-normal--14-*-*-*-c-70-iso8859-1" "7x14")
1457      ("8x13" "-misc-fixed-medium-r-normal--13-*-*-*-c-80-iso8859-1" "8x13")
1458      ("9x15" "-misc-fixed-medium-r-normal--15-*-*-*-c-90-iso8859-1" "9x15")
1459      ("10x20" "-misc-fixed-medium-r-normal--20-*-*-*-c-100-iso8859-1" "10x20")
1460      ("11x18" "-misc-fixed-medium-r-normal--18-*-*-*-c-110-iso8859-1" "11x18")
1461      ("12x24" "-misc-fixed-medium-r-normal--24-*-*-*-c-120-iso8859-1" "12x24")
1462      ("")
1463      ("clean 5x8"
1464       "-schumacher-clean-medium-r-normal--8-*-*-*-c-50-iso8859-1")
1465      ("clean 6x8"
1466       "-schumacher-clean-medium-r-normal--8-*-*-*-c-60-iso8859-1")
1467      ("clean 8x8"
1468       "-schumacher-clean-medium-r-normal--8-*-*-*-c-80-iso8859-1")
1469      ("clean 8x10"
1470       "-schumacher-clean-medium-r-normal--10-*-*-*-c-80-iso8859-1")
1471      ("clean 8x14"
1472       "-schumacher-clean-medium-r-normal--14-*-*-*-c-80-iso8859-1")
1473      ("clean 8x16"
1474       "-schumacher-clean-medium-r-normal--16-*-*-*-c-80-iso8859-1")
1475      ("")
1476      ("sony 8x16" "-sony-fixed-medium-r-normal--16-*-*-*-c-80-iso8859-1"))
1477 ;;; We don't seem to have these; who knows what they are.
1478 ;;;    ("fg-18" "fg-18")
1479 ;;;    ("fg-25" "fg-25")
1480 ;;;    ("lucidasanstypewriter-12" "lucidasanstypewriter-12")
1481 ;;;    ("lucidasanstypewriter-bold-14" "lucidasanstypewriter-bold-14")
1482 ;;;    ("lucidasanstypewriter-bold-24" "lucidasanstypewriter-bold-24")
1483 ;;;    ("lucidatypewriter-bold-r-24" "-b&h-lucidatypewriter-bold-r-normal-sans-24-240-75-75-m-140-iso8859-1")
1484 ;;;    ("fixed-medium-20" "-misc-fixed-medium-*-*-*-20-*-*-*-*-*-*-*")
1485     ("Courier"
1486      ;; For these, we specify the point height.
1487      ("8" "-adobe-courier-medium-r-normal--*-80-*-*-m-*-iso8859-1")
1488      ("10" "-adobe-courier-medium-r-normal--*-100-*-*-m-*-iso8859-1")
1489      ("12" "-adobe-courier-medium-r-normal--*-120-*-*-m-*-iso8859-1")
1490      ("14" "-adobe-courier-medium-r-normal--*-140-*-*-m-*-iso8859-1")
1491      ("18" "-adobe-courier-medium-r-normal--*-180-*-*-m-*-iso8859-1")
1492      ("24" "-adobe-courier-medium-r-normal--*-240-*-*-m-*-iso8859-1")
1493      ("8 bold" "-adobe-courier-bold-r-normal--*-80-*-*-m-*-iso8859-1")
1494      ("10 bold" "-adobe-courier-bold-r-normal--*-100-*-*-m-*-iso8859-1")
1495      ("12 bold" "-adobe-courier-bold-r-normal--*-120-*-*-m-*-iso8859-1")
1496      ("14 bold" "-adobe-courier-bold-r-normal--*-140-*-*-m-*-iso8859-1")
1497      ("18 bold" "-adobe-courier-bold-r-normal--*-180-*-*-m-*-iso8859-1")
1498      ("24 bold" "-adobe-courier-bold-r-normal--*-240-*-*-m-*-iso8859-1")
1499      ("8 slant" "-adobe-courier-medium-o-normal--*-80-*-*-m-*-iso8859-1")
1500      ("10 slant" "-adobe-courier-medium-o-normal--*-100-*-*-m-*-iso8859-1")
1501      ("12 slant" "-adobe-courier-medium-o-normal--*-120-*-*-m-*-iso8859-1")
1502      ("14 slant" "-adobe-courier-medium-o-normal--*-140-*-*-m-*-iso8859-1")
1503      ("18 slant" "-adobe-courier-medium-o-normal--*-180-*-*-m-*-iso8859-1")
1504      ("24 slant" "-adobe-courier-medium-o-normal--*-240-*-*-m-*-iso8859-1")
1505      ("8 bold slant" "-adobe-courier-bold-o-normal--*-80-*-*-m-*-iso8859-1")
1506      ("10 bold slant" "-adobe-courier-bold-o-normal--*-100-*-*-m-*-iso8859-1")
1507      ("12 bold slant" "-adobe-courier-bold-o-normal--*-120-*-*-m-*-iso8859-1")
1508      ("14 bold slant" "-adobe-courier-bold-o-normal--*-140-*-*-m-*-iso8859-1")
1509      ("18 bold slant" "-adobe-courier-bold-o-normal--*-180-*-*-m-*-iso8859-1")
1510      ("24 bold slant" "-adobe-courier-bold-o-normal--*-240-*-*-m-*-iso8859-1"))
1511     )
1512   "X fonts suitable for use in Emacs.")
1513
1514 (defun mouse-set-font (&rest fonts)
1515   "Select an emacs font from a list of known good fonts"
1516   (interactive
1517    (x-popup-menu last-nonmenu-event x-fixed-font-alist))
1518   (if fonts
1519       (let (font)
1520         (while fonts
1521           (condition-case nil
1522               (progn
1523                 (set-default-font (car fonts))
1524                 (setq font (car fonts))
1525                 (setq fonts nil))
1526             (error
1527              (setq fonts (cdr fonts)))))
1528         (if (null font)
1529             (error "Font not found")))))
1530 \f
1531 ;;; Bindings for mouse commands.
1532
1533 (define-key global-map [down-mouse-1] 'mouse-drag-region)
1534 (global-set-key [mouse-1]       'mouse-set-point)
1535 (global-set-key [drag-mouse-1]  'mouse-set-region)
1536
1537 ;; These are tested for in mouse-drag-region.
1538 (global-set-key [double-mouse-1] 'mouse-set-point)
1539 (global-set-key [triple-mouse-1] 'mouse-set-point)
1540
1541 (global-set-key [mouse-2]       'mouse-yank-at-click)
1542 (global-set-key [mouse-3]       'mouse-save-then-kill)
1543
1544 ;; By binding these to down-going events, we let the user use the up-going
1545 ;; event to make the selection, saving a click.
1546 (global-set-key [C-down-mouse-1] 'mouse-set-font)
1547 ;; C-down-mouse-2 is bound in facemenu.el.
1548 (global-set-key [C-down-mouse-3] 'mouse-major-mode-menu)
1549
1550
1551 ;; Replaced with dragging mouse-1
1552 ;; (global-set-key [S-mouse-1]  'mouse-set-mark)
1553
1554 (global-set-key [mode-line mouse-1] 'mouse-select-window)
1555 (global-set-key [mode-line drag-mouse-1] 'mouse-select-window)
1556 (global-set-key [mode-line down-mouse-1] 'mouse-drag-mode-line)
1557 (global-set-key [mode-line mouse-2] 'mouse-delete-other-windows)
1558 (global-set-key [mode-line mouse-3] 'mouse-delete-window)
1559 (global-set-key [mode-line C-mouse-2] 'mouse-split-window-horizontally)
1560 (global-set-key [vertical-scroll-bar C-mouse-2] 'mouse-split-window-vertically)
1561 (global-set-key [vertical-line C-mouse-2] 'mouse-split-window-vertically)
1562
1563 (provide 'mouse)
1564
1565 ;;; mouse.el ends here