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