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