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