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