cgit.sxemacs.org Git - sxemacs/blob - lisp/mouse.el

   1 ;;; mouse.el --- window system-independent mouse support.
   2
   3 ;; Copyright (C) 1988, 1992-4, 1997 Free Software Foundation, Inc.
   4 ;; Copyright (C) 1995 Tinker Systems
   5 ;; Copyright (C) 1995, 1996, 2000 Ben Wing.
   6
   7 ;; Maintainer: SXEmacs Development Team
   8 ;; Keywords: mouse, dumped
   9
  10 ;; This file is part of SXEmacs.
  11
  12 ;; SXEmacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; SXEmacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  24
  25 ;;; Synched up with: Not synched with FSF.  Almost completely divergent.
  26
  27 ;;; Commentary:
  28
  29 ;; This file is dumped with SXEmacs (when window system support is compiled in).
  30
  31 ;;; Authorship:
  32
  33 ;; Probably originally derived from FSF 19 pre-release.
  34 ;; much hacked upon by Jamie Zawinski and crew, pre-1994.
  35 ;;   (only mouse-motion stuff currently remains from that era)
  36 ;; all mouse-track stuff completely rewritten by Ben Wing, 1995-1996.
  37 ;; mouse-eval-sexp and *-inside-extent-p from Stig, 1995.
  38 ;; vertical divider code c. 1998 from ?.
  39
  40 ;;; Code:
  41
  42 (provide 'mouse)
  43
  44 (global-set-key 'button1 'mouse-track)
  45 (global-set-key '(shift button1) 'mouse-track-adjust)
  46 (global-set-key '(control button1) 'mouse-track-insert)
  47 (global-set-key '(control shift button1) 'mouse-track-delete-and-insert)
  48 (global-set-key '(meta button1) 'mouse-track-do-rectangle)
  49 (global-set-key 'button2 'mouse-track)
  50
  51 (defgroup mouse nil
  52   "Window system-independent mouse support."
  53   :group 'editing)
  54
  55 (defcustom mouse-track-rectangle-p nil
  56   "*If true, then dragging out a region with the mouse selects rectangles
  57 instead of simple start/end regions."
  58   :type 'boolean
  59   :group 'mouse)
  60
  61 (defcustom mouse-yank-at-point nil
  62   "*If non-nil, the function `mouse-yank' will yank text at the cursor location.
  63 Otherwise, the cursor will be moved to the location of the pointer click before
  64 text is inserted."
  65   :type 'boolean
  66   :group 'mouse)
  67
  68 (defcustom mouse-highlight-text 'context
  69   "*Choose the default double-click highlighting behavior.
  70 If set to `context', double-click will highlight words when the mouse
  71  is at a word character, or a symbol if the mouse is at a symbol
  72  character.
  73 If set to `word', double-click will always attempt to highlight a word.
  74 If set to `symbol', double-click will always attempt to highlight a
  75  symbol (the default behavior in previous XEmacs versions)."
  76   :type '(choice (const context)
  77                  (const word)
  78                  (const symbol))
  79   :group 'mouse)
  80
  81 (defvar mouse-yank-function 'mouse-consolidated-yank
  82   "Function that is called upon by `mouse-yank' to actually insert text.")
  83
  84 (defun mouse-consolidated-yank ()
  85   "Insert the current selection or, if there is none under X insert
  86 the X cutbuffer.  A mark is pushed, so that the inserted text lies
  87 between point and mark."
  88   (interactive)
  89   (if (and (not (console-on-window-system-p))
  90            (and (featurep 'gpm)
  91                 (not (declare-boundp gpm-minor-mode))))
  92       (yank)
  93     (push-mark)
  94     (if (region-active-p)
  95         (if (consp zmacs-region-extent)
  96             ;; pirated code from insert-rectangle in rect.el
  97             ;; perhaps that code should be modified to handle a list of extents
  98             ;; as the rectangle to be inserted?
  99             (let ((lines zmacs-region-extent)
 100                   (insertcolumn (current-column))
 101                   (first t))
 102               (push-mark)
 103               (while lines
 104                 (or first
 105                     (progn
 106                       (forward-line 1)
 107                       (or (bolp) (insert ?\n))
 108                       (move-to-column insertcolumn t)))
 109                 (setq first nil)
 110                 (insert (extent-string (car lines)))
 111                 (setq lines (cdr lines))))
 112           (insert (extent-string zmacs-region-extent)))
 113       (insert-selection t))))
 114
 115 (defun insert-selection (&optional check-cutbuffer-p move-point-event)
 116   "Insert the current selection into buffer at point."
 117   (interactive "P")
 118   ;; we fallback to the clipboard if the current selection is not existent
 119   (let ((text (or (get-selection-no-error 'PRIMARY   'UTF8_STRING)
 120                   (get-selection-no-error 'PRIMARY   'STRING)
 121                   (and check-cutbuffer-p (get-cutbuffer))
 122                   (get-selection-no-error 'CLIPBOARD 'UTF8_STRING)
 123                   (get-selection-no-error 'CLIPBOARD 'STRING)
 124                   (error "no selection: PRIMARY or CLIPBOARD")
 125                   )))
 126     (cond (move-point-event
 127            (mouse-set-point move-point-event)
 128            (push-mark (point)))
 129           ((interactive-p)
 130            (push-mark (point))))
 131     (insert text)
 132     ))
 133
 134 \f
 135 (defun mouse-select ()
 136   "Select Emacs window the mouse is on."
 137   (interactive "@"))
 138
 139 (defun mouse-delete-window ()
 140   "Delete the Emacs window the mouse is on."
 141   (interactive "@")
 142   (delete-window))
 143
 144 (defun mouse-keep-one-window ()
 145   "Select Emacs window mouse is on, then kill all other Emacs windows."
 146   (interactive "@")
 147   (delete-other-windows))
 148
 149 (defun mouse-select-and-split ()
 150   "Select Emacs window mouse is on, then split it vertically in half."
 151   (interactive "@")
 152   (split-window-vertically nil))
 153
 154 (defun mouse-set-point (event)
 155   "Select Emacs window mouse is on, and move point to mouse position."
 156   (interactive "@e")
 157   (let ((window (event-window event))
 158         (pos (event-point event))
 159         (close-pos (event-closest-point event)))
 160     (or window (error "not in a window"))
 161     (select-window window)
 162     (if (and pos (> pos 0))
 163         ;; If the event was over a text char, it's easy.
 164         (goto-char (max (min pos (point-max)) (point-min)))
 165       (if (and close-pos (> close-pos 0))
 166           (goto-char (max (min close-pos (point-max)) (point-min)))
 167         ;; When the event occurs outside of the frame directly to the
 168         ;; left or right of a modeline, close-point is nil, but
 169         ;; event-over-modeline is also nil.  That will drop us to this
 170         ;; point.  So instead of erroring, just return nil.
 171         nil))))
 172
 173 (defun mouse-yank (event)
 174   "Paste text with the mouse.
 175 If the variable `mouse-yank-at-point' is nil, then pasting occurs at the
 176 location of the click; otherwise, pasting occurs at the current cursor
 177 location."
 178   (interactive "e")
 179   (and (not mouse-yank-at-point)
 180        (mouse-set-point event))
 181   (funcall mouse-yank-function))
 182
 183 (defun click-inside-extent-p (click extent)
 184   "Return non-nil if the button event is within the primary selection-extent.
 185 Return nil otherwise."
 186   (let ((ewin (event-window click))
 187         (epnt (event-point click)))
 188     (and ewin
 189          epnt
 190          extent
 191          (eq (window-buffer ewin)
 192              (extent-object extent))
 193          (extent-start-position extent)
 194          (> epnt (extent-start-position extent))
 195          (> (extent-end-position extent) epnt))))
 196
 197 (defun click-inside-selection-p (click)
 198   (or (click-inside-extent-p click primary-selection-extent)
 199       (click-inside-extent-p click zmacs-region-extent)
 200       ))
 201
 202 (defun point-inside-extent-p (extent)
 203   "Return t if point is within the bounds of the primary selection extent.
 204 Return t is point is at the end position of the extent.
 205 Return nil otherwise."
 206   (and extent
 207        (eq (current-buffer)
 208            (extent-object extent))
 209        (> (point) (extent-start-position extent))
 210        (>= (extent-end-position extent) (point))))
 211
 212 (defun point-inside-selection-p ()
 213   (or (point-inside-extent-p primary-selection-extent)
 214       (point-inside-extent-p zmacs-region-extent)))
 215
 216 (defun mouse-eval-sexp (click force-window)
 217   "Evaluate the sexp under the mouse.  Usually, this is the last sexp before
 218 the click, but if you click on a left paren, then it is the sexp beginning
 219 with the paren that is evaluated.  Also, since strings evaluate to themselves,
 220 they're fed to `re-search-forward' and the matched region is highlighted until
 221 the mouse button is released.
 222
 223 Perhaps the most useful thing about this function is that the evaluation of
 224 the expression which is clicked upon is relative not to the window where you
 225 click, but to the current window and the current position of point.  Thus,
 226 you can use `mouse-eval-sexp' to interactively test code that acts upon a
 227 buffer...something you cannot do with the standard `eval-last-sexp' function.
 228 It's also fantastic for debugging regular expressions."
 229   (interactive "e\nP")
 230   (let (exp val result-str)
 231     (setq exp (save-window-excursion
 232                 (save-excursion
 233                   (mouse-set-point click)
 234                   (save-excursion
 235                     (or (looking-at "(") (forward-sexp -1))
 236                     (read (point-marker))))))
 237     (cond ((stringp exp)
 238            (if (setq val (re-search-forward exp nil t))
 239                (let* ((oo (make-extent (match-beginning 0) (match-end 0))))
 240                  (set-extent-face oo 'highlight)
 241                  (set-extent-priority oo 1000)
 242                  ;; wait for button release...
 243                  (setq unread-command-event (next-command-event))
 244                  (delete-extent oo))
 245              (message "Regex \"%s\" not found" exp)
 246              (ding nil 'quiet)))
 247           (t (setq val (if (fboundp 'eval-interactive)
 248                            (eval-interactive exp)
 249                          (eval exp)))))
 250     (setq result-str (prin1-to-string val))
 251     ;; #### -- need better test
 252     (if (and (not force-window)
 253              (<= (length result-str) (window-width (selected-window))))
 254         (message "%s" result-str)
 255       (with-output-to-temp-buffer "*Mouse-Eval*"
 256         (condition-case nil
 257             (declare-fboundp (pprint val))
 258           (error (prin1 val))))
 259       )))
 260
 261 (defun mouse-line-length (event)
 262   "Print the length of the line indicated by the pointer."
 263   (interactive "@e")
 264   (save-excursion
 265     (mouse-set-point event)
 266     (message "Line length: %d" (- (point-at-eol) (point-at-bol))))
 267   (sleep-for 1))
 268
 269 (defun mouse-set-mark (event)
 270   "Select Emacs window mouse is on, and set mark at mouse position.
 271 Display cursor at that position for a second."
 272   (interactive "@e")
 273   (let ((point-save (point)))
 274     (unwind-protect
 275         (progn (mouse-set-point event)
 276                (push-mark nil t)
 277                (sit-for 1))
 278       (goto-char point-save))))
 279
 280 (defun mouse-scroll (event)
 281   "Scroll point to the mouse position."
 282   (interactive "@e")
 283   (save-excursion
 284     (mouse-set-point event)
 285     (recenter 0)
 286     (scroll-right (event-x event))))
 287
 288 (defun mouse-del-char (event)
 289   "Delete the char pointed to by the mouse."
 290   (interactive "@e")
 291   (save-excursion
 292     (mouse-set-point event)
 293     (delete-char 1 nil)))
 294
 295 (defun mouse-kill-line (event)
 296   "Kill the line pointed to by the mouse."
 297   (interactive "@e")
 298   (save-excursion
 299     (mouse-set-point event)
 300     (kill-line nil)))
 301
 302 (defun mouse-bury-buffer (event)
 303   "Bury the buffer pointed to by the mouse, thus selecting the next one."
 304   (interactive "e")
 305   (save-selected-window
 306     (select-window (event-window event))
 307     (bury-buffer)))
 308
 309 (defun mouse-unbury-buffer (event)
 310   "Unbury and select the most recently buried buffer."
 311   (interactive "e")
 312   (save-selected-window
 313     (select-window (event-window event))
 314     (let* ((bufs (buffer-list))
 315            (entry (1- (length bufs)))
 316            val)
 317       (while (not (setq val (nth entry bufs)
 318                         val (and (/= (aref (buffer-name val) 0)
 319                                      ? )
 320                                  val)))
 321         (setq entry (1- entry)))
 322       (switch-to-buffer val))))
 323
 324 (defun narrow-window-to-region (m n)
 325   "Narrow window to region between point and last mark."
 326   (interactive "r")
 327   (save-excursion
 328     (save-restriction
 329       (if (eq (selected-window) (next-window))
 330           (split-window))
 331       (goto-char m)
 332       (recenter 0)
 333       (if (eq (selected-window)
 334               (if (zerop (minibuffer-depth))
 335                   (next-window)))
 336           ()
 337         (shrink-window (- (- (window-height) (count-lines m n)) 1))))))
 338
 339 (defun mouse-window-to-region (event)
 340   "Narrow window to region between cursor and mouse pointer."
 341   (interactive "@e")
 342   (let ((point-save (point)))
 343     (unwind-protect
 344         (progn (mouse-set-point event)
 345                (push-mark nil t)
 346                (sit-for 1))
 347       (goto-char point-save)
 348       (narrow-window-to-region (region-beginning) (region-end)))))
 349
 350 (defun mouse-ignore ()
 351   "Don't do anything."
 352   (interactive))
 353
 354 \f
 355 ;;; mouse/selection tracking
 356 ;;; generalized mouse-track
 357
 358 (defvar default-mouse-track-normalize-point-function
 359   'default-mouse-track-normalize-point
 360   "Function called to normalize position of point.
 361 Called with two arguments: TYPE depends on the number of times that the
 362 mouse has been clicked and is a member of `default-mouse-track-type-list',
 363 FORWARDP determines the direction in which the point should be moved.")
 364
 365 (defvar mouse-track-down-hook nil
 366   "Function or functions called when the user presses the mouse.
 367 This hook is invoked by `mouse-track'; thus, it will not be called
 368 for any buttons with a different binding.  The functions will be
 369 called with two arguments: the button-press event and a click
 370 count (see `mouse-track-click-hook').
 371
 372 If any function returns non-nil, the remaining functions will not be
 373 called.
 374
 375 Note that most applications should take action when the mouse is
 376 released, not when it is pressed.'")
 377
 378 (defvar mouse-track-drag-hook nil
 379   "Function or functions called when the user drags the mouse.
 380 This hook is invoked by `mouse-track'; thus, it will not be called
 381 for any buttons with a different binding.  The functions will be
 382 called with three arguments: the mouse-motion event, a click
 383 count (see `mouse-track-click-hook'), and whether the call to
 384 this hook occurred as a result of a drag timeout (see
 385 `mouse-track-scroll-delay').
 386
 387 If any function returns non-nil, the remaining functions will not be
 388 called.
 389
 390 Note that no calls to this function will be made until the user
 391 initiates a drag (i.e. moves the mouse more than a certain
 392 threshold in either the X or the Y direction, as defined by
 393 `mouse-track-x-threshold' and `mouse-track-y-threshold').
 394
 395 See also `mouse-track-drag-up-hook'.")
 396
 397 (defvar mouse-track-drag-up-hook nil
 398   "Function or functions called when the user finishes a drag.
 399 This hook is invoked by `mouse-track'; thus, it will not be called
 400 for any buttons with a different binding.  The functions will be
 401 called with two arguments: the button-press event and a click
 402 count (see `mouse-track-click-hook').
 403
 404 If any function returns non-nil, the remaining functions will not be
 405 called.
 406
 407 Note that this hook will not be invoked unless the user has
 408 initiated a drag, i.e. moved the mouse more than a certain threshold
 409 (see `mouse-track-drag-hook').  When this function is invoked,
 410 `mouse-track-drag-hook' will have been invoked at least once.
 411
 412 See also `mouse-track-click-hook'.")
 413
 414 (defvar mouse-track-click-hook nil
 415   "Function or functions called when the user clicks the mouse.
 416 `Clicking' means pressing and releasing the mouse without having
 417 initiated a drag (i.e. without having moved more than a certain
 418 threshold -- see `mouse-track-drag-hook').
 419
 420 This hook is invoked by `mouse-track'; thus, it will not be called
 421 for any buttons with a different binding.  The functions will be
 422 called with two arguments: the button-release event and a click
 423 count, which specifies the number of times that the mouse has been
 424 clicked in a series of clicks, each of which is separated by at most
 425 `mouse-track-multi-click-time'.  This can be used to implement actions
 426 that are called on double clicks, triple clicks, etc.
 427
 428 If any function returns non-nil, the remaining functions will not be
 429 called.
 430
 431 See also `mouse-track-drag-up-hook.")
 432
 433 (defvar mouse-track-up-hook nil
 434   "Function or functions called when the user releases the mouse.
 435 This hook is invoked by `mouse-track'; thus, it will not be called
 436 for any buttons with a different binding.  The functions will be
 437 called with two arguments: the button-release event and a click
 438 count (see `mouse-track-click-hook').
 439
 440 For many applications, it is more appropriate to use one or both
 441 of `mouse-track-click-hook' and `mouse-track-drag-up-hook'.")
 442
 443 (defvar mouse-track-cleanup-hook nil
 444   "Function or functions called when `mouse-track' terminates.
 445 This hook will be called in all circumstances, even upon a
 446 non-local exit out of `mouse-track', and so is useful for
 447 doing cleanup work such as removing extents that may have
 448 been created during the operation of `mouse-track'.
 449
 450 Unlike all of the other mouse-track hooks, this is a \"normal\"
 451 hook: the hook functions are called with no arguments, and
 452 all hook functions are called regardless of their return
 453 values.
 454
 455 This function is called with the buffer where the mouse was clicked
 456 set to the current buffer, unless that buffer was killed.")
 457
 458 (defcustom mouse-track-multi-click-time 400
 459   "*Maximum number of milliseconds allowed between clicks for a multi-click.
 460 See `mouse-track-click-hook'."
 461   :type 'integer
 462   :group 'mouse)
 463
 464 (defcustom mouse-track-scroll-delay 100
 465   "Maximum of milliseconds between calls to `mouse-track-drag-hook'.
 466 If the user is dragging the mouse (i.e. the button is held down and
 467 a drag has been initiated) and does not move the mouse for this many
 468 milliseconds, the hook will be called with t as the value of the
 469 WAS-TIMEOUT parameter.  This can be used to implement scrolling
 470 in a selection when the user drags the mouse out the window it
 471 was in.
 472
 473 A value of nil disables the timeout feature."
 474   :type '(choice integer (const :tag "Disabled" nil))
 475   :group 'mouse)
 476
 477 (defcustom mouse-track-activate-strokes '(button1-double-click button2-click)
 478   "List of mouse strokes that can cause \"activation\" of the text extent
 479 under the mouse.  The exact meaning of \"activation\" is dependent on the
 480 text clicked on and the mode of the buffer, but typically entails actions
 481 such as following a hyperlink or selecting an entry in a completion buffer.
 482
 483 Possible list entries are
 484
 485 button1-click
 486 button1-double-click
 487 button1-triple-click
 488 button1-down
 489 button2-click
 490 button2-double-click
 491 button2-triple-click
 492 button2-down
 493
 494 As a general rule, you should not use the \"-down\" values, because this
 495 makes it impossible to have other simultaneous actions, such as selection."
 496   :type '(set
 497           button1-click
 498           button1-double-click
 499           button1-triple-click
 500           button1-down
 501           button2-click
 502           button2-double-click
 503           button2-triple-click
 504           button2-down)
 505   :group 'mouse)
 506
 507 (defvar mouse-track-x-threshold '(face-width 'default)
 508   "Minimum number of pixels in the X direction for a drag to be initiated.
 509 If the mouse is moved more than either the X or Y threshold while the
 510 button is held down (see also `mouse-track-y-threshold'), then a drag
 511 is initiated; otherwise the gesture is considered to be a click.
 512 See `mouse-track'.
 513
 514 The value should be either a number or a form to be evaluated to
 515 produce a number.")
 516
 517 (defvar mouse-track-y-threshold '(face-height 'default)
 518   "Minimum number of pixels in the Y direction for a drag to be initiated.
 519 If the mouse is moved more than either the X or Y threshold while the
 520 button is held down (see also `mouse-track-x-threshold'), then a drag
 521 is initiated; otherwise the gesture is considered to be a click.
 522 See `mouse-track'.
 523
 524 The value should be either a number of a form to be evaluated to
 525 produce a number.")
 526
 527 ;; these variables are private to mouse-track.
 528 (defvar mouse-track-up-time nil)
 529 (defvar mouse-track-up-x nil)
 530 (defvar mouse-track-up-y nil)
 531 (defvar mouse-track-timeout-id nil)
 532 (defvar mouse-track-click-count nil)
 533
 534 (defun mouse-track-set-timeout (event)
 535   (if mouse-track-timeout-id
 536       (disable-timeout mouse-track-timeout-id))
 537   (if mouse-track-scroll-delay
 538       (setq mouse-track-timeout-id
 539             (add-timeout (/ mouse-track-scroll-delay 1000.0)
 540                          'mouse-track-scroll-undefined
 541                          (copy-event event)))))
 542
 543 (defun mouse-track-do-activate (event)
 544   "Execute the activate function under EVENT, if any.
 545 Return true if the function was activated."
 546   (let ((ex (extent-at-event event 'activate-function)))
 547     (when ex
 548       (funcall (extent-property ex 'activate-function)
 549                event ex)
 550       t)))
 551
 552 (defvar Mouse-track-gensym (gensym))
 553
 554 (defun mouse-track-run-hook (hook override event &rest args)
 555   ;; ugh, can't use run-hook-with-args-until-success because we have
 556   ;; to get the value using symbol-value-in-buffer.  Doing a
 557   ;; save-excursion/set-buffer is wrong because the hook might want to
 558   ;; change the buffer, but just doing a set-buffer is wrong because
 559   ;; the hook might not want to change the buffer.
 560   ;; #### What we need here is a Lisp interface to
 561   ;; run_hook_with_args_in_buffer.  Here is a poor man's version.
 562   (let ((overridden (plist-get override hook Mouse-track-gensym)))
 563     (if (not (eq overridden Mouse-track-gensym))
 564         (if (and (listp overridden) (not (eq (car overridden) 'lambda)))
 565             (some #'(lambda (val) (apply val event args)) overridden)
 566           (apply overridden event args))
 567       (let ((buffer (event-buffer event)))
 568         (and mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
 569         (when buffer
 570           (let ((value (symbol-value-in-buffer hook buffer nil)))
 571             (if (and (listp value) (not (eq (car value) 'lambda)))
 572                 ;; List of functions.
 573                 (let (retval)
 574                   (while (and value (null retval))
 575                     ;; Found `t': should process default value.  We could
 576                     ;; splice it into the buffer-local value, but that
 577                     ;; would cons, which is not a good thing for
 578                     ;; mouse-track hooks.
 579                     (if (eq (car value) t)
 580                         (let ((global (default-value hook)))
 581                           (if (and (listp global) (not (eq (car global)
 582                                                            'lambda)))
 583                               ;; List of functions.
 584                               (while (and global
 585                                           (null (setq retval
 586                                                       (apply (car global)
 587                                                              event args))))
 588                                 (pop global))
 589                             ;; lambda
 590                             (setq retval (apply (car global) event args))))
 591                       (setq retval (apply (car value) event args)))
 592                     (pop value))
 593                   retval)
 594               ;; lambda
 595               (apply value event args))))))))
 596
 597 (defun mouse-track-scroll-undefined (random)
 598   ;; the old implementation didn't actually define this function,
 599   ;; and in normal use it won't ever be called because the timeout
 600   ;; will either be removed before it fires or will be picked off
 601   ;; with next-event and not dispatched.  However, if you're
 602   ;; attempting to debug a click-hook (which is pretty damn
 603   ;; difficult to do), this function may get called.
 604 )
 605
 606 (defun mouse-track (event &optional overriding-hooks)
 607   "Generalized mouse-button handler.  This should be bound to a mouse button.
 608 The behavior of this function is customizable using various hooks and
 609 variables: see `mouse-track-click-hook', `mouse-track-drag-hook',
 610 `mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook',
 611 `mouse-track-cleanup-hook', `mouse-track-multi-click-time',
 612 `mouse-track-scroll-delay', `mouse-track-x-threshold', and
 613 `mouse-track-y-threshold'.
 614
 615 Default handlers are provided to implement standard selecting/positioning
 616 behavior.  You can explicitly request this default behavior, and override
 617 any custom-supplied handlers, by using the function `mouse-track-default'
 618 instead of `mouse-track'.
 619
 620 \(In general, you can override specific hooks by using the argument
 621 OVERRIDING-HOOKS, which should be a plist of alternating hook names
 622 and values.)
 623
 624 Default behavior is as follows:
 625
 626 If you click-and-drag, the selection will be set to the region between the
 627 point of the initial click and the point at which you release the button.
 628 These positions need not be ordered.
 629
 630 If you click-and-release without moving the mouse, then the point is moved
 631 and the selection is disowned (there will be no selection owner).  The mark
 632 will be set to the previous position of point.
 633
 634 If you double-click, the selection will extend by symbols instead of by
 635 characters.  If you triple-click, the selection will extend by lines.
 636
 637 If you drag the mouse off the top or bottom of the window, you can select
 638 pieces of text which are larger than the visible part of the buffer; the
 639 buffer will scroll as necessary.
 640
 641 The selected text becomes the current X Selection.  The point will be left
 642 at the position at which you released the button, and the mark will be left
 643 at the initial click position."
 644   (interactive "e")
 645   (let ((mouse-down t)
 646         (xthresh (eval mouse-track-x-threshold))
 647         (ythresh (eval mouse-track-y-threshold))
 648         (orig-x (event-x-pixel event))
 649         (orig-y (event-y-pixel event))
 650         (buffer (event-buffer event))
 651         (mouse-grabbed-buffer (event-buffer event))
 652         mouse-moved)
 653     (if (or (not mouse-track-up-x)
 654             (not mouse-track-up-y)
 655             (not mouse-track-up-time)
 656             (> (- (event-timestamp event) mouse-track-up-time)
 657                mouse-track-multi-click-time)
 658             (> (abs (- mouse-track-up-x orig-x)) xthresh)
 659             (> (abs (- mouse-track-up-y orig-y)) ythresh))
 660         (setq mouse-track-click-count 1)
 661       (setq mouse-track-click-count (1+ mouse-track-click-count)))
 662     (if (not (event-window event))
 663         (error "Not over a window."))
 664     (mouse-track-run-hook 'mouse-track-down-hook overriding-hooks
 665                           event mouse-track-click-count)
 666     (unwind-protect
 667         (while mouse-down
 668           (setq event (next-event event))
 669           (cond ((motion-event-p event)
 670                  (if (and (not mouse-moved)
 671                           (or (> (abs (- (event-x-pixel event) orig-x))
 672                                  xthresh)
 673                               (> (abs (- (event-y-pixel event) orig-y))
 674                                  ythresh)))
 675                      (setq mouse-moved t))
 676                  (if mouse-moved
 677                      (mouse-track-run-hook 'mouse-track-drag-hook
 678                                            overriding-hooks
 679                                            event mouse-track-click-count nil))
 680                  (mouse-track-set-timeout event))
 681                 ((and (timeout-event-p event)
 682                       (eq (event-function event)
 683                           'mouse-track-scroll-undefined))
 684                  (if mouse-moved
 685                      (mouse-track-run-hook 'mouse-track-drag-hook
 686                                            overriding-hooks
 687                                            (event-object event)
 688                                            mouse-track-click-count t))
 689                  (mouse-track-set-timeout (event-object event)))
 690                 ((button-release-event-p event)
 691                  (setq mouse-track-up-time (event-timestamp event))
 692                  (setq mouse-track-up-x (event-x-pixel event))
 693                  (setq mouse-track-up-y (event-y-pixel event))
 694                  (setq mouse-down nil)
 695                  (mouse-track-run-hook 'mouse-track-up-hook
 696                                        overriding-hooks
 697                                        event mouse-track-click-count)
 698                  (if mouse-moved
 699                      (mouse-track-run-hook 'mouse-track-drag-up-hook
 700                                            overriding-hooks
 701                                            event mouse-track-click-count)
 702                    (mouse-track-run-hook 'mouse-track-click-hook
 703                                          overriding-hooks
 704                                          event mouse-track-click-count)))
 705                 ((or (key-press-event-p event)
 706                      (and (misc-user-event-p event)
 707                           (eq (event-function event) 'cancel-mode-internal)))
 708                  (error "Selection aborted"))
 709                 (t
 710                  (dispatch-event event))))
 711       ;; protected
 712       (if mouse-track-timeout-id
 713           (disable-timeout mouse-track-timeout-id))
 714       (setq mouse-track-timeout-id nil)
 715       (and (buffer-live-p buffer)
 716            (save-excursion
 717              (set-buffer buffer)
 718              (let ((override (plist-get overriding-hooks
 719                                         'mouse-track-cleanup-hook
 720                                         Mouse-track-gensym)))
 721                (if (not (eq override Mouse-track-gensym))
 722                    (if (and (listp override) (not (eq (car override) 'lambda)))
 723                        (mapc #'funcall override)
 724                      (funcall override))
 725                  (run-hooks 'mouse-track-cleanup-hook))))))))
 726
 727 \f
 728 ;;;;;;;;;;;; default handlers: new version of mouse-track
 729
 730 (defvar default-mouse-track-type nil)
 731 (defvar default-mouse-track-type-list '(char word line))
 732 (defvar default-mouse-track-window nil)
 733 (defvar default-mouse-track-extent nil)
 734 (defvar default-mouse-track-adjust nil)
 735 (defvar default-mouse-track-min-anchor nil)
 736 (defvar default-mouse-track-max-anchor nil)
 737 (defvar default-mouse-track-result nil)
 738 (defvar default-mouse-track-down-event nil)
 739
 740 ;; D. Verna Feb. 17 1998
 741 ;; This function used to assume that when (event-window event) differs from
 742 ;; window, we have to scroll. This is WRONG, for instance when there are
 743 ;; toolbars on the side, in which case window-event returns nil.
 744 (defun default-mouse-track-set-point-in-window (event window)
 745   (if (event-over-modeline-p event)
 746       nil ;; Scroll
 747     ;; Not over a modeline
 748     (if (eq (event-window event) window)
 749         (let ((p (event-closest-point event)))
 750           (if  (or (not p) (not (pos-visible-in-window-p p window)))
 751               nil ;; Scroll
 752             (mouse-set-point event)
 753             t))
 754       ;; Not over a modeline, not the same window. Check if the Y position
 755       ;; is still overlapping the original window.
 756       (let* ((edges (window-pixel-edges window))
 757              (row (event-y-pixel event))
 758              (text-start (nth 1 edges))
 759              (text-end (nth 3 edges)))
 760         (if (or (< row text-start)
 761                 (> row text-end))
 762             nil ;; Scroll
 763           ;; The Y pos in overlapping the original window. Check however if
 764           ;; the position is really visible, because there could be a
 765           ;; scrollbar or a modeline at this place.
 766           ;; Find the mean line height (height / lines nb), and approximate
 767           ;; the line number for Y pos.
 768           (select-window window)
 769           (let ((line (/ (* (- row text-start) (window-height))
 770                          (- text-end text-start))))
 771             (if (not (save-excursion
 772                        (goto-char (window-start))
 773                        (pos-visible-in-window-p
 774                         (point-at-bol (+ 1 line)))))
 775                 nil ;; Scroll
 776               ;; OK, we can go to that position
 777               (goto-char (window-start))
 778               (forward-line line)
 779               ;; On the right side: go to end-of-line.
 780               (when (>= (event-x-pixel event) (nth 2 edges))
 781                 (goto-char (point-at-eol)))
 782               t))))
 783       )))
 784
 785
 786 (defun default-mouse-track-scroll-and-set-point (event window)
 787   (select-window window)
 788   (let ((edges (window-pixel-edges window))
 789         (row (event-y-pixel event))
 790         (height (face-height 'default)))
 791     (cond ((< (abs (- row (nth 1 edges))) (abs (- row (nth 3 edges))))
 792            ;; closer to window's top than to bottom, so move up
 793            (let ((delta (max 1 (/ (- (nth 1 edges) row) height))))
 794              (condition-case () (scroll-down delta) (error))
 795              (goto-char (window-start))))
 796           ((>= (point) (point-max)))
 797           (t
 798            ;; scroll by one line if over the modeline or a clipped line
 799            (let ((delta (if (or (event-over-modeline-p event)
 800                                 (< row (nth 3 edges)))
 801                             1
 802                           (+ (/ (- row (nth 3 edges)) height) 1)))
 803                  (close-pos (event-closest-point event)))
 804              (condition-case () (scroll-up delta) (error))
 805              (if (and close-pos (pos-visible-in-window-p close-pos))
 806                  (goto-char close-pos)
 807                (goto-char (window-end))
 808                (vertical-motion delta)
 809                ;; window-end reports the end of the clipped line, even if
 810                ;; scroll-on-clipped-lines is t.  compensate.
 811                ;; (If window-end gets fixed this can be removed.)
 812                (if (not (pos-visible-in-window-p (max (1- (point))
 813                                                       (point-min))))
 814                    (vertical-motion -1))
 815                (condition-case () (backward-char 1)
 816                  (error (end-of-line)))))))))
 817
 818
 819 ;; This remembers the last position at which the user clicked, for the
 820 ;; benefit of mouse-track-adjust (for example, button1; scroll until the
 821 ;; position of the click is off the frame; then Sh-button1 to select the
 822 ;; new region.
 823 (defvar default-mouse-track-previous-point nil)
 824
 825 (defun default-mouse-track-set-point (event window)
 826   (if (default-mouse-track-set-point-in-window event window)
 827       nil
 828     (default-mouse-track-scroll-and-set-point event window)))
 829
 830 (defsubst default-mouse-track-beginning-of-word (symbolp)
 831   (let ((word-constituent (cond ((eq symbolp t) #r"\w\|\s_\|\s'")
 832                                 ((null symbolp) "\\w")
 833                                 (t "[^ \t\n]")))
 834         (white-space "[ \t]"))
 835     (cond ((bobp) nil)
 836           ((looking-at word-constituent)
 837            (backward-char)
 838            (while (and (not (bobp)) (looking-at word-constituent))
 839              (backward-char))
 840            (if (or (not (bobp)) (not (looking-at word-constituent)))
 841                (forward-char)))
 842           ((looking-at white-space)
 843            (backward-char)
 844            (while (looking-at white-space)
 845              (backward-char))
 846            (forward-char)))))
 847
 848 (defun default-mouse-track-end-of-word (symbolp)
 849   (let ((word-constituent (cond ((eq symbolp t) #r"\w\|\s_\|\s'")
 850                                 ((null symbolp) "\\w")
 851                                 (t "[^ \t\n]")))
 852         (white-space "[ \t]"))
 853     (cond ((looking-at word-constituent) ; word or symbol constituent
 854            (while (looking-at word-constituent)
 855              (forward-char)))
 856           ((looking-at white-space) ; word or symbol constituent
 857            (while (looking-at white-space)
 858              (forward-char))))))
 859
 860 ;; Decide what will be the SYMBOLP argument to
 861 ;; default-mouse-track-{beginning,end}-of-word, according to the
 862 ;; syntax of the current character and value of mouse-highlight-text.
 863 (defsubst default-mouse-track-symbolp (syntax)
 864   (cond ((eq mouse-highlight-text 'context)
 865          (eq syntax ?_))
 866         ((eq mouse-highlight-text 'symbol)
 867          t)
 868         (t
 869          nil)))
 870
 871 ;; Return t if point is at an opening quote character.  This is
 872 ;; determined by testing whether the syntax of the following character
 873 ;; is `string', which will always be true for opening quotes and
 874 ;; always false for closing quotes.
 875 (defun default-mouse-track-point-at-opening-quote-p ()
 876   (save-excursion
 877     (forward-char 1)
 878     (eq (buffer-syntactic-context) 'string)))
 879
 880 (defun default-mouse-track-normalize-point (type forwardp)
 881   (cond ((eq type 'word)
 882          ;; trap the beginning and end of buffer errors
 883          (ignore-errors
 884            (setq type (char-syntax (char-after (point))))
 885            (if forwardp
 886                (if (or (= type ?\()
 887                        (and (= type ?\")
 888                             (default-mouse-track-point-at-opening-quote-p)))
 889                    (goto-char (scan-sexps (point) 1))
 890                  (default-mouse-track-end-of-word
 891                    (default-mouse-track-symbolp type)))
 892              (if (or (= type ?\))
 893                      (and (= type ?\")
 894                           (not (default-mouse-track-point-at-opening-quote-p))))
 895                  (goto-char (scan-sexps (1+ (point)) -1))
 896                (default-mouse-track-beginning-of-word
 897                  (default-mouse-track-symbolp type))))))
 898         ((eq type 'line)
 899          (if forwardp (end-of-line) (beginning-of-line)))
 900         ((eq type 'buffer)
 901          (if forwardp (end-of-buffer) (beginning-of-buffer)))))
 902
 903 (defun default-mouse-track-next-move (min-anchor max-anchor extent)
 904   (let ((anchor (if (<= (point) min-anchor) max-anchor min-anchor)))
 905     (funcall default-mouse-track-normalize-point-function
 906              default-mouse-track-type (> (point) anchor))
 907     (if (consp extent)
 908         (default-mouse-track-next-move-rect anchor (point) extent)
 909       (if extent
 910           (if (<= anchor (point))
 911               (set-extent-endpoints extent anchor (point))
 912             (set-extent-endpoints extent (point) anchor))))))
 913
 914 (defun default-mouse-track-next-move-rect (start end extents &optional pad-p)
 915   (if (< end start)
 916       (let ((tmp start)) (setq start end end tmp)))
 917   (cond
 918    ((= start end)               ; never delete the last remaining extent
 919     (mapcar 'delete-extent (cdr extents))
 920     (setcdr extents nil)
 921     (set-extent-endpoints (car extents) start start))
 922    (t
 923     (let ((indent-tabs-mode nil)        ; if pad-p, don't use tabs
 924           (rest extents)
 925           left right last p)
 926       (save-excursion
 927         (save-restriction
 928           (goto-char end)
 929           (setq right (current-column))
 930           (goto-char start)
 931           (setq left (current-column))
 932           (if (< right left)
 933               (let ((tmp left))
 934                 (setq left right right tmp)
 935                 (setq start (- start (- right left))
 936                       end (+ end (- right left)))))
 937           ;; End may have been set to a value greater than point-max if drag
 938           ;; or movement extends to end of buffer, so reset it.
 939           (setq end (min end (point-max)))
 940           (beginning-of-line)
 941           (narrow-to-region (point) end)
 942           (goto-char start)
 943           (while (and rest (not (eobp)))
 944             (setq p (point))
 945             (move-to-column right pad-p)
 946             (set-extent-endpoints (car rest) p (point))
 947             ;; this code used to look at the return value
 948             ;; of forward-line, but that doesn't work because
 949             ;; forward-line has bogus behavior: If you're on
 950             ;; the last line of a buffer but not at the very
 951             ;; end, forward-line will move you to the very
 952             ;; end and return 0 instead of 1, like it should.
 953             ;; the result was frequent infinite loops here,
 954             ;; creating very large numbers of extents at
 955             ;; the same position.  There was an N^2 sorting
 956             ;; algorithm in extents.c for extents at a
 957             ;; particular position, and the result was very
 958             ;; bad news.
 959             (forward-line 1)
 960             (if (not (eobp))
 961                 (move-to-column left pad-p))
 962             (setq last rest
 963                   rest (cdr rest)))
 964           (cond (rest
 965                  (mapcar 'delete-extent rest)
 966                  (setcdr last nil))
 967                 ((not (eobp))
 968                  (while (not (eobp))
 969                    (setq p (point))
 970                    (move-to-column right pad-p)
 971                    (let ((e (make-extent p (point))))
 972                      (set-extent-face e (extent-face (car extents)))
 973                      (set-extent-priority e (extent-priority (car extents)))
 974                      (setcdr last (cons e nil))
 975                      (setq last (cdr last)))
 976                    (forward-line 1)
 977                    (if (not (eobp))
 978                        (move-to-column left pad-p))
 979                    )))))
 980       ))))
 981
 982 (defun default-mouse-track-has-selection-p (buffer)
 983   (and (selection-owner-p)
 984        (extent-live-p primary-selection-extent)
 985        (not (extent-detached-p primary-selection-extent))
 986        (eq buffer (extent-object primary-selection-extent))))
 987
 988 (defun default-mouse-track-anchor (adjust previous-point)
 989   (if adjust
 990       (if (default-mouse-track-has-selection-p (current-buffer))
 991           (let ((start (extent-start-position primary-selection-extent))
 992                 (end (extent-end-position primary-selection-extent)))
 993             (cond ((< (point) start) end)
 994                   ((> (point) end) start)
 995                   ((> (- (point) start) (- end (point))) start)
 996                   (t end)))
 997         previous-point)
 998     (point)))
 999
1000 (defun default-mouse-track-maybe-own-selection (pair type)
1001   (let ((start (car pair))
1002         (end (cdr pair)))
1003     (or (= start end) (push-mark (if (= (point) start) end start)))
1004     (cond (zmacs-regions
1005            (if (= start end)
1006                nil
1007              ;; #### UTTER KLUDGE.
1008              ;; If we don't have this sit-for here, then triple-clicking
1009              ;; will result in the line not being highlighted as it
1010              ;; should.  What appears to be happening is this:
1011              ;;
1012              ;; -- each time the button goes down, the selection is
1013              ;;    disowned (see comment "remove the existing selection
1014              ;;    to unclutter the display", below).
1015              ;; -- this causes a SelectionClear event to be sent to
1016              ;;    SXEmacs.
1017              ;; -- each time the button goes up except the first, the
1018              ;;    selection is owned again.
1019              ;; -- later, SXEmacs processes the SelectionClear event.
1020              ;;    The selection code attempts to keep track of the
1021              ;;    time that it last asserted the selection, and
1022              ;;    compare it to the time of the SelectionClear event,
1023              ;;    to see if it's a bogus notification or not (as
1024              ;;    is the case here).  However, for some unknown
1025              ;;    reason this doesn't work in the triple-clicking
1026              ;;    case, and the selection code bogusly thinks this
1027              ;;    SelectionClear event is the real thing.
1028              ;; -- putting the sit-for in causes the pending
1029              ;;    SelectionClear events to get processed before
1030              ;;    the selection is reasserted, so everything works
1031              ;;    out OK.
1032              ;;
1033              ;; Presumably(?) this means there is a weird timing bug
1034              ;; in the selection code, but there's not a chance in hell
1035              ;; that I have the patience to track it down.  Blame the
1036              ;; designers of X for fucking everything up so badly.
1037              ;;
1038              ;; This was originally a sit-for 0 but that wasn't
1039              ;; sufficient to make things work.  Even this isn't
1040              ;; always sufficient but it seems to give something
1041              ;; approaching a 99% success rate.  Making it higher yet
1042              ;; would help guarantee success with the price that the
1043              ;; delay would start to become noticeable.
1044              ;;
1045              (and (eq (console-type) 'x)
1046                   (sit-for 0.15 t))
1047              ;; zmacs-activate-region -> zmacs-activate-region-hook ->
1048              ;; activate-region-as-selection -> either own-selection or
1049              ;; mouse-track-activate-rectangular-selection
1050              (zmacs-activate-region)))
1051           ((console-on-window-system-p)
1052            ;; #### do we need this?  we don't do it when zmacs-regions = t
1053            (if (= start end)
1054                (disown-selection type)
1055              (activate-region-as-selection))))
1056     (if (and (eq 'x (console-type))
1057              (not (= start end)))
1058         ;; I guess cutbuffers should do something with rectangles too.
1059         ;; does anybody use them?
1060         (x-store-cutbuffer (buffer-substring start end)))))
1061
1062 (defun mouse-track-activate-rectangular-selection ()
1063   (if (consp default-mouse-track-extent)
1064       ;; own the rectangular region
1065       ;; this is a hack
1066       (let ((r default-mouse-track-extent))
1067         (save-excursion
1068           (set-buffer (get-buffer-create " *rect yank temp buf*"))
1069           (erase-buffer)
1070           (while r
1071             (insert (extent-string (car r)) "\n")
1072             (setq r (cdr r)))
1073           (own-selection (buffer-substring (point-min) (point-max)))))))
1074
1075 (defun default-mouse-track-deal-with-down-event (click-count)
1076   (let ((event default-mouse-track-down-event))
1077     (if (null event) nil
1078       (select-frame (event-frame event))
1079       (let ((adjust default-mouse-track-adjust)
1080             ;; ####When you click on the splash-screen,
1081             ;; event-{closest-,}point can be out of bounds.  Should
1082             ;; event-closest-point really be allowed to return a bad
1083             ;; position like that?  Maybe pixel_to_glyph_translation
1084             ;; needs to invalidate its cache when the buffer changes.
1085             ;; -dkindred@cs.cmu.edu
1086             (close-pos  (save-excursion
1087                           (set-buffer (event-buffer event))
1088                           (let ((p (event-closest-point event)))
1089                             (and p (min (max p (point-min)) (point-max))))))
1090             extent previous-point)
1091
1092         (if (not (event-window event))
1093             (error "not over window?"))
1094         (setq default-mouse-track-type
1095               (nth (mod (1- click-count)
1096                         (length default-mouse-track-type-list))
1097                    default-mouse-track-type-list))
1098         (setq default-mouse-track-window (event-window event))
1099         ;; Note that the extent used here is NOT the extent which
1100         ;; ends up as the value of zmacs-region-extent - this one is used
1101         ;; just during mouse-dragging.
1102         (setq default-mouse-track-extent
1103               (make-extent close-pos close-pos (event-buffer event)))
1104         (setq extent default-mouse-track-extent)
1105         (set-extent-face extent 'zmacs-region)
1106         ;; While the selection is being dragged out, give the selection extent
1107         ;; slightly higher priority than any mouse-highlighted extent, so that
1108         ;; the exact endpoints of the selection will be visible while the mouse
1109         ;; is down.  Normally, the selection and mouse highlighting have the
1110         ;; same priority, so that conflicts between the two of them are
1111         ;; resolved by the usual size-and-endpoint-comparison method.
1112         (set-extent-priority extent (1+ mouse-highlight-priority))
1113         (if mouse-track-rectangle-p
1114             (setq default-mouse-track-extent
1115                   (list default-mouse-track-extent)))
1116
1117         (setq previous-point
1118               (if (and adjust
1119                        (markerp default-mouse-track-previous-point)
1120                        (eq (current-buffer)
1121                            (marker-buffer default-mouse-track-previous-point)))
1122                   (marker-position default-mouse-track-previous-point)
1123                 (point)))
1124         (default-mouse-track-set-point event default-mouse-track-window)
1125         (if (not adjust)
1126             (if (markerp default-mouse-track-previous-point)
1127                 (set-marker default-mouse-track-previous-point (point))
1128               (setq default-mouse-track-previous-point (point-marker))))
1129         ;;
1130         ;; adjust point to a word or line boundary if appropriate
1131         (let ((anchor (default-mouse-track-anchor adjust previous-point)))
1132           (setq default-mouse-track-min-anchor
1133                 (save-excursion (goto-char anchor)
1134                                 (funcall
1135                                  default-mouse-track-normalize-point-function
1136                                  default-mouse-track-type nil)
1137                                 (point)))
1138           (setq default-mouse-track-max-anchor
1139                 (save-excursion (goto-char anchor)
1140                                 (funcall
1141                                  default-mouse-track-normalize-point-function
1142                                  default-mouse-track-type t)
1143                                 (point))))
1144         ;;
1145         ;; remove the existing selection to unclutter the display
1146         (if (not adjust)
1147             (cond (zmacs-regions
1148                    (zmacs-deactivate-region))
1149                   ((console-on-window-system-p)
1150                    (disown-selection)))))
1151       (setq default-mouse-track-down-event nil))))
1152
1153 ;; return t if the button or motion event involved the specified button.
1154 (defun default-mouse-track-event-is-with-button (event n)
1155   (cond ((button-event-p event)
1156          (= n (event-button event)))
1157         ((motion-event-p event)
1158          (memq (cdr
1159                 (assq n '((1 . button1) (2 . button2) (3 . button3)
1160                           (4 . button4) (5 . button5))))
1161                (event-modifiers event)))))
1162
1163 (defun default-mouse-track-down-hook (event click-count)
1164   (cond ((default-mouse-track-event-is-with-button event 1)
1165          (if (and (memq 'button1-down mouse-track-activate-strokes)
1166                   (mouse-track-do-activate event))
1167              t
1168            (setq default-mouse-track-down-event (copy-event event))
1169            nil))
1170         ((default-mouse-track-event-is-with-button event 2)
1171          (and (memq 'button2-down mouse-track-activate-strokes)
1172               (mouse-track-do-activate event)))))
1173
1174 (defun default-mouse-track-cleanup-extents-hook ()
1175   (remove-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)
1176   (let ((extent default-mouse-track-extent))
1177     (if (consp extent) ; rectangle-p
1178         (mapcar 'delete-extent extent)
1179       (if extent
1180           (delete-extent extent)))))
1181
1182 (defun default-mouse-track-cleanup-hook ()
1183   (if zmacs-regions
1184       (funcall 'default-mouse-track-cleanup-extents-hook)
1185     (let ((extent default-mouse-track-extent)
1186           (func #'(lambda (e)
1187                     (and (extent-live-p e)
1188                          (set-extent-face e 'primary-selection)))))
1189       (add-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)
1190       (if (consp extent)                ; rectangle-p
1191           (mapcar func extent)
1192         (if extent
1193             (funcall func extent)))))
1194   t)
1195
1196 (defun default-mouse-track-cleanup-extent ()
1197   (let ((dead-func
1198          (function (lambda (x)
1199                      (or (not (extent-live-p x))
1200                          (extent-detached-p x)))))
1201         (extent default-mouse-track-extent))
1202     (if (consp extent)
1203         (if (funcall dead-func extent)
1204             (let (newval)
1205               (mapcar (function (lambda (x)
1206                                   (if (not (funcall dead-func x))
1207                                       (setq newval (cons x newval)))))
1208                       extent)
1209               (setq default-mouse-track-extent (nreverse newval))))
1210       (if (funcall dead-func extent)
1211           (setq default-mouse-track-extent nil)))))
1212
1213 (defun default-mouse-track-drag-hook (event click-count was-timeout)
1214   (cond ((default-mouse-track-event-is-with-button event 1)
1215          (default-mouse-track-deal-with-down-event click-count)
1216          (default-mouse-track-set-point event default-mouse-track-window)
1217          (default-mouse-track-cleanup-extent)
1218          (default-mouse-track-next-move default-mouse-track-min-anchor
1219            default-mouse-track-max-anchor
1220            default-mouse-track-extent)
1221          t)
1222         ;; we nuked dnd, so this kinda won't work anymore --SY.
1223         ;((default-mouse-track-event-is-with-button event 2)
1224         ; (mouse-begin-drag-n-drop event))))
1225         ))
1226
1227 (defun default-mouse-track-return-dragged-selection (event)
1228   (default-mouse-track-cleanup-extent)
1229   (let ((extent default-mouse-track-extent)
1230         result)
1231     (default-mouse-track-set-point-in-window event default-mouse-track-window)
1232     (default-mouse-track-next-move default-mouse-track-min-anchor
1233                            default-mouse-track-max-anchor
1234                            extent)
1235     (cond ((consp extent) ; rectangle-p
1236            (let ((first (car extent))
1237                  (last (car (setq extent (nreverse extent)))))
1238              ;; nreverse is destructive so we need to reset this
1239              (setq default-mouse-track-extent extent)
1240              (setq result (cons (extent-start-position first)
1241                                 (extent-end-position last)))
1242              ;; kludge to fix up region when dragging backwards...
1243              (if (and (/= (point) (extent-start-position first))
1244                       (/= (point) (extent-end-position last))
1245                       (= (point) (extent-end-position first)))
1246                  (goto-char (car result)))))
1247           (extent
1248            (setq result (cons (extent-start-position extent)
1249                               (extent-end-position extent)))))
1250     ;; Minor kludge: if we're selecting in line-mode, include the
1251     ;; final newline.  It's hard to do this in *-normalize-point.
1252     (if (and result (eq default-mouse-track-type 'line))
1253         (let ((end-p (= (point) (cdr result))))
1254           (goto-char (cdr result))
1255           (if (not (eobp))
1256               (setcdr result (1+ (cdr result))))
1257           (goto-char (if end-p (cdr result) (car result)))))
1258 ;;;       ;; Minor kludge sub 2.  If in char mode, and we drag the
1259 ;;;       ;; mouse past EOL, include the newline.
1260 ;;;       ;;
1261 ;;;       ;; Major problem: can't easily distinguish between being
1262 ;;;       ;; just past the last char on a line, and well past it,
1263 ;;;       ;; to determine whether or not to include it in the region
1264 ;;;       ;;
1265 ;;;       (if nil ; (eq default-mouse-track-type 'char)
1266 ;;;           (let ((after-end-p (and (not (eobp))
1267 ;;;                                   (eolp)
1268 ;;;                                   (> (point) (car result)))))
1269 ;;;             (if after-end-p
1270 ;;;                 (progn
1271 ;;;                   (setcdr result (1+ (cdr result)))
1272 ;;;                   (goto-char (cdr result))))))
1273     result))
1274
1275 (defun default-mouse-track-drag-up-hook (event click-count)
1276   (when (default-mouse-track-event-is-with-button event 1)
1277     (let ((result (default-mouse-track-return-dragged-selection event)))
1278       (if result
1279           (default-mouse-track-maybe-own-selection result 'PRIMARY)))
1280     t))
1281
1282 (defun default-mouse-track-click-hook (event click-count)
1283   (cond ((default-mouse-track-event-is-with-button event 1)
1284          (if (and
1285               (or (and (= click-count 1)
1286                        (memq 'button1-click
1287                              mouse-track-activate-strokes))
1288                   (and (= click-count 2)
1289                        (memq 'button1-double-click
1290                              mouse-track-activate-strokes))
1291                   (and (= click-count 3)
1292                        (memq 'button1-triple-click
1293                              mouse-track-activate-strokes)))
1294               (mouse-track-do-activate event))
1295              t
1296            (default-mouse-track-drag-hook event click-count nil)
1297            (default-mouse-track-drag-up-hook event click-count)
1298            t))
1299         ((default-mouse-track-event-is-with-button event 2)
1300          (if (and
1301               (or (and (= click-count 1)
1302                        (memq 'button2-click
1303                              mouse-track-activate-strokes))
1304                   (and (= click-count 2)
1305                        (memq 'button2-double-click
1306                              mouse-track-activate-strokes))
1307                   (and (= click-count 3)
1308                        (memq 'button2-triple-click
1309                              mouse-track-activate-strokes)))
1310               (mouse-track-do-activate event))
1311              t
1312            (mouse-yank event)
1313            t))))
1314
1315
1316 (add-hook 'mouse-track-down-hook 'default-mouse-track-down-hook)
1317 (add-hook 'mouse-track-drag-hook 'default-mouse-track-drag-hook)
1318 (add-hook 'mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook)
1319 (add-hook 'mouse-track-click-hook 'default-mouse-track-click-hook)
1320 (add-hook 'mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook)
1321
1322 \f
1323 ;;;;;;;;;;;; other mouse-track stuff (mostly associated with the
1324 ;;;;;;;;;;;; default handlers)
1325
1326 (defun mouse-track-default (event)
1327   "Invoke `mouse-track' with only the default handlers active."
1328   (interactive "e")
1329   (mouse-track event
1330                '(mouse-track-down-hook
1331                  default-mouse-track-down-hook
1332                  mouse-track-up-hook nil
1333                  mouse-track-drag-hook default-mouse-track-drag-hook
1334                  mouse-track-drag-up-hook default-mouse-track-drag-up-hook
1335                  mouse-track-click-hook default-mouse-track-click-hook
1336                  mouse-track-cleanup-hook default-mouse-track-cleanup-hook)))
1337
1338 (defun mouse-track-do-rectangle (event)
1339   "Like `mouse-track' but selects rectangles instead of regions."
1340   (interactive "e")
1341   (let ((mouse-track-rectangle-p t))
1342         (mouse-track event)))
1343
1344 (defun mouse-track-adjust (event)
1345   "Extend the existing selection.  This should be bound to a mouse button.
1346 The selection will be enlarged or shrunk so that the point of the mouse
1347 click is one of its endpoints.  This function in fact behaves fairly
1348 similarly to `mouse-track', but begins by extending the existing selection
1349 (or creating a new selection from the previous text cursor position to
1350 the current mouse position) instead of creating a new, empty selection.
1351
1352 The mouse-track handlers are run from this command just like from
1353 `mouse-track'.  Therefore, do not call this command from a mouse-track
1354 handler!"
1355   (interactive "e")
1356   (let ((default-mouse-track-adjust t))
1357     (mouse-track event)))
1358
1359 (defun mouse-track-adjust-default (event)
1360   "Extend the existing selection, using only the default handlers.
1361 This is just like `mouse-track-adjust' but will override any
1362 custom mouse-track handlers that the user may have installed."
1363   (interactive "e")
1364   (let ((default-mouse-track-adjust t))
1365     (mouse-track-default event)))
1366
1367 (defun mouse-track-insert (event &optional delete)
1368   "Make a selection with the mouse and insert it at point.
1369 This is exactly the same as the `mouse-track' command on \\[mouse-track],
1370 except that point is not moved; the selected text is immediately inserted
1371 after being selected\; and the selection is immediately disowned afterwards."
1372   (interactive "*e")
1373   (let (s selreg)
1374     (flet ((Mouse-track-insert-drag-up-hook (event count)
1375              (setq selreg
1376                    (default-mouse-track-return-dragged-selection event))
1377              t)
1378            (Mouse-track-insert-click-hook (event count)
1379              (default-mouse-track-drag-hook event count nil)
1380              (setq selreg
1381                    (default-mouse-track-return-dragged-selection event))
1382              t))
1383       (save-excursion
1384         (save-window-excursion
1385           (mouse-track
1386            event
1387            '(mouse-track-drag-up-hook
1388              Mouse-track-insert-drag-up-hook
1389              mouse-track-click-hook
1390              Mouse-track-insert-click-hook))
1391           (if (consp selreg)
1392               (let ((pair selreg))
1393                 (setq s (prog1
1394                             (buffer-substring (car pair) (cdr pair))
1395                           (if delete
1396                               (kill-region (car pair) (cdr pair))))))))))
1397     (or (null s) (equal s "") (insert s))))
1398
1399 (defun mouse-track-delete-and-insert (event)
1400   "Make a selection with the mouse and insert it at point.
1401 This is exactly the same as the `mouse-track' command on \\[mouse-track],
1402 except that point is not moved; the selected text is immediately inserted
1403 after being selected\; and the text of the selection is deleted."
1404   (interactive "*e")
1405   (mouse-track-insert event t))
1406
1407 ;;;;;;;;;;;;;;;;;;;;;;;;
1408
1409
1410 (defvar inhibit-help-echo nil
1411   "Inhibits display of `help-echo' extent properties in the minibuffer.")
1412 (defvar last-help-echo-object nil)
1413 (defvar help-echo-owns-message nil)
1414
1415 (defun clear-help-echo (&optional ignored-frame)
1416   (if help-echo-owns-message
1417       (progn
1418         (setq help-echo-owns-message nil
1419               last-help-echo-object nil)
1420         (clear-message 'help-echo))))
1421
1422 (defun show-help-echo (mess)
1423   ;; (clear-help-echo)
1424   (setq help-echo-owns-message t)
1425   (display-message 'help-echo mess))
1426
1427 (add-hook 'mouse-leave-frame-hook 'clear-help-echo)
1428
1429 ;; It may be a good idea to move this to C, for better performance of
1430 ;; extent highlighting and pointer changes.
1431 (defun default-mouse-motion-handler (event)
1432   "For use as the value of `mouse-motion-handler'.
1433 This implements the various pointer-shape variables,
1434 as well as extent highlighting, help-echo, toolbar up/down,
1435 and `mode-motion-hook'."
1436   (let* ((frame (or (event-frame event) (selected-frame)))
1437          (window (event-window event))
1438          (buffer (event-buffer event))
1439          (modeline-point (and buffer (event-modeline-position event)))
1440          (modeline-string (and modeline-point
1441                                (symbol-value-in-buffer
1442                                 'generated-modeline-string buffer)))
1443          ;; point must be invalidated by modeline-point.
1444          (point (and buffer (not modeline-point)
1445                      (event-point event)))
1446          (extent (or (and point
1447                           (extent-at point buffer 'mouse-face))
1448                      (and modeline-point
1449                           (extent-at modeline-point modeline-string
1450                                      ;; Modeline extents don't have a
1451                                      ;; mouse-face property set.
1452                                      'help-echo))))
1453          (glyph-extent1 (event-glyph-extent event))
1454          (glyph-extent (and glyph-extent1
1455                             (extent-live-p glyph-extent1)
1456                             glyph-extent1))
1457          ;; This is an extent:
1458          (user-pointer1 (or (and glyph-extent
1459                                  (extent-property glyph-extent 'pointer)
1460                                  glyph-extent)
1461                             (and point (extent-at point buffer 'pointer))
1462                             (and modeline-point
1463                                  (extent-at modeline-point modeline-string
1464                                             'pointer))))
1465          ;; And this should be a glyph:
1466          (user-pointer (and user-pointer1 (extent-live-p user-pointer1)
1467                             (extent-property user-pointer1 'pointer)))
1468          (button (event-toolbar-button event))
1469          (help (or (and glyph-extent (extent-property glyph-extent 'help-echo)
1470                         glyph-extent)
1471                    (and button (not (null (toolbar-button-help-string button)))
1472                         button)
1473                    (and point
1474                         (extent-at point buffer 'help-echo))
1475                    (and modeline-point
1476                         (extent-at modeline-point modeline-string
1477                                    'help-echo))))
1478          ;; vars is a list of glyph variables to check for a pointer
1479          ;; value.
1480          (vars (cond
1481                 ;; Checking if button is non-nil is not sufficient
1482                 ;; since the pointer could be over a blank portion
1483                 ;; of the toolbar.
1484                 ((event-over-toolbar-p event)
1485                  '(toolbar-pointer-glyph nontext-pointer-glyph
1486                                          text-pointer-glyph))
1487                 ((or extent glyph-extent)
1488                  '(selection-pointer-glyph text-pointer-glyph))
1489                 ((event-over-modeline-p event)
1490                  '(modeline-pointer-glyph nontext-pointer-glyph
1491                                           text-pointer-glyph))
1492                 ((and (event-over-vertical-divider-p event)
1493                       ;; #### I disagree with the check below.
1494                       ;; Discuss it with Kirill for 21.1.  --hniksic
1495                       (specifier-instance vertical-divider-always-visible-p
1496                                           (event-window event)))
1497                  '(divider-pointer-glyph nontext-pointer-glyph
1498                                          text-pointer-glyph))
1499                 (point '(text-pointer-glyph))
1500                 (buffer '(nontext-pointer-glyph text-pointer-glyph))
1501                 (t '(nontext-pointer-glyph text-pointer-glyph))))
1502          pointer)
1503     (and user-pointer (glyphp user-pointer)
1504          (push 'user-pointer vars))
1505     (while (and vars (not (pointer-image-instance-p pointer)))
1506       (setq pointer (glyph-image-instance (symbol-value (car vars))
1507                                           (or window frame))
1508             vars (cdr vars)))
1509
1510     (if (pointer-image-instance-p pointer)
1511         (set-frame-pointer frame pointer))
1512
1513     ;; If last-pressed-toolbar-button is not nil, then check and see
1514     ;; if we have moved to a new button and adjust the down flags
1515     ;; accordingly.
1516     (when (and (featurep 'toolbar) toolbar-active)
1517       (unless (eq last-pressed-toolbar-button button)
1518         (release-previous-toolbar-button event)
1519         (and button (press-toolbar-button event))))
1520
1521     (cond (extent (highlight-extent extent t))
1522           (glyph-extent (highlight-extent glyph-extent t))
1523           (t (highlight-extent nil nil)))
1524     (cond ((extentp help)
1525            (or inhibit-help-echo
1526                (eq help last-help-echo-object) ;save some time
1527                (eq (selected-window) (minibuffer-window))
1528                (let ((hprop (extent-property help 'help-echo)))
1529                  (setq last-help-echo-object help)
1530                  (or (stringp hprop)
1531                      (setq hprop (funcall hprop help)))
1532                  (and hprop (show-help-echo hprop)))))
1533           ((and (featurep 'toolbar)
1534                 (toolbar-button-p help)
1535                 (toolbar-button-enabled-p help))
1536            (or (not toolbar-help-enabled)
1537                (eq help last-help-echo-object) ;save some time
1538                (eq (selected-window) (minibuffer-window))
1539                (let ((hstring (toolbar-button-help-string button)))
1540                  (setq last-help-echo-object help)
1541                  (or (stringp hstring)
1542                      (setq hstring (funcall hstring help)))
1543                  (and hstring (show-help-echo hstring)))))
1544           (last-help-echo-object
1545            (clear-help-echo)))
1546     (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
1547     (if (and buffer (symbol-value-in-buffer 'mode-motion-hook buffer nil))
1548         (with-current-buffer buffer
1549           (run-hook-with-args 'mode-motion-hook event)
1550
1551           ;; If the mode-motion-hook created a highlightable extent around
1552           ;; the mouse-point, highlight it right away.  Otherwise it wouldn't
1553           ;; be highlighted until the *next* motion event came in.
1554           (if (and point
1555                    (null extent)
1556                    (setq extent (extent-at point
1557                                            (event-buffer event) ; not buffer
1558                                            'mouse-face)))
1559               (highlight-extent extent t)))))
1560   nil)
1561
1562 (setq mouse-motion-handler 'default-mouse-motion-handler)
1563 \f
1564 ;;
1565 ;; Vertical divider dragging
1566 ;;
1567 (defun drag-window-divider (event)
1568   "Handle resizing windows by dragging window dividers.
1569 This is an internal function, normally bound to button1 event in
1570 window-divider-map. You would not call it, but you may bind it to
1571 other mouse buttons."
1572   (interactive "e")
1573   ;; #### I disagree with the check below.
1574   ;; Discuss it with Kirill for 21.1.  --hniksic
1575   (if (not (specifier-instance vertical-divider-always-visible-p
1576                                (event-window event)))
1577       (error "Not over a window"))
1578   (let-specifier ((vertical-divider-shadow-thickness
1579                    (- (specifier-instance vertical-divider-shadow-thickness
1580                                           (event-window event)))
1581                    (event-window event)))
1582     (let* ((window (event-window event))
1583            (frame (event-channel event))
1584            (last-timestamp (event-timestamp event))
1585            done)
1586       (while (not done)
1587         (let* ((edges (window-pixel-edges window))
1588                (old-right (caddr edges))
1589                (old-left (car edges))
1590                (backup-conf (current-window-configuration frame))
1591                (old-edges-all-windows (mapcar 'window-pixel-edges
1592                                               (window-list))))
1593
1594           ;; This is borrowed from modeline.el:
1595           ;; requeue event and quit if this is a misc-user, eval or
1596           ;;   keypress event.
1597           ;; quit if this is a button press or release event, or if the event
1598           ;;   occurred in some other frame.
1599           ;; drag if this is a mouse motion event and the time
1600           ;;   between this event and the last event is greater than
1601           ;;   drag-divider-event-lag.
1602           ;; do nothing if this is any other kind of event.
1603           (setq event (next-event event))
1604           (cond ((or (misc-user-event-p event)
1605                      (key-press-event-p event))
1606                  (setq unread-command-events (nconc unread-command-events
1607                                                     (list event))
1608                        done t))
1609                 ((button-release-event-p event)
1610                  (setq done t))
1611                 ((button-event-p event)
1612                  (setq done t))
1613                 ((not (motion-event-p event))
1614                  (dispatch-event event))
1615                 ((not (eq frame (event-frame event)))
1616                  (setq done t))
1617                 ((< (abs (- (event-timestamp event) last-timestamp))
1618                     drag-divider-event-lag))
1619                 (t
1620                  (setq last-timestamp (event-timestamp event))
1621                  ;; Enlarge the window, calculating change in characters
1622                  ;; of default font. Do not let the window to become
1623                  ;; less than allowed minimum (not because that's critical
1624                  ;; for the code performance, just the visual effect is
1625                  ;; better: when cursor goes to the left of the next left
1626                  ;; divider, the window being resized shrinks to minimal
1627                  ;; size.
1628                  (enlarge-window (max (- window-min-width (window-width window))
1629                                       (/ (- (event-x-pixel event) old-right)
1630                                          (face-width 'default window)))
1631                                  t window)
1632                  ;; Backout the change if some windows got deleted, or
1633                  ;; if the change caused more than two windows to resize
1634                  ;; (shifting the whole stack right is ugly), or if the
1635                  ;; left window side has slipped (right side cannot be
1636                  ;; moved any further to the right, so enlarge-window
1637                  ;; plays bad games with the left edge.
1638                  (if (or (/= (count-windows) (length old-edges-all-windows))
1639                          (/= old-left (car (window-pixel-edges window)))
1640                          ;; This check is very hairy. We allow any number
1641                          ;; of left edges to change, but only to the same
1642                          ;; new value. Similar procedure is for the right edges.
1643                          (let ((all-that-bad nil)
1644                                (new-left-ok nil)
1645                                (new-right-ok nil))
1646                            (mapcar* (lambda (window old-edges)
1647                                       (let ((new (car (window-pixel-edges window))))
1648                                         (if (/= new (car old-edges))
1649                                             (if (and new-left-ok
1650                                                      (/= new-left-ok new))
1651                                                 (setq all-that-bad t)
1652                                               (setq new-left-ok new)))))
1653                                     (window-list) old-edges-all-windows)
1654                            (mapcar* (lambda (window old-edges)
1655                                       (let ((new (caddr (window-pixel-edges window))))
1656                                         (if (/= new (caddr old-edges))
1657                                             (if (and new-right-ok
1658                                                      (/= new-right-ok new))
1659                                                 (setq all-that-bad t)
1660                                               (setq new-right-ok new)))))
1661                                     (window-list) old-edges-all-windows)
1662                            all-that-bad))
1663                      (set-window-configuration backup-conf)))))))))
1664
1665 (setq vertical-divider-map (make-keymap))
1666 (define-key vertical-divider-map 'button1 'drag-window-divider)
1667
1668 ;;; mouse.el ends here