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