Mercurial > hg > xemacs-beta

comparison lisp/mouse.el @ 442:abe6d1db359e r21-2-36

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r21-2-36
author cvs
date Mon, 13 Aug 2007 11:35:02 +0200
parents 8de8e3f6228a
children 576fb035e263
comparison
equal deleted inserted replaced
441:72a7cfa4a488 442:abe6d1db359e
1 ;;; mouse.el --- window system-independent mouse support. 1 ;;; mouse.el --- window system-independent mouse support.
2 2
3 ;; Copyright (C) 1988, 1992-4, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1988, 1992-4, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1995 Tinker Systems 4 ;; Copyright (C) 1995 Tinker Systems
5 ;; Copyright (C) 1995, 1996 Ben Wing. 5 ;; Copyright (C) 1995, 1996, 2000 Ben Wing.
6 6
7 ;; Maintainer: XEmacs Development Team 7 ;; Maintainer: XEmacs Development Team
8 ;; Keywords: mouse, dumped 8 ;; Keywords: mouse, dumped
9 9
10 ;; This file is part of XEmacs. 10 ;; This file is part of XEmacs.
27 ;;; Synched up with: Not synched with FSF. Almost completely divergent. 27 ;;; Synched up with: Not synched with FSF. Almost completely divergent.
28 28
29 ;;; Commentary: 29 ;;; Commentary:
30 30
31 ;; This file is dumped with XEmacs (when window system support is compiled in). 31 ;; This file is dumped with XEmacs (when window system support is compiled in).
32
33 ;;; Authorship:
34
35 ;; Probably originally derived from FSF 19 pre-release.
36 ;; much hacked upon by Jamie Zawinski and crew, pre-1994.
37 ;; (only mouse-motion stuff currently remains from that era)
38 ;; all mouse-track stuff completely rewritten by Ben Wing, 1995-1996.
39 ;; mouse-eval-sexp and *-inside-extent-p from Stig, 1995.
40 ;; vertical divider code c. 1998 from ?.
32 41
33 ;;; Code: 42 ;;; Code:
34 43
35 (provide 'mouse) 44 (provide 'mouse)
36 45
37 (global-set-key 'button1 'mouse-track) 46 (global-set-key 'button1 'mouse-track)
38 (global-set-key '(shift button1) 'mouse-track-adjust) 47 (global-set-key '(shift button1) 'mouse-track-adjust)
39 (global-set-key '(control button1) 'mouse-track-insert) 48 (global-set-key '(control button1) 'mouse-track-insert)
40 (global-set-key '(control shift button1) 'mouse-track-delete-and-insert) 49 (global-set-key '(control shift button1) 'mouse-track-delete-and-insert)
41 (global-set-key '(meta button1) 'mouse-track-do-rectangle) 50 (global-set-key '(meta button1) 'mouse-track-do-rectangle)
42 51 (global-set-key 'button2 'mouse-track)
43 ;; drops are now handled in dragdrop.el (ograf@fga.de)
44
45 ;; enable drag regions (ograf@fga.de)
46 ;; if button2 is dragged from within a region, this becomes a drop
47 ;;
48 ;; this must be changed to the new api
49 (if (featurep '(or offix cde mswindows))
50 (global-set-key 'button2 'mouse-drag-or-yank)
51 (global-set-key 'button2 'mouse-yank))
52 52
53 (defgroup mouse nil 53 (defgroup mouse nil
54 "Window system-independent mouse support." 54 "Window system-independent mouse support."
55 :group 'editing) 55 :group 'editing)
56 56
183 (funcall mouse-yank-function)) 183 (funcall mouse-yank-function))
184 184
185 (defun click-inside-extent-p (click extent) 185 (defun click-inside-extent-p (click extent)
186 "Return non-nil if the button event is within the primary selection-extent. 186 "Return non-nil if the button event is within the primary selection-extent.
187 Return nil otherwise." 187 Return nil otherwise."
188 ;; stig@hackvan.com
189 (let ((ewin (event-window click)) 188 (let ((ewin (event-window click))
190 (epnt (event-point click))) 189 (epnt (event-point click)))
191 (and ewin 190 (and ewin
192 epnt 191 epnt
193 extent 192 extent
204 203
205 (defun point-inside-extent-p (extent) 204 (defun point-inside-extent-p (extent)
206 "Return t if point is within the bounds of the primary selection extent. 205 "Return t if point is within the bounds of the primary selection extent.
207 Return t is point is at the end position of the extent. 206 Return t is point is at the end position of the extent.
208 Return nil otherwise." 207 Return nil otherwise."
209 ;; stig@hackvan.com
210 (and extent 208 (and extent
211 (eq (current-buffer) 209 (eq (current-buffer)
212 (extent-object extent)) 210 (extent-object extent))
213 (> (point) (extent-start-position extent)) 211 (> (point) (extent-start-position extent))
214 (>= (extent-end-position extent) (point)))) 212 (>= (extent-end-position extent) (point))))
215 213
216 (defun point-inside-selection-p () 214 (defun point-inside-selection-p ()
217 ;; by Stig@hackvan.com
218 (or (point-inside-extent-p primary-selection-extent) 215 (or (point-inside-extent-p primary-selection-extent)
219 (point-inside-extent-p zmacs-region-extent))) 216 (point-inside-extent-p zmacs-region-extent)))
220 217
221 (defun mouse-drag-or-yank (event) 218 (defun mouse-begin-drag-n-drop (event)
222 "Either drag or paste the current selection. 219 "Begin a drag-n-drop operation.
223 If the variable `mouse-yank-at-point' is non-nil, 220 EVENT should be the button event that initiated the drag.
224 move the cursor to the location of the click before pasting. 221 Returns whether a drag was begun."
225 This functions has to be improved. Currently it is just a (working) test." 222 ;; #### barely implemented.
226 ;; by Oliver Graf <ograf@fga.de> 223 (when (click-inside-selection-p event)
227 (interactive "e") 224 (cond ((featurep 'offix)
228 (if (click-inside-extent-p event zmacs-region-extent) 225 (offix-start-drag-region
229 ;; okay, this is a drag 226 event
230 (cond ((featurep 'offix) 227 (extent-start-position zmacs-region-extent)
231 (offix-start-drag-region 228 (extent-end-position zmacs-region-extent))
232 event 229 t)
233 (extent-start-position zmacs-region-extent) 230 ((featurep 'cde)
234 (extent-end-position zmacs-region-extent))) 231 ;; should also work with CDE
235 ((featurep 'cde) 232 (cde-start-drag-region event
236 ;; should also work with CDE 233 (extent-start-position zmacs-region-extent)
237 (cde-start-drag-region event 234 (extent-end-position zmacs-region-extent))
238 (extent-start-position zmacs-region-extent) 235 t))))
239 (extent-end-position zmacs-region-extent)))
240 (t (error "No offix or CDE support compiled in")))
241 ;; no drag, call region-funct
242 (and (not mouse-yank-at-point)
243 (mouse-set-point event))
244 (funcall mouse-yank-function))
245 )
246 236
247 (defun mouse-eval-sexp (click force-window) 237 (defun mouse-eval-sexp (click force-window)
248 "Evaluate the sexp under the mouse. Usually, this is the last sexp before 238 "Evaluate the sexp under the mouse. Usually, this is the last sexp before
249 the click, but if you click on a left paren, then it is the sexp beginning 239 the click, but if you click on a left paren, then it is the sexp beginning
250 with the paren that is evaluated. Also, since strings evaluate to themselves, 240 with the paren that is evaluated. Also, since strings evaluate to themselves,
255 the expression which is clicked upon is relative not to the window where you 245 the expression which is clicked upon is relative not to the window where you
256 click, but to the current window and the current position of point. Thus, 246 click, but to the current window and the current position of point. Thus,
257 you can use `mouse-eval-sexp' to interactively test code that acts upon a 247 you can use `mouse-eval-sexp' to interactively test code that acts upon a
258 buffer...something you cannot do with the standard `eval-last-sexp' function. 248 buffer...something you cannot do with the standard `eval-last-sexp' function.
259 It's also fantastic for debugging regular expressions." 249 It's also fantastic for debugging regular expressions."
260 ;; by Stig@hackvan.com
261 (interactive "e\nP") 250 (interactive "e\nP")
262 (let (exp val result-str) 251 (let (exp val result-str)
263 (setq exp (save-window-excursion 252 (setq exp (save-window-excursion
264 (save-excursion 253 (save-excursion
265 (mouse-set-point click) 254 (mouse-set-point click)
501 490
502 A value of nil disables the timeout feature." 491 A value of nil disables the timeout feature."
503 :type '(choice integer (const :tag "Disabled" nil)) 492 :type '(choice integer (const :tag "Disabled" nil))
504 :group 'mouse) 493 :group 'mouse)
505 494
495 (defcustom mouse-track-activate-strokes '(button1-double-click button2-click)
496 "List of mouse strokes that can cause \"activation\" of the text extent
497 under the mouse. The exact meaning of \"activation\" is dependent on the
498 text clicked on and the mode of the buffer, but typically entails actions
499 such as following a hyperlink or selecting an entry in a completion buffer.
500
501 Possible list entries are
502
503 button1-click
504 button1-double-click
505 button1-triple-click
506 button1-down
507 button2-click
508 button2-double-click
509 button2-triple-click
510 button2-down
511
512 As a general rule, you should not use the \"-down\" values, because this
513 makes it impossible to have other simultaneous actions, such as selection."
514 :type '(set
515 button1-click
516 button1-double-click
517 button1-triple-click
518 button1-down
519 button2-click
520 button2-double-click
521 button2-triple-click
522 button2-down)
523 :group 'mouse)
524
506 (defvar mouse-track-x-threshold '(face-width 'default) 525 (defvar mouse-track-x-threshold '(face-width 'default)
507 "Minimum number of pixels in the X direction for a drag to be initiated. 526 "Minimum number of pixels in the X direction for a drag to be initiated.
508 If the mouse is moved more than either the X or Y threshold while the 527 If the mouse is moved more than either the X or Y threshold while the
509 button is held down (see also `mouse-track-y-threshold'), then a drag 528 button is held down (see also `mouse-track-y-threshold'), then a drag
510 is initiated; otherwise the gesture is considered to be a click. 529 is initiated; otherwise the gesture is considered to be a click.
536 (if mouse-track-scroll-delay 555 (if mouse-track-scroll-delay
537 (setq mouse-track-timeout-id 556 (setq mouse-track-timeout-id
538 (add-timeout (/ mouse-track-scroll-delay 1000.0) 557 (add-timeout (/ mouse-track-scroll-delay 1000.0)
539 'mouse-track-scroll-undefined 558 'mouse-track-scroll-undefined
540 (copy-event event))))) 559 (copy-event event)))))
560
561 (defun mouse-track-do-activate (event)
562 "Execute the activate function under EVENT, if any.
563 Return true if the function was activated."
564 (let ((ex (extent-at-event event 'activate-function)))
565 (when ex
566 (funcall (extent-property ex 'activate-function)
567 event ex)
568 t)))
541 569
542 (defun mouse-track-run-hook (hook event &rest args) 570 (defun mouse-track-run-hook (hook event &rest args)
543 ;; ugh, can't use run-hook-with-args-until-success because we have 571 ;; ugh, can't use run-hook-with-args-until-success because we have
544 ;; to get the value using symbol-value-in-buffer. Doing a 572 ;; to get the value using symbol-value-in-buffer. Doing a
545 ;; save-excursion/set-buffer is wrong because the hook might want to 573 ;; save-excursion/set-buffer is wrong because the hook might want to
583 ;; attempting to debug a click-hook (which is pretty damn 611 ;; attempting to debug a click-hook (which is pretty damn
584 ;; difficult to do), this function may get called. 612 ;; difficult to do), this function may get called.
585 ) 613 )
586 614
587 (defun mouse-track (event) 615 (defun mouse-track (event)
588 "Make a selection with the mouse. This should be bound to a mouse button. 616 "Generalized mouse-button handler. This should be bound to a mouse button.
589 The behavior of XEmacs during mouse selection is customizable using various 617 The behavior of this function is customizable using various hooks and
590 hooks and variables: see `mouse-track-click-hook', `mouse-track-drag-hook', 618 variables: see `mouse-track-click-hook', `mouse-track-drag-hook',
591 `mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook', 619 `mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook',
592 `mouse-track-cleanup-hook', `mouse-track-multi-click-time', 620 `mouse-track-cleanup-hook', `mouse-track-multi-click-time',
593 `mouse-track-scroll-delay', `mouse-track-x-threshold', and 621 `mouse-track-scroll-delay', `mouse-track-x-threshold', and
594 `mouse-track-y-threshold'. 622 `mouse-track-y-threshold'.
595 623
1108 (zmacs-deactivate-region)) 1136 (zmacs-deactivate-region))
1109 ((console-on-window-system-p) 1137 ((console-on-window-system-p)
1110 (disown-selection))))) 1138 (disown-selection)))))
1111 (setq default-mouse-track-down-event nil)))) 1139 (setq default-mouse-track-down-event nil))))
1112 1140
1141 ;; return t if the button or motion event involved the specified button.
1142 (defun default-mouse-track-event-is-with-button (event n)
1143 (cond ((button-event-p event)
1144 (= n (event-button event)))
1145 ((motion-event-p event)
1146 (memq (cdr
1147 (assq n '((1 . button1) (2 . button2) (3 . button3)
1148 (4 . button4) (5 . button5))))
1149 (event-modifiers event)))))
1150
1113 (defun default-mouse-track-down-hook (event click-count) 1151 (defun default-mouse-track-down-hook (event click-count)
1114 (setq default-mouse-track-down-event (copy-event event)) 1152 (cond ((default-mouse-track-event-is-with-button event 1)
1115 nil) 1153 (if (and (memq 'button1-down mouse-track-activate-strokes)
1154 (mouse-track-do-activate event))
1155 t
1156 (setq default-mouse-track-down-event (copy-event event))
1157 nil))
1158 ((default-mouse-track-event-is-with-button event 2)
1159 (and (memq 'button2-down mouse-track-activate-strokes)
1160 (mouse-track-do-activate event)))))
1116 1161
1117 (defun default-mouse-track-cleanup-extents-hook () 1162 (defun default-mouse-track-cleanup-extents-hook ()
1118 (remove-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook) 1163 (remove-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)
1119 (let ((extent default-mouse-track-extent)) 1164 (let ((extent default-mouse-track-extent))
1120 (if (consp extent) ; rectangle-p 1165 (if (consp extent) ; rectangle-p
1131 (set-extent-face e 'primary-selection))))) 1176 (set-extent-face e 'primary-selection)))))
1132 (add-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook) 1177 (add-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)
1133 (if (consp extent) ; rectangle-p 1178 (if (consp extent) ; rectangle-p
1134 (mapcar func extent) 1179 (mapcar func extent)
1135 (if extent 1180 (if extent
1136 (funcall func extent)))))) 1181 (funcall func extent)))))
1182 t)
1137 1183
1138 (defun default-mouse-track-cleanup-extent () 1184 (defun default-mouse-track-cleanup-extent ()
1139 (let ((dead-func 1185 (let ((dead-func
1140 (function (lambda (x) 1186 (function (lambda (x)
1141 (or (not (extent-live-p x)) 1187 (or (not (extent-live-p x))
1151 (setq default-mouse-track-extent (nreverse newval)))) 1197 (setq default-mouse-track-extent (nreverse newval))))
1152 (if (funcall dead-func extent) 1198 (if (funcall dead-func extent)
1153 (setq default-mouse-track-extent nil))))) 1199 (setq default-mouse-track-extent nil)))))
1154 1200
1155 (defun default-mouse-track-drag-hook (event click-count was-timeout) 1201 (defun default-mouse-track-drag-hook (event click-count was-timeout)
1156 (default-mouse-track-deal-with-down-event click-count) 1202 (cond ((default-mouse-track-event-is-with-button event 1)
1157 (default-mouse-track-set-point event default-mouse-track-window) 1203 (default-mouse-track-deal-with-down-event click-count)
1158 (default-mouse-track-cleanup-extent) 1204 (default-mouse-track-set-point event default-mouse-track-window)
1159 (default-mouse-track-next-move default-mouse-track-min-anchor 1205 (default-mouse-track-cleanup-extent)
1160 default-mouse-track-max-anchor 1206 (default-mouse-track-next-move default-mouse-track-min-anchor
1161 default-mouse-track-extent) 1207 default-mouse-track-max-anchor
1162 t) 1208 default-mouse-track-extent)
1209 t)
1210 ((default-mouse-track-event-is-with-button event 2)
1211 (mouse-begin-drag-n-drop event))))
1163 1212
1164 (defun default-mouse-track-return-dragged-selection (event) 1213 (defun default-mouse-track-return-dragged-selection (event)
1165 (default-mouse-track-cleanup-extent) 1214 (default-mouse-track-cleanup-extent)
1166 (let ((extent default-mouse-track-extent) 1215 (let ((extent default-mouse-track-extent)
1167 result) 1216 result)
1208 ;;; (setcdr result (1+ (cdr result))) 1257 ;;; (setcdr result (1+ (cdr result)))
1209 ;;; (goto-char (cdr result)))))) 1258 ;;; (goto-char (cdr result))))))
1210 result)) 1259 result))
1211 1260
1212 (defun default-mouse-track-drag-up-hook (event click-count) 1261 (defun default-mouse-track-drag-up-hook (event click-count)
1213 (let ((result (default-mouse-track-return-dragged-selection event))) 1262 (when (default-mouse-track-event-is-with-button event 1)
1214 (if result 1263 (let ((result (default-mouse-track-return-dragged-selection event)))
1215 (default-mouse-track-maybe-own-selection result 'PRIMARY))) 1264 (if result
1216 t) 1265 (default-mouse-track-maybe-own-selection result 'PRIMARY)))
1266 t))
1217 1267
1218 (defun default-mouse-track-click-hook (event click-count) 1268 (defun default-mouse-track-click-hook (event click-count)
1219 (default-mouse-track-drag-hook event click-count nil) 1269 (cond ((default-mouse-track-event-is-with-button event 1)
1220 (default-mouse-track-drag-up-hook event click-count) 1270 (if (and
1221 t) 1271 (or (and (= click-count 1)
1272 (memq 'button1-click
1273 mouse-track-activate-strokes))
1274 (and (= click-count 2)
1275 (memq 'button1-double-click
1276 mouse-track-activate-strokes))
1277 (and (= click-count 3)
1278 (memq 'button1-triple-click
1279 mouse-track-activate-strokes)))
1280 (mouse-track-do-activate event))
1281 t
1282 (default-mouse-track-drag-hook event click-count nil)
1283 (default-mouse-track-drag-up-hook event click-count)
1284 t))
1285 ((default-mouse-track-event-is-with-button event 2)
1286 (if (and
1287 (or (and (= click-count 1)
1288 (memq 'button2-click
1289 mouse-track-activate-strokes))
1290 (and (= click-count 2)
1291 (memq 'button2-double-click
1292 mouse-track-activate-strokes))
1293 (and (= click-count 3)
1294 (memq 'button2-triple-click
1295 mouse-track-activate-strokes)))
1296 (mouse-track-do-activate event))
1297 t
1298 (mouse-yank event)
1299 t))))
1300
1222 1301
1223 (add-hook 'mouse-track-down-hook 'default-mouse-track-down-hook) 1302 (add-hook 'mouse-track-down-hook 'default-mouse-track-down-hook)
1224 (add-hook 'mouse-track-drag-hook 'default-mouse-track-drag-hook) 1303 (add-hook 'mouse-track-drag-hook 'default-mouse-track-drag-hook)
1225 (add-hook 'mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook) 1304 (add-hook 'mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook)
1226 (add-hook 'mouse-track-click-hook 'default-mouse-track-click-hook) 1305 (add-hook 'mouse-track-click-hook 'default-mouse-track-click-hook)
1469 ;; 1548 ;;
1470 ;; Vertical divider dragging 1549 ;; Vertical divider dragging
1471 ;; 1550 ;;
1472 (defun drag-window-divider (event) 1551 (defun drag-window-divider (event)
1473 "Handle resizing windows by dragging window dividers. 1552 "Handle resizing windows by dragging window dividers.
1474 This is an intenal function, normally bound to button1 event in 1553 This is an internal function, normally bound to button1 event in
1475 window-divider-map. You would not call it, but you may bind it to 1554 window-divider-map. You would not call it, but you may bind it to
1476 other mouse buttons." 1555 other mouse buttons."
1477 (interactive "e") 1556 (interactive "e")
1478 ;; #### I disagree with the check below. 1557 ;; #### I disagree with the check below.
1479 ;; Discuss it with Kirill for 21.1. --hniksic 1558 ;; Discuss it with Kirill for 21.1. --hniksic