Mercurial > hg > xemacs-beta
comparison lisp/prim/mouse.el @ 0:376386a54a3c r19-14
Import from CVS: tag r19-14
| author | cvs |
|---|---|
| date | Mon, 13 Aug 2007 08:45:50 +0200 |
| parents | |
| children | 27bc7f280385 |
comparison
equal
deleted
inserted
replaced
| -1:000000000000 | 0:376386a54a3c |
|---|---|
| 1 ;;; mouse.el --- window system-independent mouse support. | |
| 2 ;; Keywords: hardware | |
| 3 | |
| 4 ;; Copyright (C) 1988, 1992, 1993, 1994 Free Software Foundation, Inc. | |
| 5 ;; Copyright (C) 1995 Tinker Systems | |
| 6 ;; Copyright (C) 1995, 1996 Ben Wing. | |
| 7 | |
| 8 ;; This file is part of XEmacs. | |
| 9 | |
| 10 ;; XEmacs is free software; you can redistribute it and/or modify it | |
| 11 ;; under the terms of the GNU General Public License as published by | |
| 12 ;; the Free Software Foundation; either version 2, or (at your option) | |
| 13 ;; any later version. | |
| 14 | |
| 15 ;; XEmacs is distributed in the hope that it will be useful, but | |
| 16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
| 17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU | |
| 18 ;; General Public License for more details. | |
| 19 | |
| 20 ;; You should have received a copy of the GNU General Public License | |
| 21 ;; along with XEmacs; see the file COPYING. If not, write to the Free | |
| 22 ;; Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. | |
| 23 | |
| 24 ;;; Synched up with: Not synched with FSF. Almost completely divergent. | |
| 25 | |
| 26 (provide 'mouse) | |
| 27 | |
| 28 (global-set-key 'button1 'mouse-track) | |
| 29 (global-set-key '(shift button1) 'mouse-track-adjust) | |
| 30 (global-set-key '(control button1) 'mouse-track-insert) | |
| 31 (global-set-key '(control shift button1) 'mouse-track-delete-and-insert) | |
| 32 (global-set-key '(meta button1) 'mouse-track-do-rectangle) | |
| 33 | |
| 34 (global-set-key 'button2 'mouse-yank) | |
| 35 | |
| 36 (defvar mouse-track-rectangle-p nil | |
| 37 "*If true, then dragging out a region with the mouse selects rectangles | |
| 38 instead of simple start/end regions.") | |
| 39 | |
| 40 (defvar mouse-yank-at-point nil | |
| 41 "*If non-nil, the function `mouse-yank' will yank text at the cursor location. | |
| 42 Otherwise, the cursor will be moved to the location of the pointer click before | |
| 43 text is inserted.") | |
| 44 | |
| 45 (defvar mouse-yank-function 'yank ; x11/x-mouse changes this... | |
| 46 "Function that is called upon by `mouse-yank' to actually insert text.") | |
| 47 | |
| 48 | |
| 49 (defun mouse-select () | |
| 50 "Select Emacs window the mouse is on." | |
| 51 (interactive "@")) | |
| 52 | |
| 53 (defun mouse-delete-window () | |
| 54 "Delete the Emacs window the mouse is on." | |
| 55 (interactive "@") | |
| 56 (delete-window)) | |
| 57 | |
| 58 (defun mouse-keep-one-window () | |
| 59 "Select Emacs window mouse is on, then kill all other Emacs windows." | |
| 60 (interactive "@") | |
| 61 (delete-other-windows)) | |
| 62 | |
| 63 (defun mouse-select-and-split () | |
| 64 "Select Emacs window mouse is on, then split it vertically in half." | |
| 65 (interactive "@") | |
| 66 (split-window-vertically nil)) | |
| 67 | |
| 68 (defun mouse-set-point (event) | |
| 69 "Select Emacs window mouse is on, and move point to mouse position." | |
| 70 (interactive "@e") | |
| 71 (let ((window (event-window event)) | |
| 72 (pos (event-point event)) | |
| 73 (close-pos (event-closest-point event))) | |
| 74 (or window (error "not in a window")) | |
| 75 (select-window window) | |
| 76 (if (and pos (> pos 0)) | |
| 77 ;; If the event was over a text char, it's easy. | |
| 78 (goto-char (max (min pos (point-max)) (point-min))) | |
| 79 (if (and close-pos (> close-pos 0)) | |
| 80 (goto-char (max (min close-pos (point-max)) (point-min))) | |
| 81 ;; When the event occurs outside of the frame directly to the | |
| 82 ;; left or right of a modeline, close-point is nil, but | |
| 83 ;; event-over-modeline is also nil. That will drop us to this | |
| 84 ;; point. So instead of erroring, just return nil. | |
| 85 nil)))) | |
| 86 | |
| 87 (defun mouse-yank (event) | |
| 88 "Paste text with the mouse. | |
| 89 If the variable `mouse-yank-at-point' is nil, then pasting occurs at the | |
| 90 location of the click; otherwise, pasting occurs at the current cursor | |
| 91 location." | |
| 92 (interactive "e") | |
| 93 (and (not mouse-yank-at-point) | |
| 94 (mouse-set-point event)) | |
| 95 (funcall mouse-yank-function)) | |
| 96 | |
| 97 (defun click-inside-extent-p (click extent) | |
| 98 "Returns non-nil if the button event is within the bounds of the primary | |
| 99 selection-extent, nil otherwise." | |
| 100 ;; stig@hackvan.com | |
| 101 (let ((ewin (event-window click)) | |
| 102 (epnt (event-point click))) | |
| 103 (and ewin | |
| 104 epnt | |
| 105 extent | |
| 106 (eq (window-buffer ewin) | |
| 107 (extent-object extent)) | |
| 108 (extent-start-position extent) | |
| 109 (> epnt (extent-start-position extent)) | |
| 110 (> (extent-end-position extent) epnt)))) | |
| 111 | |
| 112 (defun click-inside-selection-p (click) | |
| 113 (or (click-inside-extent-p click primary-selection-extent) | |
| 114 (click-inside-extent-p click zmacs-region-extent) | |
| 115 )) | |
| 116 | |
| 117 (defun point-inside-extent-p (extent) | |
| 118 "Returns non-nil if the point is within or just after the bounds of the | |
| 119 primary selection-extent, nil otherwise." | |
| 120 ;; stig@hackvan.com | |
| 121 (and extent | |
| 122 (eq (current-buffer) | |
| 123 (extent-object extent)) | |
| 124 (> (point) (extent-start-position extent)) | |
| 125 (>= (extent-end-position extent) (point)))) | |
| 126 | |
| 127 (defun point-inside-selection-p () | |
| 128 ;; by Stig@hackvan.com | |
| 129 (or (point-inside-extent-p primary-selection-extent) | |
| 130 (point-inside-extent-p zmacs-region-extent))) | |
| 131 | |
| 132 ;;; #### - finish this... | |
| 133 ;;; (defun mouse-drag-or-yank (event) | |
| 134 ;;; "Either drag or paste the current selection. If the variable | |
| 135 ;;; `mouse-yank-at-point' is non-nil, then moves the cursor to the location of | |
| 136 ;;; the click before pasting." | |
| 137 ;;; (interactive "e") | |
| 138 ;;; (if (click-inside-selection-p event) | |
| 139 ;;; ;; okay, this is a drag | |
| 140 ;;; ) | |
| 141 ;;; ) | |
| 142 | |
| 143 (defun mouse-eval-sexp (click force-window) | |
| 144 "Evaluate the sexp under the mouse. Usually, this is the last sexp before | |
| 145 the click, but if you click on a left paren, then it is the sexp beginning | |
| 146 with the paren that is evaluated. Also, since strings evaluate to themselves, | |
| 147 they're fed to re-search-forward and the matched region is highlighted until | |
| 148 the mouse button is released. | |
| 149 | |
| 150 Perhaps the most useful thing about this function is that the evaluation of | |
| 151 the expression which is clicked upon is relative not to the window where you | |
| 152 click, but to the current window and the current position of point. Thus, | |
| 153 you can use `mouse-eval-sexp' to interactively test code that acts upon a | |
| 154 buffer...something you cannot do with the standard `eval-last-sexp' function. | |
| 155 It's also fantastic for debugging regular expressions." | |
| 156 ;; by Stig@hackvan.com | |
| 157 (interactive "e\nP") | |
| 158 (let (exp val result-str) | |
| 159 (setq exp (save-window-excursion | |
| 160 (save-excursion | |
| 161 (mouse-set-point click) | |
| 162 (save-excursion | |
| 163 (or (looking-at "(") (forward-sexp -1)) | |
| 164 (read (point-marker)))))) | |
| 165 (cond ((stringp exp) | |
| 166 (if (setq val (re-search-forward exp nil t)) | |
| 167 (let* ((oo (make-extent (match-beginning 0) (match-end 0)))) | |
| 168 (set-extent-face oo 'highlight) | |
| 169 (set-extent-priority oo 1000) | |
| 170 ;; wait for button release... | |
| 171 (setq unread-command-event (next-command-event)) | |
| 172 (delete-extent oo)) | |
| 173 (message "Regex \"%s\" not found" exp) | |
| 174 (ding nil 'quiet))) | |
| 175 (t (setq val (if (fboundp 'eval-interactive) | |
| 176 (eval-interactive exp) | |
| 177 (eval exp))))) | |
| 178 (setq result-str (prin1-to-string val)) | |
| 179 ;; #### -- need better test | |
| 180 (if (and (not force-window) | |
| 181 (<= (length result-str) (window-width (selected-window)))) | |
| 182 (message "%s" result-str) | |
| 183 (with-output-to-temp-buffer "*Mouse-Eval*" | |
| 184 (condition-case nil | |
| 185 (pprint val) | |
| 186 (error (prin1 val)))) | |
| 187 ))) | |
| 188 | |
| 189 (defun mouse-line-length (event) | |
| 190 "Print the length of the line indicated by the pointer." | |
| 191 (interactive "@e") | |
| 192 (save-excursion | |
| 193 (mouse-set-point event) | |
| 194 (message "Line length: %d" (- (progn (end-of-line) (point)) | |
| 195 (progn (beginning-of-line) (point))))) | |
| 196 (sleep-for 1)) | |
| 197 | |
| 198 (defun mouse-set-mark (event) | |
| 199 "Select Emacs window mouse is on, and set mark at mouse position. | |
| 200 Display cursor at that position for a second." | |
| 201 (interactive "@e") | |
| 202 (let ((point-save (point))) | |
| 203 (unwind-protect | |
| 204 (progn (mouse-set-point event) | |
| 205 (push-mark nil t) | |
| 206 (sit-for 1)) | |
| 207 (goto-char point-save)))) | |
| 208 | |
| 209 (defun mouse-scroll (event) | |
| 210 "Scroll point to the mouse position." | |
| 211 (interactive "@e") | |
| 212 (save-excursion | |
| 213 (mouse-set-point event) | |
| 214 (recenter 0) | |
| 215 (scroll-right (event-x event)))) | |
| 216 | |
| 217 (defun mouse-del-char (event) | |
| 218 "Delete the char pointed to by the mouse." | |
| 219 (interactive "@e") | |
| 220 (save-excursion | |
| 221 (mouse-set-point event) | |
| 222 (delete-char 1 nil))) | |
| 223 | |
| 224 (defun mouse-kill-line (event) | |
| 225 "Kill the line pointed to by the mouse." | |
| 226 (interactive "@e") | |
| 227 (save-excursion | |
| 228 (mouse-set-point event) | |
| 229 (kill-line nil))) | |
| 230 | |
| 231 (defun mouse-bury-buffer (event) | |
| 232 "Bury the buffer pointed to by the mouse, thus selecting the next one." | |
| 233 (interactive "e") | |
| 234 (save-selected-window | |
| 235 (select-window (event-window event)) | |
| 236 (bury-buffer))) | |
| 237 | |
| 238 (defun mouse-unbury-buffer (event) | |
| 239 "Unbury and select the most recently buried buffer." | |
| 240 (interactive "e") | |
| 241 (save-selected-window | |
| 242 (select-window (event-window event)) | |
| 243 (let* ((bufs (buffer-list)) | |
| 244 (entry (1- (length bufs))) | |
| 245 val) | |
| 246 (while (not (setq val (nth entry bufs) | |
| 247 val (and (/= (aref (buffer-name val) 0) | |
| 248 ? ) | |
| 249 val))) | |
| 250 (setq entry (1- entry))) | |
| 251 (switch-to-buffer val)))) | |
| 252 | |
| 253 (defun narrow-window-to-region (m n) | |
| 254 "Narrow window to region between point and last mark" | |
| 255 (interactive "r") | |
| 256 (save-excursion | |
| 257 (save-restriction | |
| 258 (if (eq (selected-window) (next-window)) | |
| 259 (split-window)) | |
| 260 (goto-char m) | |
| 261 (recenter 0) | |
| 262 (if (eq (selected-window) | |
| 263 (if (zerop (minibuffer-depth)) | |
| 264 (next-window))) | |
| 265 () | |
| 266 (shrink-window (- (- (window-height) (count-lines m n)) 1)))))) | |
| 267 | |
| 268 (defun mouse-window-to-region (event) | |
| 269 "Narrow window to region between cursor and mouse pointer." | |
| 270 (interactive "@e") | |
| 271 (let ((point-save (point))) | |
| 272 (unwind-protect | |
| 273 (progn (mouse-set-point event) | |
| 274 (push-mark nil t) | |
| 275 (sit-for 1)) | |
| 276 (goto-char point-save) | |
| 277 (narrow-window-to-region (region-beginning) (region-end))))) | |
| 278 | |
| 279 (defun mouse-ignore () | |
| 280 "Don't do anything." | |
| 281 (interactive)) | |
| 282 | |
| 283 | |
| 284 ;; | |
| 285 ;; Commands for the scroll bar. | |
| 286 ;; | |
| 287 | |
| 288 ;; #### this stuff has never ever been used and should be junked. | |
| 289 | |
| 290 ;; Vertical bar | |
| 291 | |
| 292 (defun mouse-scroll-down (nlines) | |
| 293 "Junk me, please." | |
| 294 (interactive "@p") | |
| 295 (scroll-down nlines)) | |
| 296 | |
| 297 (defun mouse-scroll-up (nlines) | |
| 298 "Junk me, please." | |
| 299 (interactive "@p") | |
| 300 (scroll-up nlines)) | |
| 301 | |
| 302 (defun mouse-scroll-down-full () | |
| 303 "Junk me, please." | |
| 304 (interactive "@") | |
| 305 (scroll-down nil)) | |
| 306 | |
| 307 (defun mouse-scroll-up-full () | |
| 308 "Junk me, please." | |
| 309 (interactive "@") | |
| 310 (scroll-up nil)) | |
| 311 | |
| 312 (defun mouse-scroll-move-cursor (nlines) | |
| 313 "Junk me, please." | |
| 314 (interactive "@p") | |
| 315 (move-to-window-line nlines)) | |
| 316 | |
| 317 (defun mouse-scroll-absolute (event) | |
| 318 "Junk me, please." | |
| 319 (interactive "@e") | |
| 320 (let* ((position (event-x event)) | |
| 321 (length (event-y event)) | |
| 322 (size (buffer-size)) | |
| 323 (scale-factor (max 1 (/ 8000000 size))) | |
| 324 (newpos (* (/ (* (/ size scale-factor) position) length) | |
| 325 scale-factor))) | |
| 326 (goto-char newpos) | |
| 327 (recenter '(4)))) | |
| 328 | |
| 329 ;; These scroll while the invoking button is depressed. | |
| 330 | |
| 331 (defvar scrolled-lines 0) | |
| 332 (defvar scroll-speed 1) | |
| 333 | |
| 334 (defun incr-scroll-down (event) | |
| 335 "Junk me, please." | |
| 336 (interactive "@e") | |
| 337 (setq scrolled-lines 0) | |
| 338 (incremental-scroll scroll-speed)) | |
| 339 | |
| 340 (defun incr-scroll-up (event) | |
| 341 "Junk me, please." | |
| 342 (interactive "@e") | |
| 343 (setq scrolled-lines 0) | |
| 344 (incremental-scroll (- scroll-speed))) | |
| 345 | |
| 346 (defun incremental-scroll (n) | |
| 347 "Junk me, please." | |
| 348 (let ((down t)) | |
| 349 (while down | |
| 350 (sit-for mouse-track-scroll-delay) | |
| 351 (cond ((input-pending-p) | |
| 352 (let ((event (next-command-event))) | |
| 353 (if (or (button-press-event-p event) | |
| 354 (button-release-event-p event)) | |
| 355 (setq down nil)) | |
| 356 (dispatch-event event)))) | |
| 357 (setq scrolled-lines (1+ (* scroll-speed scrolled-lines))) | |
| 358 (scroll-down n)))) | |
| 359 | |
| 360 (defun incr-scroll-stop (event) | |
| 361 "Junk me, please." | |
| 362 (interactive "@e") | |
| 363 (setq scrolled-lines 0) | |
| 364 (sleep-for 1)) | |
| 365 | |
| 366 | |
| 367 (defun mouse-scroll-left (ncolumns) | |
| 368 "Junk me, please." | |
| 369 (interactive "@p") | |
| 370 (scroll-left ncolumns)) | |
| 371 | |
| 372 (defun mouse-scroll-right (ncolumns) | |
| 373 "Junk me, please." | |
| 374 (interactive "@p") | |
| 375 (scroll-right ncolumns)) | |
| 376 | |
| 377 (defun mouse-scroll-left-full () | |
| 378 "Junk me, please." | |
| 379 (interactive "@") | |
| 380 (scroll-left nil)) | |
| 381 | |
| 382 (defun mouse-scroll-right-full () | |
| 383 "Junk me, please." | |
| 384 (interactive "@") | |
| 385 (scroll-right nil)) | |
| 386 | |
| 387 (defun mouse-scroll-move-cursor-horizontally (ncolumns) | |
| 388 "Junk me, please." | |
| 389 (interactive "@p") | |
| 390 (move-to-column ncolumns)) | |
| 391 | |
| 392 (defun mouse-scroll-absolute-horizontally (event) | |
| 393 "Junk me, please." | |
| 394 (interactive "@e") | |
| 395 (set-window-hscroll (selected-window) 33)) | |
| 396 | |
| 397 | |
| 398 | |
| 399 ;;; mouse/selection tracking | |
| 400 ;;; generalized mouse-track | |
| 401 | |
| 402 (defvar mouse-track-down-hook nil | |
| 403 "Function or functions called when the user presses the mouse. | |
| 404 This hook is invoked by `mouse-track'; thus, it will not be called | |
| 405 for any buttons with a different binding. The functions will be | |
| 406 called with two arguments: the button-press event and a click | |
| 407 count (see `mouse-track-click-hook'). | |
| 408 | |
| 409 If any function returns non-nil, the remaining functions will not be | |
| 410 called. | |
| 411 | |
| 412 Note that most applications should take action when the mouse is | |
| 413 released, not when it is pressed.'") | |
| 414 | |
| 415 (defvar mouse-track-drag-hook nil | |
| 416 "Function or functions called when the user drags the mouse. | |
| 417 This hook is invoked by `mouse-track'; thus, it will not be called | |
| 418 for any buttons with a different binding. The functions will be | |
| 419 called with three arguments: the mouse-motion event, a click | |
| 420 count (see `mouse-track-click-hook'), and whether the call to | |
| 421 this hook occurred as a result of a drag timeout (see | |
| 422 `mouse-track-scroll-delay'). | |
| 423 | |
| 424 If any function returns non-nil, the remaining functions will not be | |
| 425 called. | |
| 426 | |
| 427 Note that no calls to this function will be made until the user | |
| 428 initiates a drag (i.e. moves the mouse more than a certain | |
| 429 threshold in either the X or the Y direction, as defined by | |
| 430 `mouse-track-x-threshold' and `mouse-track-y-threshold'). | |
| 431 | |
| 432 See also `mouse-track-drag-up-hook'.") | |
| 433 | |
| 434 (defvar mouse-track-drag-up-hook nil | |
| 435 "Function or functions called when the user finishes a drag. | |
| 436 This hook is invoked by `mouse-track'; thus, it will not be called | |
| 437 for any buttons with a different binding. The functions will be | |
| 438 called with two arguments: the button-press event and a click | |
| 439 count (see `mouse-track-click-hook'). | |
| 440 | |
| 441 If any function returns non-nil, the remaining functions will not be | |
| 442 called. | |
| 443 | |
| 444 Note that this hook will not be invoked unless the user has | |
| 445 initiated a drag, i.e. moved the mouse more than a certain threshold | |
| 446 (see `mouse-track-drag-hook'). When this function is invoked, | |
| 447 `mouse-track-drag-hook' will have been invoked at least once. | |
| 448 | |
| 449 See also `mouse-track-click-hook'.") | |
| 450 | |
| 451 (defvar mouse-track-click-hook nil | |
| 452 "Function or functions called when the user clicks the mouse. | |
| 453 `Clicking' means pressing and releasing the mouse without having | |
| 454 initiated a drag (i.e. without having moved more than a certain | |
| 455 threshold -- see `mouse-track-drag-hook'). | |
| 456 | |
| 457 This hook is invoked by `mouse-track'; thus, it will not be called | |
| 458 for any buttons with a different binding. The functions will be | |
| 459 called with two arguments: the button-release event and a click | |
| 460 count, which specifies the number of times that the mouse has been | |
| 461 clicked in a series of clicks, each of which is separated by at most | |
| 462 `mouse-track-multi-click-time'. This can be used to implement actions | |
| 463 that are called on double clicks, triple clicks, etc. | |
| 464 | |
| 465 If any function returns non-nil, the remaining functions will not be | |
| 466 called. | |
| 467 | |
| 468 See also `mouse-track-drag-up-hook.") | |
| 469 | |
| 470 (defvar mouse-track-up-hook nil | |
| 471 "Function or functions called when the user releases the mouse. | |
| 472 This hook is invoked by `mouse-track'; thus, it will not be called | |
| 473 for any buttons with a different binding. The functions will be | |
| 474 called with two arguments: the button-release event and a click | |
| 475 count (see `mouse-track-click-hook'). | |
| 476 | |
| 477 For many applications, it is more appropriate to use one or both | |
| 478 of `mouse-track-click-hook' and `mouse-track-drag-up-hook'.") | |
| 479 | |
| 480 (defvar mouse-track-cleanup-hook nil | |
| 481 "Function or functions called when `mouse-track' terminates. | |
| 482 This hook will be called in all circumstances, even upon a | |
| 483 non-local exit out of `mouse-track', and so is useful for | |
| 484 doing cleanup work such as removing extents that may have | |
| 485 been created during the operation of `mouse-track'. | |
| 486 | |
| 487 Unlike all of the other mouse-track hooks, this is a \"normal\" | |
| 488 hook: the hook functions are called with no arguments, and | |
| 489 all hook functions are called regardless of their return | |
| 490 values.") | |
| 491 | |
| 492 (defvar mouse-track-multi-click-time 400 | |
| 493 "Maximum number of milliseconds allowed between clicks for a multi-click. | |
| 494 See `mouse-track-click-hook'.") | |
| 495 | |
| 496 (defvar mouse-track-scroll-delay 100 | |
| 497 "Maximum of milliseconds between calls to `mouse-track-drag-hook'. | |
| 498 If the user is dragging the mouse (i.e. the button is held down and | |
| 499 a drag has been initiated) and does not move the mouse for this many | |
| 500 milliseconds, the hook will be called with t as the value of the | |
| 501 WAS-TIMEOUT parameter. This can be used to implement scrolling | |
| 502 in a selection when the user drags the mouse out the window it | |
| 503 was in. | |
| 504 | |
| 505 A value of nil disables the timeout feature.") | |
| 506 | |
| 507 (defvar mouse-track-x-threshold '(face-width 'default) | |
| 508 "Minimum number of pixels in the X direction for a drag to be initiated. | |
| 509 If the mouse is moved more than either the X or Y threshold while the | |
| 510 button is held down (see also `mouse-track-y-threshold'), then a drag | |
| 511 is initiated; otherwise the gesture is considered to be a click. | |
| 512 See `mouse-track'. | |
| 513 | |
| 514 The value should be either a number of a form to be evaluated to | |
| 515 produce a number.") | |
| 516 | |
| 517 (defvar mouse-track-y-threshold '(face-height 'default) | |
| 518 "Minimum number of pixels in the Y direction for a drag to be initiated. | |
| 519 If the mouse is moved more than either the X or Y threshold while the | |
| 520 button is held down (see also `mouse-track-x-threshold'), then a drag | |
| 521 is initiated; otherwise the gesture is considered to be a click. | |
| 522 See `mouse-track'. | |
| 523 | |
| 524 The value should be either a number of a form to be evaluated to | |
| 525 produce a number.") | |
| 526 | |
| 527 ;; these variables are private to mouse-track. | |
| 528 (defvar mouse-track-up-time nil) | |
| 529 (defvar mouse-track-up-x nil) | |
| 530 (defvar mouse-track-up-y nil) | |
| 531 (defvar mouse-track-timeout-id nil) | |
| 532 (defvar mouse-track-click-count nil) | |
| 533 | |
| 534 (defun mouse-track-set-timeout (event) | |
| 535 (if mouse-track-timeout-id | |
| 536 (disable-timeout mouse-track-timeout-id)) | |
| 537 (if mouse-track-scroll-delay | |
| 538 (setq mouse-track-timeout-id | |
| 539 (add-timeout (/ mouse-track-scroll-delay 1000.0) | |
| 540 'mouse-track-scroll-undefined | |
| 541 (copy-event event))))) | |
| 542 | |
| 543 (defun mouse-track-run-hook (hook event &rest args) | |
| 544 ;; ugh, can't use run-special-hook-with-args because we | |
| 545 ;; have to get the value using symbol-value-in-buffer. | |
| 546 ;; Doing a save-excursion/set-buffer is wrong because | |
| 547 ;; the hook might want to change the buffer, but just | |
| 548 ;; doing a set-buffer is wrong because the hook might | |
| 549 ;; not want to change the buffer. | |
| 550 (let ((buffer (event-buffer event))) | |
| 551 (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer)) | |
| 552 (if buffer | |
| 553 (let ((value (symbol-value-in-buffer hook buffer nil))) | |
| 554 (if (and (listp value) (not (eq (car value) 'lambda))) | |
| 555 (let (retval) | |
| 556 (while (and value | |
| 557 (not (setq retval (apply (car value) event args)))) | |
| 558 (setq value (cdr value))) | |
| 559 retval) | |
| 560 (apply value event args)))))) | |
| 561 | |
| 562 (defun mouse-track-scroll-undefined (random) | |
| 563 ;; the old implementation didn't actually define this function, | |
| 564 ;; and in normal use it won't ever be called because the timeout | |
| 565 ;; will either be removed before it fires or will be picked off | |
| 566 ;; with next-event and not dispatched. However, if you're | |
| 567 ;; attempting to debug a click-hook (which is pretty damn | |
| 568 ;; difficult to do), this function may get called. | |
| 569 ) | |
| 570 | |
| 571 (defun mouse-track (event) | |
| 572 "Make a selection with the mouse. This should be bound to a mouse button. | |
| 573 The behavior of XEmacs during mouse selection is customizable using various | |
| 574 hooks and variables: see `mouse-track-click-hook', `mouse-track-drag-hook', | |
| 575 `mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook', | |
| 576 `mouse-track-cleanup-hook', `mouse-track-multi-click-time', | |
| 577 `mouse-track-scroll-delay', `mouse-track-x-threshold', and | |
| 578 `mouse-track-y-threshold'. | |
| 579 | |
| 580 Default handlers are provided to implement standard selecting/positioning | |
| 581 behavior. You can explicitly request this default behavior, and override | |
| 582 any custom-supplied handlers, by using the function `mouse-track-default' | |
| 583 instead of `mouse-track'. | |
| 584 | |
| 585 Default behavior is as follows: | |
| 586 | |
| 587 If you click-and-drag, the selection will be set to the region between the | |
| 588 point of the initial click and the point at which you release the button. | |
| 589 These positions need not be ordered. | |
| 590 | |
| 591 If you click-and-release without moving the mouse, then the point is moved | |
| 592 and the selection is disowned (there will be no selection owner). The mark | |
| 593 will be set to the previous position of point. | |
| 594 | |
| 595 If you double-click, the selection will extend by symbols instead of by | |
| 596 characters. If you triple-click, the selection will extend by lines. | |
| 597 | |
| 598 If you drag the mouse off the top or bottom of the window, you can select | |
| 599 pieces of text which are larger than the visible part of the buffer; the | |
| 600 buffer will scroll as necessary. | |
| 601 | |
| 602 The selected text becomes the current X Selection. The point will be left | |
| 603 at the position at which you released the button, and the mark will be left | |
| 604 at the initial click position." | |
| 605 (interactive "e") | |
| 606 (let ((mouse-down t) | |
| 607 (xthresh (eval mouse-track-x-threshold)) | |
| 608 (ythresh (eval mouse-track-y-threshold)) | |
| 609 (orig-x (event-x-pixel event)) | |
| 610 (orig-y (event-y-pixel event)) | |
| 611 (buffer (event-buffer event)) | |
| 612 (mouse-grabbed-buffer (event-buffer event)) | |
| 613 mouse-moved) | |
| 614 (if (or (not mouse-track-up-x) | |
| 615 (not mouse-track-up-y) | |
| 616 (not mouse-track-up-time) | |
| 617 (> (- (event-timestamp event) mouse-track-up-time) | |
| 618 mouse-track-multi-click-time) | |
| 619 (> (abs (- mouse-track-up-x orig-x)) xthresh) | |
| 620 (> (abs (- mouse-track-up-y orig-y)) ythresh)) | |
| 621 (setq mouse-track-click-count 1) | |
| 622 (setq mouse-track-click-count (1+ mouse-track-click-count))) | |
| 623 (if (not (event-window event)) | |
| 624 (error "Not over a window.")) | |
| 625 (mouse-track-run-hook 'mouse-track-down-hook | |
| 626 event mouse-track-click-count) | |
| 627 (unwind-protect | |
| 628 (while mouse-down | |
| 629 (setq event (next-event event)) | |
| 630 (cond ((motion-event-p event) | |
| 631 (if (and (not mouse-moved) | |
| 632 (or (> (abs (- (event-x-pixel event) orig-x)) | |
| 633 xthresh) | |
| 634 (> (abs (- (event-y-pixel event) orig-y)) | |
| 635 ythresh))) | |
| 636 (setq mouse-moved t)) | |
| 637 (if mouse-moved | |
| 638 (mouse-track-run-hook 'mouse-track-drag-hook | |
| 639 event mouse-track-click-count nil)) | |
| 640 (mouse-track-set-timeout event)) | |
| 641 ((and (timeout-event-p event) | |
| 642 (eq (event-function event) | |
| 643 'mouse-track-scroll-undefined)) | |
| 644 (if mouse-moved | |
| 645 (mouse-track-run-hook 'mouse-track-drag-hook | |
| 646 (event-object event) mouse-track-click-count t)) | |
| 647 (mouse-track-set-timeout (event-object event))) | |
| 648 ((button-release-event-p event) | |
| 649 (setq mouse-track-up-time (event-timestamp event)) | |
| 650 (setq mouse-track-up-x (event-x-pixel event)) | |
| 651 (setq mouse-track-up-y (event-y-pixel event)) | |
| 652 (setq mouse-down nil) | |
| 653 (mouse-track-run-hook 'mouse-track-up-hook | |
| 654 event mouse-track-click-count) | |
| 655 (if mouse-moved | |
| 656 (mouse-track-run-hook 'mouse-track-drag-up-hook | |
| 657 event mouse-track-click-count) | |
| 658 (mouse-track-run-hook 'mouse-track-click-hook | |
| 659 event mouse-track-click-count))) | |
| 660 ((key-press-event-p event) | |
| 661 (error "Selection aborted")) | |
| 662 (t | |
| 663 (dispatch-event event)))) | |
| 664 ;; protected | |
| 665 (if mouse-track-timeout-id | |
| 666 (disable-timeout mouse-track-timeout-id)) | |
| 667 (setq mouse-track-timeout-id nil) | |
| 668 (and buffer | |
| 669 (save-excursion | |
| 670 (set-buffer buffer) | |
| 671 (run-hooks 'mouse-track-cleanup-hook)))))) | |
| 672 | |
| 673 | |
| 674 ;;;;;;;;;;;; default handlers: new version of mouse-track | |
| 675 | |
| 676 (defvar default-mouse-track-type nil) | |
| 677 (defvar default-mouse-track-type-list '(char word line)) | |
| 678 (defvar default-mouse-track-window nil) | |
| 679 (defvar default-mouse-track-extent nil) | |
| 680 (defvar default-mouse-track-adjust nil) | |
| 681 (defvar default-mouse-track-min-anchor nil) | |
| 682 (defvar default-mouse-track-max-anchor nil) | |
| 683 (defvar default-mouse-track-result nil) | |
| 684 (defvar default-mouse-track-down-event nil) | |
| 685 | |
| 686 (defun default-mouse-track-set-point-in-window (event window) | |
| 687 (if (not (and (not (event-over-modeline-p event)) | |
| 688 (eq (event-window event) window) | |
| 689 (let ((p (event-closest-point event))) | |
| 690 (and p (pos-visible-in-window-p p window))))) | |
| 691 nil | |
| 692 (mouse-set-point event) | |
| 693 t)) | |
| 694 | |
| 695 (defun default-mouse-track-scroll-and-set-point (event window) | |
| 696 (select-window window) | |
| 697 (let ((edges (window-pixel-edges window)) | |
| 698 (row (event-y-pixel event)) | |
| 699 (height (face-height 'default))) | |
| 700 (cond ((< (abs (- row (nth 1 edges))) (abs (- row (nth 3 edges)))) | |
| 701 ;; closer to window's top than to bottom, so move up | |
| 702 (let ((delta (max 1 (/ (- (nth 1 edges) row) height)))) | |
| 703 (condition-case () (scroll-down delta) (error)) | |
| 704 (goto-char (window-start)))) | |
| 705 ((>= (point) (point-max))) | |
| 706 (t | |
| 707 ;; scroll by one line if over the modeline or a clipped line | |
| 708 (let ((delta (if (or (event-over-modeline-p event) | |
| 709 (< row (nth 3 edges))) | |
| 710 1 | |
| 711 (+ (/ (- row (nth 3 edges)) height) 1))) | |
| 712 (close-pos (event-closest-point event))) | |
| 713 (condition-case () (scroll-up delta) (error)) | |
| 714 (if (and close-pos (pos-visible-in-window-p close-pos)) | |
| 715 (goto-char close-pos) | |
| 716 (goto-char (window-end)) | |
| 717 (vertical-motion delta) | |
| 718 ;; window-end reports the end of the clipped line, even if | |
| 719 ;; scroll-on-clipped-lines is t. compensate. | |
| 720 ;; (If window-end gets fixed this can be removed.) | |
| 721 (if (not (pos-visible-in-window-p (max (1- (point)) | |
| 722 (point-min)))) | |
| 723 (vertical-motion -1)) | |
| 724 (condition-case () (backward-char 1) | |
| 725 (error (end-of-line))))))))) | |
| 726 | |
| 727 | |
| 728 ;; This remembers the last position at which the user clicked, for the | |
| 729 ;; benefit of mouse-track-adjust (for example, button1; scroll until the | |
| 730 ;; position of the click is off the frame; then Sh-button1 to select the | |
| 731 ;; new region. | |
| 732 (defvar default-mouse-track-previous-point nil) | |
| 733 | |
| 734 (defun default-mouse-track-set-point (event window) | |
| 735 (if (default-mouse-track-set-point-in-window event window) | |
| 736 nil | |
| 737 (default-mouse-track-scroll-and-set-point event window))) | |
| 738 | |
| 739 (defsubst default-mouse-track-beginning-of-word (symbolp) | |
| 740 (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'") | |
| 741 ((null symbolp) "\\w") | |
| 742 (t "[^ \t\n]"))) | |
| 743 (white-space "[ \t]")) | |
| 744 (cond ((bobp) nil) | |
| 745 ((looking-at word-constituent) | |
| 746 (backward-char) | |
| 747 (while (and (not (bobp)) (looking-at word-constituent)) | |
| 748 (backward-char)) | |
| 749 (if (or (not (bobp)) (not (looking-at word-constituent))) | |
| 750 (forward-char))) | |
| 751 ((looking-at white-space) | |
| 752 (backward-char) | |
| 753 (while (looking-at white-space) | |
| 754 (backward-char)) | |
| 755 (forward-char))))) | |
| 756 | |
| 757 (defun default-mouse-track-end-of-word (symbolp) | |
| 758 (let ((word-constituent (cond ((eq symbolp t) "\\w\\|\\s_\\|\\s'") | |
| 759 ((null symbolp) "\\w") | |
| 760 (t "[^ \t\n]"))) | |
| 761 (white-space "[ \t]")) | |
| 762 (cond ((looking-at word-constituent) ; word or symbol constituent | |
| 763 (while (looking-at word-constituent) | |
| 764 (forward-char))) | |
| 765 ((looking-at white-space) ; word or symbol constituent | |
| 766 (while (looking-at white-space) | |
| 767 (forward-char)))))) | |
| 768 | |
| 769 (defun default-mouse-track-normalize-point (type forwardp) | |
| 770 (cond ((eq type 'word) | |
| 771 ;; trap the beginning and end of buffer errors | |
| 772 (condition-case () | |
| 773 (if forwardp | |
| 774 (default-mouse-track-end-of-word t) | |
| 775 (default-mouse-track-beginning-of-word t)) | |
| 776 (error ()))) | |
| 777 ((eq type 'line) | |
| 778 (if forwardp (end-of-line) (beginning-of-line))) | |
| 779 ((eq type 'buffer) | |
| 780 (if forwardp (end-of-buffer) (beginning-of-buffer))))) | |
| 781 | |
| 782 (defun default-mouse-track-next-move (min-anchor max-anchor extent) | |
| 783 (let ((anchor (if (<= (point) min-anchor) max-anchor min-anchor))) | |
| 784 (default-mouse-track-normalize-point | |
| 785 default-mouse-track-type (> (point) anchor)) | |
| 786 (if (consp extent) | |
| 787 (default-mouse-track-next-move-rect anchor (point) extent) | |
| 788 (if extent | |
| 789 (if (<= anchor (point)) | |
| 790 (set-extent-endpoints extent anchor (point)) | |
| 791 (set-extent-endpoints extent (point) anchor)))))) | |
| 792 | |
| 793 (defun default-mouse-track-next-move-rect (start end extents &optional pad-p) | |
| 794 (if (< end start) | |
| 795 (let ((tmp start)) (setq start end end tmp))) | |
| 796 (cond | |
| 797 ((= start end) ; never delete the last remaining extent | |
| 798 (mapcar 'delete-extent (cdr extents)) | |
| 799 (setcdr extents nil) | |
| 800 (set-extent-endpoints (car extents) start start)) | |
| 801 (t | |
| 802 (let ((indent-tabs-mode nil) ; if pad-p, don't use tabs | |
| 803 (rest extents) | |
| 804 left right last p) | |
| 805 (save-excursion | |
| 806 (save-restriction | |
| 807 (goto-char end) | |
| 808 (setq right (current-column)) | |
| 809 (goto-char start) | |
| 810 (setq left (current-column)) | |
| 811 (if (< right left) | |
| 812 (let ((tmp left)) | |
| 813 (setq left right right tmp) | |
| 814 (setq start (- start (- right left)) | |
| 815 end (+ end (- right left))))) | |
| 816 ;; End may have been set to a value greater than point-max if drag | |
| 817 ;; or movement extends to end of buffer, so reset it. | |
| 818 (setq end (min end (point-max))) | |
| 819 (beginning-of-line) | |
| 820 (narrow-to-region (point) end) | |
| 821 (goto-char start) | |
| 822 (while (and rest (not (eobp))) | |
| 823 (setq p (point)) | |
| 824 (move-to-column right pad-p) | |
| 825 (set-extent-endpoints (car rest) p (point)) | |
| 826 ;; this code used to look at the return value | |
| 827 ;; of forward-line, but that doesn't work because | |
| 828 ;; forward-line has bogus behavior: If you're on | |
| 829 ;; the last line of a buffer but not at the very | |
| 830 ;; end, forward-line will move you to the very | |
| 831 ;; end and return 0 instead of 1, like it should. | |
| 832 ;; the result was frequent infinite loops here, | |
| 833 ;; creating very large numbers of extents at | |
| 834 ;; the same position. There was an N^2 sorting | |
| 835 ;; algorithm in extents.c for extents at a | |
| 836 ;; particular position, and the result was very | |
| 837 ;; bad news. | |
| 838 (forward-line 1) | |
| 839 (if (not (eobp)) | |
| 840 (move-to-column left pad-p)) | |
| 841 (setq last rest | |
| 842 rest (cdr rest))) | |
| 843 (cond (rest | |
| 844 (mapcar 'delete-extent rest) | |
| 845 (setcdr last nil)) | |
| 846 ((not (eobp)) | |
| 847 (while (not (eobp)) | |
| 848 (setq p (point)) | |
| 849 (move-to-column right pad-p) | |
| 850 (let ((e (make-extent p (point)))) | |
| 851 (set-extent-face e (extent-face (car extents))) | |
| 852 (set-extent-priority e (extent-priority (car extents))) | |
| 853 (setcdr last (cons e nil)) | |
| 854 (setq last (cdr last))) | |
| 855 (forward-line 1) | |
| 856 (if (not (eobp)) | |
| 857 (move-to-column left pad-p)) | |
| 858 ))))) | |
| 859 )))) | |
| 860 | |
| 861 (defun default-mouse-track-has-selection-p (buffer) | |
| 862 (and (or (not (eq 'x (console-type (selected-console)))) | |
| 863 (x-selection-owner-p)) | |
| 864 (extent-live-p primary-selection-extent) | |
| 865 (not (extent-detached-p primary-selection-extent)) | |
| 866 (eq buffer (extent-object primary-selection-extent)))) | |
| 867 | |
| 868 (defun default-mouse-track-anchor (adjust previous-point) | |
| 869 (if adjust | |
| 870 (if (default-mouse-track-has-selection-p (current-buffer)) | |
| 871 (let ((start (extent-start-position primary-selection-extent)) | |
| 872 (end (extent-end-position primary-selection-extent))) | |
| 873 (cond ((< (point) start) end) | |
| 874 ((> (point) end) start) | |
| 875 ((> (- (point) start) (- end (point))) start) | |
| 876 (t end))) | |
| 877 previous-point) | |
| 878 (point))) | |
| 879 | |
| 880 (defun default-mouse-track-maybe-own-selection (pair type) | |
| 881 (let ((start (car pair)) | |
| 882 (end (cdr pair))) | |
| 883 (or (= start end) (push-mark (if (= (point) start) end start))) | |
| 884 (cond (zmacs-regions | |
| 885 (if (= start end) | |
| 886 nil | |
| 887 ;; #### UTTER KLUDGE. | |
| 888 ;; If we don't have this sit-for here, then triple-clicking | |
| 889 ;; will result in the line not being highlighted as it | |
| 890 ;; should. What appears to be happening is this: | |
| 891 ;; | |
| 892 ;; -- each time the button goes down, the selection is | |
| 893 ;; disowned (see comment "remove the existing selection | |
| 894 ;; to unclutter the display", below). | |
| 895 ;; -- this causes a SelectionClear event to be sent to | |
| 896 ;; XEmacs. | |
| 897 ;; -- each time the button goes up except the first, the | |
| 898 ;; selection is owned again. | |
| 899 ;; -- later, XEmacs processes the SelectionClear event. | |
| 900 ;; The selection code attempts to keep track of the | |
| 901 ;; time that it last asserted the selection, and | |
| 902 ;; compare it to the time of the SelectionClear event, | |
| 903 ;; to see if it's a bogus notification or not (as | |
| 904 ;; is the case here). However, for some unknown | |
| 905 ;; reason this doesn't work in the triple-clicking | |
| 906 ;; case, and the selection code bogusly thinks this | |
| 907 ;; SelectionClear event is the real thing. | |
| 908 ;; -- putting the sit-for in causes the pending | |
| 909 ;; SelectionClear events to get processed before | |
| 910 ;; the selection is reasserted, so everything works | |
| 911 ;; out OK. | |
| 912 ;; | |
| 913 ;; Presumably(?) this means there is a weird timing bug | |
| 914 ;; in the selection code, but there's not a chance in hell | |
| 915 ;; that I have the patience to track it down. Blame the | |
| 916 ;; designers of X for fucking everything up so badly. | |
| 917 ;; | |
| 918 ;; This was originally a sit-for 0 but that wasn't | |
| 919 ;; sufficient to make things work. Even this isn't | |
| 920 ;; always sufficient but it seems to give something | |
| 921 ;; approaching a 99% success rate. Making it higher yet | |
| 922 ;; would help guarantee success with the price that the | |
| 923 ;; delay would start to become noticable. | |
| 924 ;; | |
| 925 (sit-for 0.15 t) | |
| 926 (zmacs-activate-region))) | |
| 927 ((eq 'x (console-type (selected-console))) | |
| 928 (if (= start end) | |
| 929 (x-disown-selection type) | |
| 930 (if (consp default-mouse-track-extent) | |
| 931 ;; own the rectangular region | |
| 932 ;; this is a hack | |
| 933 (let ((r default-mouse-track-extent)) | |
| 934 (save-excursion | |
| 935 (set-buffer (get-buffer-create " *rect yank temp buf*")) | |
| 936 (while r | |
| 937 (insert (extent-string (car r)) "\n") | |
| 938 (setq r (cdr r))) | |
| 939 (x-own-selection (buffer-substring (point-min) (point-max))) | |
| 940 (kill-buffer (current-buffer)))) | |
| 941 (x-own-selection (cons (set-marker (make-marker) start) | |
| 942 (set-marker (make-marker) end)) | |
| 943 type))))) | |
| 944 (if (and (eq 'x (console-type (selected-console))) | |
| 945 (not (= start end))) | |
| 946 ;; I guess cutbuffers should do something with rectangles too. | |
| 947 ;; does anybody use them? | |
| 948 (x-store-cutbuffer (buffer-substring start end))))) | |
| 949 | |
| 950 (defun default-mouse-track-deal-with-down-event (click-count) | |
| 951 (let ((event default-mouse-track-down-event)) | |
| 952 (if (null event) nil | |
| 953 (select-frame (event-frame event)) | |
| 954 (let ((adjust default-mouse-track-adjust) | |
| 955 ;; ####When you click on the splash-screen, | |
| 956 ;; event-{closest-,}point can be out of bounds. Should | |
| 957 ;; event-closest-point really be allowed to return a bad | |
| 958 ;; position like that? Maybe pixel_to_glyph_translation | |
| 959 ;; needs to invalidate its cache when the buffer changes. | |
| 960 ;; -dkindred@cs.cmu.edu | |
| 961 (close-pos (save-excursion | |
| 962 (set-buffer (event-buffer event)) | |
| 963 (let ((p (event-closest-point event))) | |
| 964 (and p (min (max p (point-min)) (point-max)))))) | |
| 965 extent previous-point) | |
| 966 | |
| 967 (if (not (event-window event)) | |
| 968 (error "not over window?")) | |
| 969 (setq default-mouse-track-type | |
| 970 (nth (mod (1- click-count) | |
| 971 (length default-mouse-track-type-list)) | |
| 972 default-mouse-track-type-list)) | |
| 973 (setq default-mouse-track-window (event-window event)) | |
| 974 ;; Note that the extent used here is NOT the extent which | |
| 975 ;; ends up as the value of zmacs-region-extent - this one is used | |
| 976 ;; just during mouse-dragging. | |
| 977 (setq default-mouse-track-extent | |
| 978 (make-extent close-pos close-pos (event-buffer event))) | |
| 979 (setq extent default-mouse-track-extent) | |
| 980 (set-extent-face extent 'zmacs-region) | |
| 981 ;; While the selection is being dragged out, give the selection extent | |
| 982 ;; slightly higher priority than any mouse-highlighted extent, so that | |
| 983 ;; the exact endpoints of the selection will be visible while the mouse | |
| 984 ;; is down. Normally, the selection and mouse highlighting have the | |
| 985 ;; same priority, so that conflicts between the two of them are | |
| 986 ;; resolved by the usual size-and-endpoint-comparison method. | |
| 987 (set-extent-priority extent (1+ mouse-highlight-priority)) | |
| 988 (if mouse-track-rectangle-p | |
| 989 (setq default-mouse-track-extent | |
| 990 (list default-mouse-track-extent))) | |
| 991 | |
| 992 (setq previous-point | |
| 993 (if (and adjust | |
| 994 (markerp default-mouse-track-previous-point) | |
| 995 (eq (current-buffer) | |
| 996 (marker-buffer default-mouse-track-previous-point))) | |
| 997 (marker-position default-mouse-track-previous-point) | |
| 998 (point))) | |
| 999 (default-mouse-track-set-point event default-mouse-track-window) | |
| 1000 (if (not adjust) | |
| 1001 (if (markerp default-mouse-track-previous-point) | |
| 1002 (set-marker default-mouse-track-previous-point (point)) | |
| 1003 (setq default-mouse-track-previous-point (point-marker)))) | |
| 1004 ;; | |
| 1005 ;; adjust point to a word or line boundary if appropriate | |
| 1006 (let ((anchor (default-mouse-track-anchor adjust previous-point))) | |
| 1007 (setq default-mouse-track-min-anchor | |
| 1008 (save-excursion (goto-char anchor) | |
| 1009 (default-mouse-track-normalize-point | |
| 1010 default-mouse-track-type nil) | |
| 1011 (point))) | |
| 1012 (setq default-mouse-track-max-anchor | |
| 1013 (save-excursion (goto-char anchor) | |
| 1014 (default-mouse-track-normalize-point | |
| 1015 default-mouse-track-type t) | |
| 1016 (point)))) | |
| 1017 ;; | |
| 1018 ;; remove the existing selection to unclutter the display | |
| 1019 (if (not adjust) | |
| 1020 (cond (zmacs-regions | |
| 1021 (zmacs-deactivate-region)) | |
| 1022 ((eq 'x (console-type (selected-console))) | |
| 1023 (x-disown-selection))))) | |
| 1024 (setq default-mouse-track-down-event nil)))) | |
| 1025 | |
| 1026 (defun default-mouse-track-down-hook (event click-count) | |
| 1027 (setq default-mouse-track-down-event (copy-event event)) | |
| 1028 nil) | |
| 1029 | |
| 1030 (defun default-mouse-track-cleanup-hook () | |
| 1031 (let ((extent default-mouse-track-extent)) | |
| 1032 (if (consp extent) ; rectangle-p | |
| 1033 (mapcar 'delete-extent extent) | |
| 1034 (if extent | |
| 1035 (delete-extent extent))))) | |
| 1036 | |
| 1037 (defun default-mouse-track-cleanup-extent () | |
| 1038 (let ((dead-func | |
| 1039 (function (lambda (x) | |
| 1040 (or (not (extent-live-p x)) | |
| 1041 (extent-detached-p x))))) | |
| 1042 (extent default-mouse-track-extent)) | |
| 1043 (if (consp extent) | |
| 1044 (if (some dead-func extent) | |
| 1045 (let (newval) | |
| 1046 (mapcar (function (lambda (x) | |
| 1047 (if (not (funcall dead-func x)) | |
| 1048 (setq newval (cons x newval))))) | |
| 1049 extent) | |
| 1050 (setq default-mouse-track-extent (nreverse newval)))) | |
| 1051 (if (funcall dead-func extent) | |
| 1052 (setq default-mouse-track-extent nil))))) | |
| 1053 | |
| 1054 (defun default-mouse-track-drag-hook (event click-count was-timeout) | |
| 1055 (default-mouse-track-deal-with-down-event click-count) | |
| 1056 (default-mouse-track-set-point event default-mouse-track-window) | |
| 1057 (default-mouse-track-cleanup-extent) | |
| 1058 (default-mouse-track-next-move default-mouse-track-min-anchor | |
| 1059 default-mouse-track-max-anchor | |
| 1060 default-mouse-track-extent) | |
| 1061 t) | |
| 1062 | |
| 1063 (defun default-mouse-track-return-dragged-selection (event) | |
| 1064 (default-mouse-track-cleanup-extent) | |
| 1065 (let ((extent default-mouse-track-extent) | |
| 1066 result) | |
| 1067 (default-mouse-track-set-point-in-window event default-mouse-track-window) | |
| 1068 (default-mouse-track-next-move default-mouse-track-min-anchor | |
| 1069 default-mouse-track-max-anchor | |
| 1070 extent) | |
| 1071 (cond ((consp extent) ; rectangle-p | |
| 1072 (let ((first (car extent)) | |
| 1073 (last (car (setq extent (nreverse extent))))) | |
| 1074 ;; nreverse is destructive so we need to reset this | |
| 1075 (setq default-mouse-track-extent extent) | |
| 1076 (setq result (cons (extent-start-position first) | |
| 1077 (extent-end-position last))) | |
| 1078 ;; kludge to fix up region when dragging backwards... | |
| 1079 (if (and (/= (point) (extent-start-position first)) | |
| 1080 (/= (point) (extent-end-position last)) | |
| 1081 (= (point) (extent-end-position first))) | |
| 1082 (goto-char (car result))))) | |
| 1083 (extent | |
| 1084 (setq result (cons (extent-start-position extent) | |
| 1085 (extent-end-position extent))))) | |
| 1086 ;; Minor kludge: if we're selecting in line-mode, include the | |
| 1087 ;; final newline. It's hard to do this in *-normalize-point. | |
| 1088 (if (and result (eq default-mouse-track-type 'line)) | |
| 1089 (let ((end-p (= (point) (cdr result)))) | |
| 1090 (goto-char (cdr result)) | |
| 1091 (if (not (eobp)) | |
| 1092 (setcdr result (1+ (cdr result)))) | |
| 1093 (goto-char (if end-p (cdr result) (car result))))) | |
| 1094 ;;; ;; Minor kludge sub 2. If in char mode, and we drag the | |
| 1095 ;;; ;; mouse past EOL, include the newline. | |
| 1096 ;;; ;; | |
| 1097 ;;; ;; Major problem: can't easily distinguish between being | |
| 1098 ;;; ;; just past the last char on a line, and well past it, | |
| 1099 ;;; ;; to determine whether or not to include it in the region | |
| 1100 ;;; ;; | |
| 1101 ;;; (if nil ; (eq default-mouse-track-type 'char) | |
| 1102 ;;; (let ((after-end-p (and (not (eobp)) | |
| 1103 ;;; (eolp) | |
| 1104 ;;; (> (point) (car result))))) | |
| 1105 ;;; (if after-end-p | |
| 1106 ;;; (progn | |
| 1107 ;;; (setcdr result (1+ (cdr result))) | |
| 1108 ;;; (goto-char (cdr result)))))) | |
| 1109 result)) | |
| 1110 | |
| 1111 (defun default-mouse-track-drag-up-hook (event click-count) | |
| 1112 (let ((result (default-mouse-track-return-dragged-selection event))) | |
| 1113 (if result | |
| 1114 (default-mouse-track-maybe-own-selection result 'PRIMARY))) | |
| 1115 t) | |
| 1116 | |
| 1117 (defun default-mouse-track-click-hook (event click-count) | |
| 1118 (default-mouse-track-drag-hook event click-count nil) | |
| 1119 (default-mouse-track-drag-up-hook event click-count) | |
| 1120 t) | |
| 1121 | |
| 1122 (add-hook 'mouse-track-down-hook 'default-mouse-track-down-hook) | |
| 1123 (add-hook 'mouse-track-drag-hook 'default-mouse-track-drag-hook) | |
| 1124 (add-hook 'mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook) | |
| 1125 (add-hook 'mouse-track-click-hook 'default-mouse-track-click-hook) | |
| 1126 (add-hook 'mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook) | |
| 1127 | |
| 1128 | |
| 1129 ;;;;;;;;;;;; other mouse-track stuff (mostly associated with the | |
| 1130 ;;;;;;;;;;;; default handlers) | |
| 1131 | |
| 1132 (defun mouse-track-default (event) | |
| 1133 "Invoke `mouse-track' with only the default handlers active." | |
| 1134 (interactive "e") | |
| 1135 (let ((mouse-track-down-hook 'default-mouse-track-down-hook) | |
| 1136 (mouse-track-drag-hook 'default-mouse-track-drag-hook) | |
| 1137 (mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook) | |
| 1138 (mouse-track-click-hook 'default-mouse-track-click-hook) | |
| 1139 (mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook)) | |
| 1140 (mouse-track event))) | |
| 1141 | |
| 1142 (defun mouse-track-do-rectangle (event) | |
| 1143 "Like `mouse-track' but selects rectangles instead of regions." | |
| 1144 (interactive "e") | |
| 1145 (let ((mouse-track-rectangle-p t)) | |
| 1146 (mouse-track event))) | |
| 1147 | |
| 1148 (defun mouse-track-adjust (event) | |
| 1149 "Extend the existing selection. This should be bound to a mouse button. | |
| 1150 The selection will be enlarged or shrunk so that the point of the mouse | |
| 1151 click is one of its endpoints. This function in fact behaves fairly | |
| 1152 similarly to `mouse-track', but begins by extending the existing selection | |
| 1153 (or creating a new selection from the previous text cursor position to | |
| 1154 the current mouse position) instead of creating a new, empty selection. | |
| 1155 | |
| 1156 The mouse-track handlers are run from this command just like from | |
| 1157 `mouse-track'. Therefore, do not call this command from a mouse-track | |
| 1158 handler!" | |
| 1159 (interactive "e") | |
| 1160 (let ((default-mouse-track-adjust t)) | |
| 1161 (mouse-track event))) | |
| 1162 | |
| 1163 (defun mouse-track-adjust-default (event) | |
| 1164 "Extend the existing selection, using only the default handlers. | |
| 1165 This is just like `mouse-track-adjust' but will override any | |
| 1166 custom mouse-track handlers that the user may have installed." | |
| 1167 (interactive "e") | |
| 1168 (let ((default-mouse-track-adjust t)) | |
| 1169 (mouse-track-default event))) | |
| 1170 | |
| 1171 (defvar mouse-track-insert-selected-region nil) | |
| 1172 | |
| 1173 (defun mouse-track-insert-drag-up-hook (event click-count) | |
| 1174 (setq mouse-track-insert-selected-region | |
| 1175 (default-mouse-track-return-dragged-selection event))) | |
| 1176 | |
| 1177 (defun mouse-track-insert (event &optional delete) | |
| 1178 "Make a selection with the mouse and insert it at point. | |
| 1179 This is exactly the same as the `mouse-track' command on \\[mouse-track], | |
| 1180 except that point is not moved; the selected text is immediately inserted | |
| 1181 after being selected\; and the selection is immediately disowned afterwards." | |
| 1182 (interactive "*e") | |
| 1183 (setq mouse-track-insert-selected-region nil) | |
| 1184 (let ((mouse-track-drag-up-hook 'mouse-track-insert-drag-up-hook) | |
| 1185 (mouse-track-click-hook 'mouse-track-insert-click-hook) | |
| 1186 s) | |
| 1187 (save-excursion | |
| 1188 (save-window-excursion | |
| 1189 (mouse-track event) | |
| 1190 (if (consp mouse-track-insert-selected-region) | |
| 1191 (let ((pair mouse-track-insert-selected-region)) | |
| 1192 (setq s (prog1 | |
| 1193 (buffer-substring (car pair) (cdr pair)) | |
| 1194 (if delete | |
| 1195 (kill-region (car pair) (cdr pair))))))))) | |
| 1196 (or (null s) (equal s "") (insert s)))) | |
| 1197 | |
| 1198 (defun mouse-track-insert-click-hook (event click-count) | |
| 1199 (default-mouse-track-drag-hook event click-count nil) | |
| 1200 (mouse-track-insert-drag-up-hook event click-count) | |
| 1201 t) | |
| 1202 | |
| 1203 (defun mouse-track-delete-and-insert (event) | |
| 1204 "Make a selection with the mouse and insert it at point. | |
| 1205 This is exactly the same as the `mouse-track' command on \\[mouse-track], | |
| 1206 except that point is not moved; the selected text is immediately inserted | |
| 1207 after being selected\; and the text of the selection is deleted." | |
| 1208 (interactive "*e") | |
| 1209 (mouse-track-insert event t)) | |
| 1210 | |
| 1211 ;;;;;;;;;;;;;;;;;;;;;;;; | |
| 1212 | |
| 1213 | |
| 1214 (defvar inhibit-help-echo nil | |
| 1215 "Inhibits display of `help-echo' extent properties in the minibuffer.") | |
| 1216 (defvar last-help-echo-object nil) | |
| 1217 (defvar help-echo-owns-message nil) | |
| 1218 | |
| 1219 (defun clear-help-echo (&optional ignored-frame) | |
| 1220 (if help-echo-owns-message | |
| 1221 (progn | |
| 1222 (setq help-echo-owns-message nil | |
| 1223 last-help-echo-object nil) | |
| 1224 (clear-message 'help-echo)))) | |
| 1225 | |
| 1226 (defun show-help-echo (mess) | |
| 1227 ;; (clear-help-echo) | |
| 1228 (setq help-echo-owns-message t) | |
| 1229 (display-message 'help-echo mess)) | |
| 1230 | |
| 1231 (add-hook 'mouse-leave-frame-hook 'clear-help-echo) | |
| 1232 | |
| 1233 (defun default-mouse-motion-handler (event) | |
| 1234 "For use as the value of `mouse-motion-handler'. | |
| 1235 This implements the various pointer-shape variables, | |
| 1236 as well as extent highlighting, help-echo, toolbar up/down, | |
| 1237 and `mode-motion-hook'." | |
| 1238 (let* ((frame (or (event-frame event) (selected-frame))) | |
| 1239 (window (event-window event)) | |
| 1240 (buffer (event-buffer event)) | |
| 1241 (point (and buffer (event-point event))) | |
| 1242 (modeline-point (and buffer (event-modeline-position event))) | |
| 1243 (extent (and point (extent-at point buffer 'mouse-face))) | |
| 1244 (glyph1 (event-glyph-extent event)) | |
| 1245 (glyph (and glyph1 (extent-live-p glyph1) glyph1)) | |
| 1246 (user-pointer1 (or (and glyph (extent-property glyph 'pointer)) | |
| 1247 (and point | |
| 1248 (condition-case nil | |
| 1249 (extent-at point buffer 'pointer) | |
| 1250 (error nil))) | |
| 1251 (and modeline-point | |
| 1252 (condition-case nil | |
| 1253 (extent-at modeline-point | |
| 1254 (symbol-value-in-buffer | |
| 1255 'generated-modeline-string | |
| 1256 buffer) 'pointer))))) | |
| 1257 (user-pointer (and user-pointer1 (extent-live-p user-pointer1) | |
| 1258 (extent-property user-pointer1 'pointer))) | |
| 1259 (button (event-toolbar-button event)) | |
| 1260 (help (or (and glyph (extent-property glyph 'help-echo) glyph) | |
| 1261 (and button (not (null (toolbar-button-help-string button))) | |
| 1262 button) | |
| 1263 (and point | |
| 1264 (condition-case nil | |
| 1265 (extent-at point buffer 'help-echo) | |
| 1266 (error nil))) | |
| 1267 (and modeline-point | |
| 1268 (condition-case nil | |
| 1269 (extent-at modeline-point | |
| 1270 (symbol-value-in-buffer | |
| 1271 'generated-modeline-string | |
| 1272 buffer) 'help-echo))))) | |
| 1273 ;; vars is a list of glyph variables to check for a pointer | |
| 1274 ;; value. | |
| 1275 (vars (cond | |
| 1276 ;; Checking if button is non-nil is not sufficent | |
| 1277 ;; since the pointer could be over a blank portion | |
| 1278 ;; of the toolbar. | |
| 1279 ((event-over-toolbar-p event) | |
| 1280 '(toolbar-pointer-glyph nontext-pointer-glyph | |
| 1281 text-pointer-glyph)) | |
| 1282 ((or extent glyph) | |
| 1283 '(selection-pointer-glyph text-pointer-glyph)) | |
| 1284 ((event-over-modeline-p event) | |
| 1285 '(modeline-pointer-glyph nontext-pointer-glyph | |
| 1286 text-pointer-glyph)) | |
| 1287 (point '(text-pointer-glyph)) | |
| 1288 (buffer '(nontext-pointer-glyph text-pointer-glyph)) | |
| 1289 (t '(modeline-pointer-glyph nontext-pointer-glyph | |
| 1290 text-pointer-glyph)))) | |
| 1291 pointer) | |
| 1292 (if (and user-pointer (glyphp user-pointer)) | |
| 1293 (setq vars (cons 'user-pointer vars))) | |
| 1294 (while (and vars (not (pointer-image-instance-p pointer))) | |
| 1295 (setq pointer (glyph-image-instance (symbol-value (car vars)) | |
| 1296 (or window frame)) | |
| 1297 vars (cdr vars))) | |
| 1298 | |
| 1299 (if (pointer-image-instance-p pointer) | |
| 1300 (set-frame-pointer frame pointer)) | |
| 1301 | |
| 1302 ;; If last-pressed-toolbar-button is not nil, then check and see | |
| 1303 ;; if we have moved to a new button and adjust the down flags | |
| 1304 ;; accordingly. | |
| 1305 (if (and (featurep 'toolbar) toolbar-active) | |
| 1306 (if (not (eq last-pressed-toolbar-button button)) | |
| 1307 (progn | |
| 1308 (release-previous-toolbar-button event) | |
| 1309 (and button (press-toolbar-button event))))) | |
| 1310 | |
| 1311 (cond (extent (highlight-extent extent t)) | |
| 1312 (glyph (highlight-extent glyph t)) | |
| 1313 (t (highlight-extent nil nil))) | |
| 1314 (cond ((extentp help) | |
| 1315 (or inhibit-help-echo | |
| 1316 (eq help last-help-echo-object) ;save some time | |
| 1317 (let ((hprop (extent-property help 'help-echo))) | |
| 1318 (setq last-help-echo-object help) | |
| 1319 (or (stringp hprop) | |
| 1320 (setq hprop (funcall hprop help))) | |
| 1321 (and hprop (show-help-echo hprop))))) | |
| 1322 ((and (featurep 'toolbar) | |
| 1323 (toolbar-button-p help) | |
| 1324 (toolbar-button-enabled-p help)) | |
| 1325 (or (not toolbar-help-enabled) | |
| 1326 (eq help last-help-echo-object) ;save some time | |
| 1327 (let ((hstring (toolbar-button-help-string button))) | |
| 1328 (setq last-help-echo-object help) | |
| 1329 (or (stringp hstring) | |
| 1330 (setq hstring (funcall hstring help))) | |
| 1331 (show-help-echo hstring)))) | |
| 1332 (last-help-echo-object | |
| 1333 (clear-help-echo))) | |
| 1334 (if mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer)) | |
| 1335 (if (and buffer (symbol-value-in-buffer 'mode-motion-hook buffer nil)) | |
| 1336 (save-window-excursion | |
| 1337 (set-buffer buffer) | |
| 1338 (run-hook-with-args 'mode-motion-hook event) | |
| 1339 | |
| 1340 ;; If the mode-motion-hook created a highlightable extent around | |
| 1341 ;; the mouse-point, highlight it right away. Otherwise it wouldn't | |
| 1342 ;; be highlighted until the *next* motion event came in. | |
| 1343 (if (and point | |
| 1344 (null extent) | |
| 1345 (setq extent (extent-at point | |
| 1346 (event-buffer event) ; not buffer | |
| 1347 'mouse-face))) | |
| 1348 (highlight-extent extent t))))) | |
| 1349 nil) | |
| 1350 | |
| 1351 (setq mouse-motion-handler 'default-mouse-motion-handler) |