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