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