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