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