1 ;;; mouse.el --- window system-independent mouse support.
3 ;; Copyright (C) 1988, 1992-4, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems
5 ;; Copyright (C) 1995, 1996 Ben Wing.
7 ;; Maintainer: XEmacs Development Team
8 ;; Keywords: mouse, dumped
10 ;; This file is part of XEmacs.
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)
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.
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.
27 ;;; Synched up with: Not synched with FSF. Almost completely divergent.
31 ;; This file is dumped with XEmacs (when window system support is compiled in).
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)
43 ;; drops are now handled in dragdrop.el (ograf@fga.de)
45 ;; enable drag regions (ograf@fga.de)
46 ;; if button2 is dragged from within a region, this becomes a drop
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))
54 "Window system-independent mouse support."
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."
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
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
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)
83 (defvar mouse-yank-function 'mouse-consolidated-yank
84 "Function that is called upon by `mouse-yank' to actually insert text.")
86 (defun mouse-consolidated-yank ()
94 (defun mouse-select ()
95 "Select Emacs window the mouse is on."
98 (defun mouse-delete-window ()
99 "Delete the Emacs window the mouse is on."
103 (defun mouse-keep-one-window ()
104 "Select Emacs window mouse is on, then kill all other Emacs windows."
106 (delete-other-windows))
108 (defun mouse-select-and-split ()
109 "Select Emacs window mouse is on, then split it vertically in half."
111 (split-window-vertically nil))
113 (defun mouse-set-point (event)
114 "Select Emacs window mouse is on, and move point to mouse position."
116 (let ((window (event-window event))
117 (pos (event-point event))
118 (close-pos (event-closest-point event)))
119 (or window (error "not in a window"))
120 (select-window window)
121 (if (and pos (> pos 0))
122 ;; If the event was over a text char, it's easy.
123 (goto-char (max (min pos (point-max)) (point-min)))
124 (if (and close-pos (> close-pos 0))
125 (goto-char (max (min close-pos (point-max)) (point-min)))
126 ;; When the event occurs outside of the frame directly to the
127 ;; left or right of a modeline, close-point is nil, but
128 ;; event-over-modeline is also nil. That will drop us to this
129 ;; point. So instead of erroring, just return nil.
132 (defun mouse-yank (event)
133 "Paste text with the mouse.
134 If the variable `mouse-yank-at-point' is nil, then pasting occurs at the
135 location of the click; otherwise, pasting occurs at the current cursor
138 (and (not mouse-yank-at-point)
139 (mouse-set-point event))
140 (funcall mouse-yank-function))
142 (defun click-inside-extent-p (click extent)
143 "Return non-nil if the button event is within the primary selection-extent.
144 Return nil otherwise."
146 (let ((ewin (event-window click))
147 (epnt (event-point click)))
151 (eq (window-buffer ewin)
152 (extent-object extent))
153 (extent-start-position extent)
154 (> epnt (extent-start-position extent))
155 (> (extent-end-position extent) epnt))))
157 (defun click-inside-selection-p (click)
158 (or (click-inside-extent-p click primary-selection-extent)
159 (click-inside-extent-p click zmacs-region-extent)
162 (defun point-inside-extent-p (extent)
163 "Return t if point is within the bounds of the primary selection extent.
164 Return t is point is at the end position of the extent.
165 Return nil otherwise."
169 (extent-object extent))
170 (> (point) (extent-start-position extent))
171 (>= (extent-end-position extent) (point))))
173 (defun point-inside-selection-p ()
174 ;; by Stig@hackvan.com
175 (or (point-inside-extent-p primary-selection-extent)
176 (point-inside-extent-p zmacs-region-extent)))
178 (defun mouse-drag-or-yank (event)
179 "Either drag or paste the current selection.
180 If the variable `mouse-yank-at-point' is non-nil,
181 move the cursor to the location of the click before pasting.
182 This functions has to be improved. Currently it is just a (working) test."
183 ;; by Oliver Graf <ograf@fga.de>
185 (if (click-inside-extent-p event zmacs-region-extent)
186 ;; okay, this is a drag
187 (cond ((featurep 'offix)
188 (offix-start-drag-region event
189 (extent-start-position zmacs-region-extent)
190 (extent-end-position zmacs-region-extent)))
192 ;; should also work with CDE
193 (cde-start-drag-region event
194 (extent-start-position zmacs-region-extent)
195 (extent-end-position zmacs-region-extent)))
196 (t (error "No offix or CDE support compiled in")))
197 ;; no drag, call region-funct
198 (and (not mouse-yank-at-point)
199 (mouse-set-point event))
200 (funcall mouse-yank-function))
203 (defun mouse-eval-sexp (click force-window)
204 "Evaluate the sexp under the mouse. Usually, this is the last sexp before
205 the click, but if you click on a left paren, then it is the sexp beginning
206 with the paren that is evaluated. Also, since strings evaluate to themselves,
207 they're fed to re-search-forward and the matched region is highlighted until
208 the mouse button is released.
210 Perhaps the most useful thing about this function is that the evaluation of
211 the expression which is clicked upon is relative not to the window where you
212 click, but to the current window and the current position of point. Thus,
213 you can use `mouse-eval-sexp' to interactively test code that acts upon a
214 buffer...something you cannot do with the standard `eval-last-sexp' function.
215 It's also fantastic for debugging regular expressions."
216 ;; by Stig@hackvan.com
218 (let (exp val result-str)
219 (setq exp (save-window-excursion
221 (mouse-set-point click)
223 (or (looking-at "(") (forward-sexp -1))
224 (read (point-marker))))))
226 (if (setq val (re-search-forward exp nil t))
227 (let* ((oo (make-extent (match-beginning 0) (match-end 0))))
228 (set-extent-face oo 'highlight)
229 (set-extent-priority oo 1000)
230 ;; wait for button release...
231 (setq unread-command-event (next-command-event))
233 (message "Regex \"%s\" not found" exp)
235 (t (setq val (if (fboundp 'eval-interactive)
236 (eval-interactive exp)
238 (setq result-str (prin1-to-string val))
239 ;; #### -- need better test
240 (if (and (not force-window)
241 (<= (length result-str) (window-width (selected-window))))
242 (message "%s" result-str)
243 (with-output-to-temp-buffer "*Mouse-Eval*"
246 (error (prin1 val))))
249 (defun mouse-line-length (event)
250 "Print the length of the line indicated by the pointer."
253 (mouse-set-point event)
254 (message "Line length: %d" (- (point-at-eol) (point-at-bol))))
257 (defun mouse-set-mark (event)
258 "Select Emacs window mouse is on, and set mark at mouse position.
259 Display cursor at that position for a second."
261 (let ((point-save (point)))
263 (progn (mouse-set-point event)
266 (goto-char point-save))))
268 (defun mouse-scroll (event)
269 "Scroll point to the mouse position."
272 (mouse-set-point event)
274 (scroll-right (event-x event))))
276 (defun mouse-del-char (event)
277 "Delete the char pointed to by the mouse."
280 (mouse-set-point event)
281 (delete-char 1 nil)))
283 (defun mouse-kill-line (event)
284 "Kill the line pointed to by the mouse."
287 (mouse-set-point event)
290 (defun mouse-bury-buffer (event)
291 "Bury the buffer pointed to by the mouse, thus selecting the next one."
293 (save-selected-window
294 (select-window (event-window event))
297 (defun mouse-unbury-buffer (event)
298 "Unbury and select the most recently buried buffer."
300 (save-selected-window
301 (select-window (event-window event))
302 (let* ((bufs (buffer-list))
303 (entry (1- (length bufs)))
305 (while (not (setq val (nth entry bufs)
306 val (and (/= (aref (buffer-name val) 0)
309 (setq entry (1- entry)))
310 (switch-to-buffer val))))
312 (defun narrow-window-to-region (m n)
313 "Narrow window to region between point and last mark"
317 (if (eq (selected-window) (next-window))
321 (if (eq (selected-window)
322 (if (zerop (minibuffer-depth))
325 (shrink-window (- (- (window-height) (count-lines m n)) 1))))))
327 (defun mouse-window-to-region (event)
328 "Narrow window to region between cursor and mouse pointer."
330 (let ((point-save (point)))
332 (progn (mouse-set-point event)
335 (goto-char point-save)
336 (narrow-window-to-region (region-beginning) (region-end)))))
338 (defun mouse-ignore ()
343 ;;; mouse/selection tracking
344 ;;; generalized mouse-track
346 (defvar default-mouse-track-normalize-point-function
347 'default-mouse-track-normalize-point
348 "Function called to normalize position of point.
349 Called with two arguments: TYPE depends on the number of times that the
350 mouse has been clicked and is a member of `default-mouse-track-type-list',
351 FORWARDP determines the direction in which the point should be moved.")
353 (defvar mouse-track-down-hook nil
354 "Function or functions called when the user presses the mouse.
355 This hook is invoked by `mouse-track'; thus, it will not be called
356 for any buttons with a different binding. The functions will be
357 called with two arguments: the button-press event and a click
358 count (see `mouse-track-click-hook').
360 If any function returns non-nil, the remaining functions will not be
363 Note that most applications should take action when the mouse is
364 released, not when it is pressed.'")
366 (defvar mouse-track-drag-hook nil
367 "Function or functions called when the user drags the mouse.
368 This hook is invoked by `mouse-track'; thus, it will not be called
369 for any buttons with a different binding. The functions will be
370 called with three arguments: the mouse-motion event, a click
371 count (see `mouse-track-click-hook'), and whether the call to
372 this hook occurred as a result of a drag timeout (see
373 `mouse-track-scroll-delay').
375 If any function returns non-nil, the remaining functions will not be
378 Note that no calls to this function will be made until the user
379 initiates a drag (i.e. moves the mouse more than a certain
380 threshold in either the X or the Y direction, as defined by
381 `mouse-track-x-threshold' and `mouse-track-y-threshold').
383 See also `mouse-track-drag-up-hook'.")
385 (defvar mouse-track-drag-up-hook nil
386 "Function or functions called when the user finishes a drag.
387 This hook is invoked by `mouse-track'; thus, it will not be called
388 for any buttons with a different binding. The functions will be
389 called with two arguments: the button-press event and a click
390 count (see `mouse-track-click-hook').
392 If any function returns non-nil, the remaining functions will not be
395 Note that this hook will not be invoked unless the user has
396 initiated a drag, i.e. moved the mouse more than a certain threshold
397 (see `mouse-track-drag-hook'). When this function is invoked,
398 `mouse-track-drag-hook' will have been invoked at least once.
400 See also `mouse-track-click-hook'.")
402 (defvar mouse-track-click-hook nil
403 "Function or functions called when the user clicks the mouse.
404 `Clicking' means pressing and releasing the mouse without having
405 initiated a drag (i.e. without having moved more than a certain
406 threshold -- see `mouse-track-drag-hook').
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 two arguments: the button-release event and a click
411 count, which specifies the number of times that the mouse has been
412 clicked in a series of clicks, each of which is separated by at most
413 `mouse-track-multi-click-time'. This can be used to implement actions
414 that are called on double clicks, triple clicks, etc.
416 If any function returns non-nil, the remaining functions will not be
419 See also `mouse-track-drag-up-hook.")
421 (defvar mouse-track-up-hook nil
422 "Function or functions called when the user releases the mouse.
423 This hook is invoked by `mouse-track'; thus, it will not be called
424 for any buttons with a different binding. The functions will be
425 called with two arguments: the button-release event and a click
426 count (see `mouse-track-click-hook').
428 For many applications, it is more appropriate to use one or both
429 of `mouse-track-click-hook' and `mouse-track-drag-up-hook'.")
431 (defvar mouse-track-cleanup-hook nil
432 "Function or functions called when `mouse-track' terminates.
433 This hook will be called in all circumstances, even upon a
434 non-local exit out of `mouse-track', and so is useful for
435 doing cleanup work such as removing extents that may have
436 been created during the operation of `mouse-track'.
438 Unlike all of the other mouse-track hooks, this is a \"normal\"
439 hook: the hook functions are called with no arguments, and
440 all hook functions are called regardless of their return
443 (defcustom mouse-track-multi-click-time 400
444 "*Maximum number of milliseconds allowed between clicks for a multi-click.
445 See `mouse-track-click-hook'."
449 (defcustom mouse-track-scroll-delay 100
450 "Maximum of milliseconds between calls to `mouse-track-drag-hook'.
451 If the user is dragging the mouse (i.e. the button is held down and
452 a drag has been initiated) and does not move the mouse for this many
453 milliseconds, the hook will be called with t as the value of the
454 WAS-TIMEOUT parameter. This can be used to implement scrolling
455 in a selection when the user drags the mouse out the window it
458 A value of nil disables the timeout feature."
459 :type '(choice integer (const :tag "Disabled" nil))
462 (defvar mouse-track-x-threshold '(face-width 'default)
463 "Minimum number of pixels in the X direction for a drag to be initiated.
464 If the mouse is moved more than either the X or Y threshold while the
465 button is held down (see also `mouse-track-y-threshold'), then a drag
466 is initiated; otherwise the gesture is considered to be a click.
469 The value should be either a number of a form to be evaluated to
472 (defvar mouse-track-y-threshold '(face-height 'default)
473 "Minimum number of pixels in the Y direction for a drag to be initiated.
474 If the mouse is moved more than either the X or Y threshold while the
475 button is held down (see also `mouse-track-x-threshold'), then a drag
476 is initiated; otherwise the gesture is considered to be a click.
479 The value should be either a number of a form to be evaluated to
482 ;; these variables are private to mouse-track.
483 (defvar mouse-track-up-time nil)
484 (defvar mouse-track-up-x nil)
485 (defvar mouse-track-up-y nil)
486 (defvar mouse-track-timeout-id nil)
487 (defvar mouse-track-click-count nil)
489 (defun mouse-track-set-timeout (event)
490 (if mouse-track-timeout-id
491 (disable-timeout mouse-track-timeout-id))
492 (if mouse-track-scroll-delay
493 (setq mouse-track-timeout-id
494 (add-timeout (/ mouse-track-scroll-delay 1000.0)
495 'mouse-track-scroll-undefined
496 (copy-event event)))))
498 (defun mouse-track-run-hook (hook event &rest args)
499 ;; ugh, can't use run-hook-with-args-until-success because we have
500 ;; to get the value using symbol-value-in-buffer. Doing a
501 ;; save-excursion/set-buffer is wrong because the hook might want to
502 ;; change the buffer, but just doing a set-buffer is wrong because
503 ;; the hook might not want to change the buffer.
504 ;; #### What we need here is a Lisp interface to
505 ;; run_hook_with_args_in_buffer. Here is a poor man's version.
506 (let ((buffer (event-buffer event)))
507 (and mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
509 (let ((value (symbol-value-in-buffer hook buffer nil)))
510 (if (and (listp value) (not (eq (car value) 'lambda)))
511 ;; List of functions.
513 (while (and value (null retval))
514 ;; Found `t': should process default value. We could
515 ;; splice it into the buffer-local value, but that
516 ;; would cons, which is not a good thing for
517 ;; mouse-track hooks.
518 (if (eq (car value) t)
519 (let ((global (default-value hook)))
520 (if (and (listp global) (not (eq (car global) 'lambda)))
521 ;; List of functions.
524 (apply (car global) event args))))
527 (setq retval (apply (car global) event args))))
528 (setq retval (apply (car value) event args)))
532 (apply value event args))))))
534 (defun mouse-track-scroll-undefined (random)
535 ;; the old implementation didn't actually define this function,
536 ;; and in normal use it won't ever be called because the timeout
537 ;; will either be removed before it fires or will be picked off
538 ;; with next-event and not dispatched. However, if you're
539 ;; attempting to debug a click-hook (which is pretty damn
540 ;; difficult to do), this function may get called.
543 (defun mouse-track (event)
544 "Make a selection with the mouse. This should be bound to a mouse button.
545 The behavior of XEmacs during mouse selection is customizable using various
546 hooks and variables: see `mouse-track-click-hook', `mouse-track-drag-hook',
547 `mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook',
548 `mouse-track-cleanup-hook', `mouse-track-multi-click-time',
549 `mouse-track-scroll-delay', `mouse-track-x-threshold', and
550 `mouse-track-y-threshold'.
552 Default handlers are provided to implement standard selecting/positioning
553 behavior. You can explicitly request this default behavior, and override
554 any custom-supplied handlers, by using the function `mouse-track-default'
555 instead of `mouse-track'.
557 Default behavior is as follows:
559 If you click-and-drag, the selection will be set to the region between the
560 point of the initial click and the point at which you release the button.
561 These positions need not be ordered.
563 If you click-and-release without moving the mouse, then the point is moved
564 and the selection is disowned (there will be no selection owner). The mark
565 will be set to the previous position of point.
567 If you double-click, the selection will extend by symbols instead of by
568 characters. If you triple-click, the selection will extend by lines.
570 If you drag the mouse off the top or bottom of the window, you can select
571 pieces of text which are larger than the visible part of the buffer; the
572 buffer will scroll as necessary.
574 The selected text becomes the current X Selection. The point will be left
575 at the position at which you released the button, and the mark will be left
576 at the initial click position."
579 (xthresh (eval mouse-track-x-threshold))
580 (ythresh (eval mouse-track-y-threshold))
581 (orig-x (event-x-pixel event))
582 (orig-y (event-y-pixel event))
583 (buffer (event-buffer event))
584 (mouse-grabbed-buffer (event-buffer event))
586 (if (or (not mouse-track-up-x)
587 (not mouse-track-up-y)
588 (not mouse-track-up-time)
589 (> (- (event-timestamp event) mouse-track-up-time)
590 mouse-track-multi-click-time)
591 (> (abs (- mouse-track-up-x orig-x)) xthresh)
592 (> (abs (- mouse-track-up-y orig-y)) ythresh))
593 (setq mouse-track-click-count 1)
594 (setq mouse-track-click-count (1+ mouse-track-click-count)))
595 (if (not (event-window event))
596 (error "Not over a window."))
597 (mouse-track-run-hook 'mouse-track-down-hook
598 event mouse-track-click-count)
601 (setq event (next-event event))
602 (cond ((motion-event-p event)
603 (if (and (not mouse-moved)
604 (or (> (abs (- (event-x-pixel event) orig-x))
606 (> (abs (- (event-y-pixel event) orig-y))
608 (setq mouse-moved t))
610 (mouse-track-run-hook 'mouse-track-drag-hook
611 event mouse-track-click-count nil))
612 (mouse-track-set-timeout event))
613 ((and (timeout-event-p event)
614 (eq (event-function event)
615 'mouse-track-scroll-undefined))
617 (mouse-track-run-hook 'mouse-track-drag-hook
618 (event-object event) mouse-track-click-count t))
619 (mouse-track-set-timeout (event-object event)))
620 ((button-release-event-p event)
621 (setq mouse-track-up-time (event-timestamp event))
622 (setq mouse-track-up-x (event-x-pixel event))
623 (setq mouse-track-up-y (event-y-pixel event))
624 (setq mouse-down nil)
625 (mouse-track-run-hook 'mouse-track-up-hook
626 event mouse-track-click-count)
628 (mouse-track-run-hook 'mouse-track-drag-up-hook
629 event mouse-track-click-count)
630 (mouse-track-run-hook 'mouse-track-click-hook
631 event mouse-track-click-count)))
632 ((or (key-press-event-p event)
633 (and (misc-user-event-p event)
634 (eq (event-function event) 'cancel-mode-internal)))
635 (error "Selection aborted"))
637 (dispatch-event event))))
639 (if mouse-track-timeout-id
640 (disable-timeout mouse-track-timeout-id))
641 (setq mouse-track-timeout-id nil)
645 (run-hooks 'mouse-track-cleanup-hook))))))
648 ;;;;;;;;;;;; default handlers: new version of mouse-track
650 (defvar default-mouse-track-type nil)
651 (defvar default-mouse-track-type-list '(char word line))
652 (defvar default-mouse-track-window nil)
653 (defvar default-mouse-track-extent nil)
654 (defvar default-mouse-track-adjust nil)
655 (defvar default-mouse-track-min-anchor nil)
656 (defvar default-mouse-track-max-anchor nil)
657 (defvar default-mouse-track-result nil)
658 (defvar default-mouse-track-down-event nil)
660 ;; D. Verna Feb. 17 1998
661 ;; This function used to assume that when (event-window event) differs from
662 ;; window, we have to scroll. This is WRONG, for instance when there are
663 ;; toolbars on the side, in which case window-event returns nil.
664 (defun default-mouse-track-set-point-in-window (event window)
665 (if (event-over-modeline-p event)
667 ;; Not over a modeline
668 (if (eq (event-window event) window)
669 (let ((p (event-closest-point event)))
670 (if (or (not p) (not (pos-visible-in-window-p p window)))
672 (mouse-set-point event)
674 ;; Not over a modeline, not the same window. Check if the Y position
675 ;; is still overlapping the original window.
676 (let* ((edges (window-pixel-edges window))
677 (row (event-y-pixel event))
678 (text-start (nth 1 edges))
679 (text-end (+ (nth 3 edges))))
680 (if (or (< row text-start)
683 ;; The Y pos in overlapping the original window. Check however if
684 ;; the position is really visible, because there could be a
685 ;; scrollbar or a modeline at this place.
686 ;; Find the mean line height (height / lines nb), and approximate
687 ;; the line number for Y pos.
688 (select-window window)
689 (let ((line (/ (* (- row text-start) (window-height))
690 (- text-end text-start))))
691 (if (not (save-excursion
692 (goto-char (window-start))
693 (pos-visible-in-window-p
694 (point-at-bol (+ 1 line)))))
696 ;; OK, we can go to that position
697 (goto-char (window-start))
699 ;; On the right side: go to end-of-line.
700 (when (>= (event-x-pixel event) (nth 2 edges))
701 (goto-char (point-at-eol)))
706 (defun default-mouse-track-scroll-and-set-point (event window)
707 (select-window window)
708 (let ((edges (window-pixel-edges window))
709 (row (event-y-pixel event))
710 (height (face-height 'default)))
711 (cond ((< (abs (- row (nth 1 edges))) (abs (- row (nth 3 edges))))
712 ;; closer to window's top than to bottom, so move up
713 (let ((delta (max 1 (/ (- (nth 1 edges) row) height))))
714 (condition-case () (scroll-down delta) (error))
715 (goto-char (window-start))))
716 ((>= (point) (point-max)))
718 ;; scroll by one line if over the modeline or a clipped line
719 (let ((delta (if (or (event-over-modeline-p event)
720 (< row (nth 3 edges)))
722 (+ (/ (- row (nth 3 edges)) height) 1)))
723 (close-pos (event-closest-point event)))
724 (condition-case () (scroll-up delta) (error))
725 (if (and close-pos (pos-visible-in-window-p close-pos))
726 (goto-char close-pos)
727 (goto-char (window-end))
728 (vertical-motion delta)
729 ;; window-end reports the end of the clipped line, even if
730 ;; scroll-on-clipped-lines is t. compensate.
731 ;; (If window-end gets fixed this can be removed.)
732 (if (not (pos-visible-in-window-p (max (1- (point))
734 (vertical-motion -1))
735 (condition-case () (backward-char 1)
736 (error (end-of-line)))))))))
739 ;; This remembers the last position at which the user clicked, for the
740 ;; benefit of mouse-track-adjust (for example, button1; scroll until the
741 ;; position of the click is off the frame; then Sh-button1 to select the
743 (defvar default-mouse-track-previous-point nil)
745 (defun default-mouse-track-set-point (event window)
746 (if (default-mouse-track-set-point-in-window event window)
748 (default-mouse-track-scroll-and-set-point event window)))
750 (defsubst default-mouse-track-beginning-of-word (symbolp)
751 (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'")
752 ((null symbolp) "\\w")
754 (white-space "[ \t]"))
756 ((looking-at word-constituent)
758 (while (and (not (bobp)) (looking-at word-constituent))
760 (if (or (not (bobp)) (not (looking-at word-constituent)))
762 ((looking-at white-space)
764 (while (looking-at white-space)
768 (defun default-mouse-track-end-of-word (symbolp)
769 (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'")
770 ((null symbolp) "\\w")
772 (white-space "[ \t]"))
773 (cond ((looking-at word-constituent) ; word or symbol constituent
774 (while (looking-at word-constituent)
776 ((looking-at white-space) ; word or symbol constituent
777 (while (looking-at white-space)
780 ;; Decide what will be the SYMBOLP argument to
781 ;; default-mouse-track-{beginning,end}-of-word, according to the
782 ;; syntax of the current character and value of mouse-highlight-text.
783 (defsubst default-mouse-track-symbolp (syntax)
784 (cond ((eq mouse-highlight-text 'context)
786 ((eq mouse-highlight-text 'symbol)
791 ;; Return t if point is at an opening quote character. This is
792 ;; determined by testing whether the syntax of the following character
793 ;; is `string', which will always be true for opening quotes and
794 ;; always false for closing quotes.
795 (defun default-mouse-track-point-at-opening-quote-p ()
798 (eq (buffer-syntactic-context) 'string)))
800 (defun default-mouse-track-normalize-point (type forwardp)
801 (cond ((eq type 'word)
802 ;; trap the beginning and end of buffer errors
804 (setq type (char-syntax (char-after (point))))
808 (default-mouse-track-point-at-opening-quote-p)))
809 (goto-char (scan-sexps (point) 1))
810 (default-mouse-track-end-of-word
811 (default-mouse-track-symbolp type)))
814 (not (default-mouse-track-point-at-opening-quote-p))))
815 (goto-char (scan-sexps (1+ (point)) -1))
816 (default-mouse-track-beginning-of-word
817 (default-mouse-track-symbolp type))))))
819 (if forwardp (end-of-line) (beginning-of-line)))
821 (if forwardp (end-of-buffer) (beginning-of-buffer)))))
823 (defun default-mouse-track-next-move (min-anchor max-anchor extent)
824 (let ((anchor (if (<= (point) min-anchor) max-anchor min-anchor)))
825 (funcall default-mouse-track-normalize-point-function
826 default-mouse-track-type (> (point) anchor))
828 (default-mouse-track-next-move-rect anchor (point) extent)
830 (if (<= anchor (point))
831 (set-extent-endpoints extent anchor (point))
832 (set-extent-endpoints extent (point) anchor))))))
834 (defun default-mouse-track-next-move-rect (start end extents &optional pad-p)
836 (let ((tmp start)) (setq start end end tmp)))
838 ((= start end) ; never delete the last remaining extent
839 (mapcar 'delete-extent (cdr extents))
841 (set-extent-endpoints (car extents) start start))
843 (let ((indent-tabs-mode nil) ; if pad-p, don't use tabs
849 (setq right (current-column))
851 (setq left (current-column))
854 (setq left right right tmp)
855 (setq start (- start (- right left))
856 end (+ end (- right left)))))
857 ;; End may have been set to a value greater than point-max if drag
858 ;; or movement extends to end of buffer, so reset it.
859 (setq end (min end (point-max)))
861 (narrow-to-region (point) end)
863 (while (and rest (not (eobp)))
865 (move-to-column right pad-p)
866 (set-extent-endpoints (car rest) p (point))
867 ;; this code used to look at the return value
868 ;; of forward-line, but that doesn't work because
869 ;; forward-line has bogus behavior: If you're on
870 ;; the last line of a buffer but not at the very
871 ;; end, forward-line will move you to the very
872 ;; end and return 0 instead of 1, like it should.
873 ;; the result was frequent infinite loops here,
874 ;; creating very large numbers of extents at
875 ;; the same position. There was an N^2 sorting
876 ;; algorithm in extents.c for extents at a
877 ;; particular position, and the result was very
881 (move-to-column left pad-p))
885 (mapcar 'delete-extent rest)
890 (move-to-column right pad-p)
891 (let ((e (make-extent p (point))))
892 (set-extent-face e (extent-face (car extents)))
893 (set-extent-priority e (extent-priority (car extents)))
894 (setcdr last (cons e nil))
895 (setq last (cdr last)))
898 (move-to-column left pad-p))
902 (defun default-mouse-track-has-selection-p (buffer)
903 (and (selection-owner-p)
904 (extent-live-p primary-selection-extent)
905 (not (extent-detached-p primary-selection-extent))
906 (eq buffer (extent-object primary-selection-extent))))
908 (defun default-mouse-track-anchor (adjust previous-point)
910 (if (default-mouse-track-has-selection-p (current-buffer))
911 (let ((start (extent-start-position primary-selection-extent))
912 (end (extent-end-position primary-selection-extent)))
913 (cond ((< (point) start) end)
914 ((> (point) end) start)
915 ((> (- (point) start) (- end (point))) start)
920 (defun default-mouse-track-maybe-own-selection (pair type)
921 (let ((start (car pair))
923 (or (= start end) (push-mark (if (= (point) start) end start)))
927 ;; #### UTTER KLUDGE.
928 ;; If we don't have this sit-for here, then triple-clicking
929 ;; will result in the line not being highlighted as it
930 ;; should. What appears to be happening is this:
932 ;; -- each time the button goes down, the selection is
933 ;; disowned (see comment "remove the existing selection
934 ;; to unclutter the display", below).
935 ;; -- this causes a SelectionClear event to be sent to
937 ;; -- each time the button goes up except the first, the
938 ;; selection is owned again.
939 ;; -- later, XEmacs processes the SelectionClear event.
940 ;; The selection code attempts to keep track of the
941 ;; time that it last asserted the selection, and
942 ;; compare it to the time of the SelectionClear event,
943 ;; to see if it's a bogus notification or not (as
944 ;; is the case here). However, for some unknown
945 ;; reason this doesn't work in the triple-clicking
946 ;; case, and the selection code bogusly thinks this
947 ;; SelectionClear event is the real thing.
948 ;; -- putting the sit-for in causes the pending
949 ;; SelectionClear events to get processed before
950 ;; the selection is reasserted, so everything works
953 ;; Presumably(?) this means there is a weird timing bug
954 ;; in the selection code, but there's not a chance in hell
955 ;; that I have the patience to track it down. Blame the
956 ;; designers of X for fucking everything up so badly.
958 ;; This was originally a sit-for 0 but that wasn't
959 ;; sufficient to make things work. Even this isn't
960 ;; always sufficient but it seems to give something
961 ;; approaching a 99% success rate. Making it higher yet
962 ;; would help guarantee success with the price that the
963 ;; delay would start to become noticeable.
965 (and (eq (console-type) 'x)
967 (zmacs-activate-region)))
968 ((console-on-window-system-p)
970 (disown-selection type)
971 (if (consp default-mouse-track-extent)
972 ;; own the rectangular region
974 (let ((r default-mouse-track-extent))
976 (set-buffer (get-buffer-create " *rect yank temp buf*"))
978 (insert (extent-string (car r)) "\n")
980 (own-selection (buffer-substring (point-min) (point-max)))
981 (kill-buffer (current-buffer))))
982 (own-selection (cons (set-marker (make-marker) start)
983 (set-marker (make-marker) end))
985 (if (and (eq 'x (console-type))
987 ;; I guess cutbuffers should do something with rectangles too.
988 ;; does anybody use them?
989 (x-store-cutbuffer (buffer-substring start end)))))
991 (defun default-mouse-track-deal-with-down-event (click-count)
992 (let ((event default-mouse-track-down-event))
994 (select-frame (event-frame event))
995 (let ((adjust default-mouse-track-adjust)
996 ;; ####When you click on the splash-screen,
997 ;; event-{closest-,}point can be out of bounds. Should
998 ;; event-closest-point really be allowed to return a bad
999 ;; position like that? Maybe pixel_to_glyph_translation
1000 ;; needs to invalidate its cache when the buffer changes.
1001 ;; -dkindred@cs.cmu.edu
1002 (close-pos (save-excursion
1003 (set-buffer (event-buffer event))
1004 (let ((p (event-closest-point event)))
1005 (and p (min (max p (point-min)) (point-max))))))
1006 extent previous-point)
1008 (if (not (event-window event))
1009 (error "not over window?"))
1010 (setq default-mouse-track-type
1011 (nth (mod (1- click-count)
1012 (length default-mouse-track-type-list))
1013 default-mouse-track-type-list))
1014 (setq default-mouse-track-window (event-window event))
1015 ;; Note that the extent used here is NOT the extent which
1016 ;; ends up as the value of zmacs-region-extent - this one is used
1017 ;; just during mouse-dragging.
1018 (setq default-mouse-track-extent
1019 (make-extent close-pos close-pos (event-buffer event)))
1020 (setq extent default-mouse-track-extent)
1021 (set-extent-face extent 'zmacs-region)
1022 ;; While the selection is being dragged out, give the selection extent
1023 ;; slightly higher priority than any mouse-highlighted extent, so that
1024 ;; the exact endpoints of the selection will be visible while the mouse
1025 ;; is down. Normally, the selection and mouse highlighting have the
1026 ;; same priority, so that conflicts between the two of them are
1027 ;; resolved by the usual size-and-endpoint-comparison method.
1028 (set-extent-priority extent (1+ mouse-highlight-priority))
1029 (if mouse-track-rectangle-p
1030 (setq default-mouse-track-extent
1031 (list default-mouse-track-extent)))
1033 (setq previous-point
1035 (markerp default-mouse-track-previous-point)
1036 (eq (current-buffer)
1037 (marker-buffer default-mouse-track-previous-point)))
1038 (marker-position default-mouse-track-previous-point)
1040 (default-mouse-track-set-point event default-mouse-track-window)
1042 (if (markerp default-mouse-track-previous-point)
1043 (set-marker default-mouse-track-previous-point (point))
1044 (setq default-mouse-track-previous-point (point-marker))))
1046 ;; adjust point to a word or line boundary if appropriate
1047 (let ((anchor (default-mouse-track-anchor adjust previous-point)))
1048 (setq default-mouse-track-min-anchor
1049 (save-excursion (goto-char anchor)
1051 default-mouse-track-normalize-point-function
1052 default-mouse-track-type nil)
1054 (setq default-mouse-track-max-anchor
1055 (save-excursion (goto-char anchor)
1057 default-mouse-track-normalize-point-function
1058 default-mouse-track-type t)
1061 ;; remove the existing selection to unclutter the display
1063 (cond (zmacs-regions
1064 (zmacs-deactivate-region))
1065 ((console-on-window-system-p)
1066 (disown-selection)))))
1067 (setq default-mouse-track-down-event nil))))
1069 (defun default-mouse-track-down-hook (event click-count)
1070 (setq default-mouse-track-down-event (copy-event event))
1073 (defun default-mouse-track-cleanup-extents-hook ()
1074 (remove-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)
1075 (let ((extent default-mouse-track-extent))
1076 (if (consp extent) ; rectangle-p
1077 (mapcar 'delete-extent extent)
1079 (delete-extent extent)))))
1081 (defun default-mouse-track-cleanup-hook ()
1083 (funcall 'default-mouse-track-cleanup-extents-hook)
1084 (let ((extent default-mouse-track-extent)
1086 (and (extent-live-p e)
1087 (set-extent-face e 'primary-selection)))))
1088 (add-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)
1089 (if (consp extent) ; rectangle-p
1090 (mapcar func extent)
1092 (funcall func extent))))))
1094 (defun default-mouse-track-cleanup-extent ()
1096 (function (lambda (x)
1097 (or (not (extent-live-p x))
1098 (extent-detached-p x)))))
1099 (extent default-mouse-track-extent))
1101 (if (funcall dead-func extent)
1103 (mapcar (function (lambda (x)
1104 (if (not (funcall dead-func x))
1105 (setq newval (cons x newval)))))
1107 (setq default-mouse-track-extent (nreverse newval))))
1108 (if (funcall dead-func extent)
1109 (setq default-mouse-track-extent nil)))))
1111 (defun default-mouse-track-drag-hook (event click-count was-timeout)
1112 (default-mouse-track-deal-with-down-event click-count)
1113 (default-mouse-track-set-point event default-mouse-track-window)
1114 (default-mouse-track-cleanup-extent)
1115 (default-mouse-track-next-move default-mouse-track-min-anchor
1116 default-mouse-track-max-anchor
1117 default-mouse-track-extent)
1120 (defun default-mouse-track-return-dragged-selection (event)
1121 (default-mouse-track-cleanup-extent)
1122 (let ((extent default-mouse-track-extent)
1124 (default-mouse-track-set-point-in-window event default-mouse-track-window)
1125 (default-mouse-track-next-move default-mouse-track-min-anchor
1126 default-mouse-track-max-anchor
1128 (cond ((consp extent) ; rectangle-p
1129 (let ((first (car extent))
1130 (last (car (setq extent (nreverse extent)))))
1131 ;; nreverse is destructive so we need to reset this
1132 (setq default-mouse-track-extent extent)
1133 (setq result (cons (extent-start-position first)
1134 (extent-end-position last)))
1135 ;; kludge to fix up region when dragging backwards...
1136 (if (and (/= (point) (extent-start-position first))
1137 (/= (point) (extent-end-position last))
1138 (= (point) (extent-end-position first)))
1139 (goto-char (car result)))))
1141 (setq result (cons (extent-start-position extent)
1142 (extent-end-position extent)))))
1143 ;; Minor kludge: if we're selecting in line-mode, include the
1144 ;; final newline. It's hard to do this in *-normalize-point.
1145 (if (and result (eq default-mouse-track-type 'line))
1146 (let ((end-p (= (point) (cdr result))))
1147 (goto-char (cdr result))
1149 (setcdr result (1+ (cdr result))))
1150 (goto-char (if end-p (cdr result) (car result)))))
1151 ;;; ;; Minor kludge sub 2. If in char mode, and we drag the
1152 ;;; ;; mouse past EOL, include the newline.
1154 ;;; ;; Major problem: can't easily distinguish between being
1155 ;;; ;; just past the last char on a line, and well past it,
1156 ;;; ;; to determine whether or not to include it in the region
1158 ;;; (if nil ; (eq default-mouse-track-type 'char)
1159 ;;; (let ((after-end-p (and (not (eobp))
1161 ;;; (> (point) (car result)))))
1164 ;;; (setcdr result (1+ (cdr result)))
1165 ;;; (goto-char (cdr result))))))
1168 (defun default-mouse-track-drag-up-hook (event click-count)
1169 (let ((result (default-mouse-track-return-dragged-selection event)))
1171 (default-mouse-track-maybe-own-selection result 'PRIMARY)))
1174 (defun default-mouse-track-click-hook (event click-count)
1175 (default-mouse-track-drag-hook event click-count nil)
1176 (default-mouse-track-drag-up-hook event click-count)
1179 (add-hook 'mouse-track-down-hook 'default-mouse-track-down-hook)
1180 (add-hook 'mouse-track-drag-hook 'default-mouse-track-drag-hook)
1181 (add-hook 'mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook)
1182 (add-hook 'mouse-track-click-hook 'default-mouse-track-click-hook)
1183 (add-hook 'mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook)
1186 ;;;;;;;;;;;; other mouse-track stuff (mostly associated with the
1187 ;;;;;;;;;;;; default handlers)
1189 (defun mouse-track-default (event)
1190 "Invoke `mouse-track' with only the default handlers active."
1192 (let ((mouse-track-down-hook 'default-mouse-track-down-hook)
1193 (mouse-track-drag-hook 'default-mouse-track-drag-hook)
1194 (mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook)
1195 (mouse-track-click-hook 'default-mouse-track-click-hook)
1196 (mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook))
1197 (mouse-track event)))
1199 (defun mouse-track-do-rectangle (event)
1200 "Like `mouse-track' but selects rectangles instead of regions."
1202 (let ((mouse-track-rectangle-p t))
1203 (mouse-track event)))
1205 (defun mouse-track-adjust (event)
1206 "Extend the existing selection. This should be bound to a mouse button.
1207 The selection will be enlarged or shrunk so that the point of the mouse
1208 click is one of its endpoints. This function in fact behaves fairly
1209 similarly to `mouse-track', but begins by extending the existing selection
1210 (or creating a new selection from the previous text cursor position to
1211 the current mouse position) instead of creating a new, empty selection.
1213 The mouse-track handlers are run from this command just like from
1214 `mouse-track'. Therefore, do not call this command from a mouse-track
1217 (let ((default-mouse-track-adjust t))
1218 (mouse-track event)))
1220 (defun mouse-track-adjust-default (event)
1221 "Extend the existing selection, using only the default handlers.
1222 This is just like `mouse-track-adjust' but will override any
1223 custom mouse-track handlers that the user may have installed."
1225 (let ((default-mouse-track-adjust t))
1226 (mouse-track-default event)))
1228 (defvar mouse-track-insert-selected-region nil)
1230 (defun mouse-track-insert-drag-up-hook (event click-count)
1231 (setq mouse-track-insert-selected-region
1232 (default-mouse-track-return-dragged-selection event)))
1234 (defun mouse-track-insert (event &optional delete)
1235 "Make a selection with the mouse and insert it at point.
1236 This is exactly the same as the `mouse-track' command on \\[mouse-track],
1237 except that point is not moved; the selected text is immediately inserted
1238 after being selected\; and the selection is immediately disowned afterwards."
1240 (setq mouse-track-insert-selected-region nil)
1241 (let ((mouse-track-drag-up-hook 'mouse-track-insert-drag-up-hook)
1242 (mouse-track-click-hook 'mouse-track-insert-click-hook)
1245 (save-window-excursion
1247 (if (consp mouse-track-insert-selected-region)
1248 (let ((pair mouse-track-insert-selected-region))
1250 (buffer-substring (car pair) (cdr pair))
1252 (kill-region (car pair) (cdr pair)))))))))
1253 (or (null s) (equal s "") (insert s))))
1255 (defun mouse-track-insert-click-hook (event click-count)
1256 (default-mouse-track-drag-hook event click-count nil)
1257 (mouse-track-insert-drag-up-hook event click-count)
1260 (defun mouse-track-delete-and-insert (event)
1261 "Make a selection with the mouse and insert it at point.
1262 This is exactly the same as the `mouse-track' command on \\[mouse-track],
1263 except that point is not moved; the selected text is immediately inserted
1264 after being selected\; and the text of the selection is deleted."
1266 (mouse-track-insert event t))
1268 ;;;;;;;;;;;;;;;;;;;;;;;;
1271 (defvar inhibit-help-echo nil
1272 "Inhibits display of `help-echo' extent properties in the minibuffer.")
1273 (defvar last-help-echo-object nil)
1274 (defvar help-echo-owns-message nil)
1276 (defun clear-help-echo (&optional ignored-frame)
1277 (if help-echo-owns-message
1279 (setq help-echo-owns-message nil
1280 last-help-echo-object nil)
1281 (clear-message 'help-echo))))
1283 (defun show-help-echo (mess)
1284 ;; (clear-help-echo)
1285 (setq help-echo-owns-message t)
1286 (display-message 'help-echo mess))
1288 (add-hook 'mouse-leave-frame-hook 'clear-help-echo)
1290 ;; It may be a good idea to move this to C, for better performance of
1291 ;; extent highlighting and pointer changes.
1292 (defun default-mouse-motion-handler (event)
1293 "For use as the value of `mouse-motion-handler'.
1294 This implements the various pointer-shape variables,
1295 as well as extent highlighting, help-echo, toolbar up/down,
1296 and `mode-motion-hook'."
1297 (let* ((frame (or (event-frame event) (selected-frame)))
1298 (window (event-window event))
1299 (buffer (event-buffer event))
1300 (modeline-point (and buffer (event-modeline-position event)))
1301 (modeline-string (and modeline-point
1302 (symbol-value-in-buffer
1303 'generated-modeline-string buffer)))
1304 ;; point must be invalidated by modeline-point.
1305 (point (and buffer (not modeline-point)
1306 (event-point event)))
1307 (extent (or (and point
1308 (extent-at point buffer 'mouse-face))
1310 (extent-at modeline-point modeline-string
1311 ;; Modeline extents don't have a
1312 ;; mouse-face property set.
1314 (glyph-extent1 (event-glyph-extent event))
1315 (glyph-extent (and glyph-extent1
1316 (extent-live-p glyph-extent1)
1318 ;; This is an extent:
1319 (user-pointer1 (or (and glyph-extent
1320 (extent-property glyph-extent 'pointer)
1322 (and point (extent-at point buffer 'pointer))
1324 (extent-at modeline-point modeline-string
1326 ;; And this should be a glyph:
1327 (user-pointer (and user-pointer1 (extent-live-p user-pointer1)
1328 (extent-property user-pointer1 'pointer)))
1329 (button (event-toolbar-button event))
1330 (help (or (and glyph-extent (extent-property glyph-extent 'help-echo)
1332 (and button (not (null (toolbar-button-help-string button)))
1335 (extent-at point buffer 'help-echo))
1337 (extent-at modeline-point modeline-string
1339 ;; vars is a list of glyph variables to check for a pointer
1342 ;; Checking if button is non-nil is not sufficent
1343 ;; since the pointer could be over a blank portion
1345 ((event-over-toolbar-p event)
1346 '(toolbar-pointer-glyph nontext-pointer-glyph
1347 text-pointer-glyph))
1348 ((or extent glyph-extent)
1349 '(selection-pointer-glyph text-pointer-glyph))
1350 ((event-over-modeline-p event)
1351 '(modeline-pointer-glyph nontext-pointer-glyph
1352 text-pointer-glyph))
1353 ((and (event-over-vertical-divider-p event)
1354 ;; #### I disagree with the check below.
1355 ;; Discuss it with Kirill for 21.1. --hniksic
1356 (specifier-instance vertical-divider-always-visible-p
1357 (event-window event)))
1358 '(divider-pointer-glyph nontext-pointer-glyph
1359 text-pointer-glyph))
1360 (point '(text-pointer-glyph))
1361 (buffer '(nontext-pointer-glyph text-pointer-glyph))
1362 (t '(nontext-pointer-glyph text-pointer-glyph))))
1364 (and user-pointer (glyphp user-pointer)
1365 (push 'user-pointer vars))
1366 (while (and vars (not (pointer-image-instance-p pointer)))
1367 (setq pointer (glyph-image-instance (symbol-value (car vars))
1371 (if (pointer-image-instance-p pointer)
1372 (set-frame-pointer frame pointer))
1374 ;; If last-pressed-toolbar-button is not nil, then check and see
1375 ;; if we have moved to a new button and adjust the down flags
1377 (when (and (featurep 'toolbar) toolbar-active)
1378 (unless (eq last-pressed-toolbar-button button)
1379 (release-previous-toolbar-button event)
1380 (and button (press-toolbar-button event))))
1382 (cond (extent (highlight-extent extent t))
1383 (glyph-extent (highlight-extent glyph-extent t))
1384 (t (highlight-extent nil nil)))
1385 (cond ((extentp help)
1386 (or inhibit-help-echo
1387 (eq help last-help-echo-object) ;save some time
1388 (let ((hprop (extent-property help 'help-echo)))
1389 (setq last-help-echo-object help)
1391 (setq hprop (funcall hprop help)))
1392 (and hprop (show-help-echo hprop)))))
1393 ((and (featurep 'toolbar)
1394 (toolbar-button-p help)
1395 (toolbar-button-enabled-p help))
1396 (or (not toolbar-help-enabled)
1397 (eq help last-help-echo-object) ;save some time
1398 (let ((hstring (toolbar-button-help-string button)))
1399 (setq last-help-echo-object help)
1400 (or (stringp hstring)
1401 (setq hstring (funcall hstring help)))
1402 (show-help-echo hstring))))
1403 (last-help-echo-object
1405 (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
1406 (if (and buffer (symbol-value-in-buffer 'mode-motion-hook buffer nil))
1407 (with-current-buffer buffer
1408 (run-hook-with-args 'mode-motion-hook event)
1410 ;; If the mode-motion-hook created a highlightable extent around
1411 ;; the mouse-point, highlight it right away. Otherwise it wouldn't
1412 ;; be highlighted until the *next* motion event came in.
1415 (setq extent (extent-at point
1416 (event-buffer event) ; not buffer
1418 (highlight-extent extent t)))))
1421 (setq mouse-motion-handler 'default-mouse-motion-handler)
1424 ;; Vertical divider dragging
1426 (defun drag-window-divider (event)
1427 "Handle resizing windows by dragging window dividers.
1428 This is an intenal function, normally bound to button1 event in
1429 window-divider-map. You would not call it, but you may bind it to
1430 other mouse buttons."
1432 ;; #### I disagree with the check below.
1433 ;; Discuss it with Kirill for 21.1. --hniksic
1434 (if (not (specifier-instance vertical-divider-always-visible-p
1435 (event-window event)))
1436 (error "Not over a window"))
1437 (let-specifier ((vertical-divider-shadow-thickness
1438 (- (specifier-instance vertical-divider-shadow-thickness
1439 (event-window event)))
1440 (event-window event)))
1441 (let* ((window (event-window event))
1442 (frame (event-channel event))
1443 (last-timestamp (event-timestamp event))
1446 (let* ((edges (window-pixel-edges window))
1447 (old-right (caddr edges))
1448 (old-left (car edges))
1449 (backup-conf (current-window-configuration frame))
1450 (old-edges-all-windows (mapcar 'window-pixel-edges
1453 ;; This is borrowed from modeline.el:
1454 ;; requeue event and quit if this is a misc-user, eval or
1456 ;; quit if this is a button press or release event, or if the event
1457 ;; occurred in some other frame.
1458 ;; drag if this is a mouse motion event and the time
1459 ;; between this event and the last event is greater than
1460 ;; drag-divider-event-lag.
1461 ;; do nothing if this is any other kind of event.
1462 (setq event (next-event event))
1463 (cond ((or (misc-user-event-p event)
1464 (key-press-event-p event))
1465 (setq unread-command-events (nconc unread-command-events
1468 ((button-release-event-p event)
1470 ((button-event-p event)
1472 ((not (motion-event-p event))
1473 (dispatch-event event))
1474 ((not (eq frame (event-frame event)))
1476 ((< (abs (- (event-timestamp event) last-timestamp))
1477 drag-divider-event-lag))
1479 (setq last-timestamp (event-timestamp event))
1480 ;; Enlarge the window, calculating change in characters
1481 ;; of default font. Do not let the window to become
1482 ;; less than alolwed minimum (not because that's critical
1483 ;; for the code performance, just the visual effect is
1484 ;; better: when cursor goes to the left of the next left
1485 ;; divider, the vindow being resized shrinks to minimal
1487 (enlarge-window (max (- window-min-width (window-width window))
1488 (/ (- (event-x-pixel event) old-right)
1489 (face-width 'default window)))
1491 ;; Backout the change if some windows got deleted, or
1492 ;; if the change caused more than two windows to resize
1493 ;; (shifting the whole stack right is ugly), or if the
1494 ;; left window side has slipped (right side cannot be
1495 ;; moved any funrther to the right, so enlarge-window
1496 ;; plays bad games with the left edge.
1497 (if (or (/= (count-windows) (length old-edges-all-windows))
1498 (/= old-left (car (window-pixel-edges window)))
1499 ;; This check is very hairy. We allow any number
1500 ;; of left edges to change, but only to the same
1501 ;; new value. Similar procedure is for the right edges.
1502 (let ((all-that-bad nil)
1505 (mapcar* (lambda (window old-edges)
1506 (let ((new (car (window-pixel-edges window))))
1507 (if (/= new (car old-edges))
1508 (if (and new-left-ok
1509 (/= new-left-ok new))
1510 (setq all-that-bad t)
1511 (setq new-left-ok new)))))
1512 (window-list) old-edges-all-windows)
1513 (mapcar* (lambda (window old-edges)
1514 (let ((new (caddr (window-pixel-edges window))))
1515 (if (/= new (caddr old-edges))
1516 (if (and new-right-ok
1517 (/= new-right-ok new))
1518 (setq all-that-bad t)
1519 (setq new-right-ok new)))))
1520 (window-list) old-edges-all-windows)
1522 (set-window-configuration backup-conf)))))))))
1524 (setq vertical-divider-map (make-keymap))
1525 (define-key vertical-divider-map 'button1 'drag-window-divider)
1527 ;;; mouse.el ends here