Mercurial > hg > xemacs-beta
annotate lisp/mouse.el @ 5576:071b810ceb18
Declare labels as line where appropriate; use #'labels, not #'flet, tests.
lisp/ChangeLog addition:
2011-10-03 Aidan Kehoe <kehoea@parhasard.net>
* simple.el (handle-pre-motion-command-current-command-is-motion):
Implement #'keysyms-equal with #'labels + (declare (inline ...)),
instead of abusing macrolet to the same end.
* specifier.el (let-specifier):
* mule/mule-cmds.el (describe-language-environment):
* mule/mule-cmds.el (set-language-environment-coding-systems):
* mule/mule-x-init.el (x-use-halfwidth-roman-font):
* faces.el (Face-frob-property):
* keymap.el (key-sequence-list-description):
* lisp-mode.el (construct-lisp-mode-menu):
* loadhist.el (unload-feature):
* mouse.el (default-mouse-track-check-for-activation):
Declare various labels inline in dumped files when that reduces
the size of the dumped image. Declaring labels inline is normally
only worthwhile for inner loops and so on, but it's reasonable
exercise of the related code to have these changes in core.
tests/ChangeLog addition:
2011-10-03 Aidan Kehoe <kehoea@parhasard.net>
* automated/case-tests.el (uni-mappings):
* automated/database-tests.el (delete-database-files):
* automated/hash-table-tests.el (iterations):
* automated/lisp-tests.el (test1):
* automated/lisp-tests.el (a):
* automated/lisp-tests.el (cl-floor):
* automated/lisp-tests.el (foo):
* automated/lisp-tests.el (list-nreverse):
* automated/lisp-tests.el (needs-lexical-context):
* automated/mule-tests.el (featurep):
* automated/os-tests.el (original-string):
* automated/os-tests.el (with):
* automated/symbol-tests.el (check-weak-list-unique):
Replace #'flet with #'labels where appropriate in these tests,
following my own advice on style in the docstrings of those
functions.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Mon, 03 Oct 2011 20:16:14 +0100 |
| parents | 3bc58dc9d688 |
| children | bbe4146603db |
| 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))) |
|
8f1ee2d15784
Support full Common Lisp multiple values in C.
Aidan Kehoe <kehoea@parhasard.net>
parents:
3061
diff
changeset
|
277 (not (string-match "\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 |