Mercurial > hg > xemacs-beta

comparison lisp/mouse.el @ 546:666d73d6ac56

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2001-05-20 01:17:07 by ben] fixes so MinGW compiles. console-msw.h, scrollbar-msw.c, event-msw.c: we might receive scrollbar events on windows without scrollbars (e.g. holding down and moving the wheel button). dired.c: win9x support. eval.c: doc comment about gcpro'ing in record_unwind_protect. frame-msw.c: typo. frame.c: avoid problems with errors during init_frame_3. process-nt.c: remove unused mswindows-quote-process-args. rec for 21.4. unexcw.c: use do/while. autoload.el: Oops, off by one argument. mouse.el: Add an argument to mouse-track so that hooks can be overridden. (let-binding doesn't work when the hooks have been made local.) modify mouse-track-run-hook accordingly, and fix mouse-track-default and mouse-track-insert to use the new functionality. printer.el: Oops, off by one paren.
author ben
date Sun, 20 May 2001 01:17:16 +0000
parents eec22eb29327
children 79940b592197
comparison
equal deleted inserted replaced
545:9a775fb11bb7 546:666d73d6ac56
568 (when ex 568 (when ex
569 (funcall (extent-property ex 'activate-function) 569 (funcall (extent-property ex 'activate-function)
570 event ex) 570 event ex)
571 t))) 571 t)))
572 572
573 (defun mouse-track-run-hook (hook event &rest args) 573 (defvar Mouse-track-gensym (gensym))
574
575 (defun mouse-track-run-hook (hook override event &rest args)
574 ;; ugh, can't use run-hook-with-args-until-success because we have 576 ;; ugh, can't use run-hook-with-args-until-success because we have
575 ;; to get the value using symbol-value-in-buffer. Doing a 577 ;; to get the value using symbol-value-in-buffer. Doing a
576 ;; save-excursion/set-buffer is wrong because the hook might want to 578 ;; save-excursion/set-buffer is wrong because the hook might want to
577 ;; change the buffer, but just doing a set-buffer is wrong because 579 ;; change the buffer, but just doing a set-buffer is wrong because
578 ;; the hook might not want to change the buffer. 580 ;; the hook might not want to change the buffer.
579 ;; #### What we need here is a Lisp interface to 581 ;; #### What we need here is a Lisp interface to
580 ;; run_hook_with_args_in_buffer. Here is a poor man's version. 582 ;; run_hook_with_args_in_buffer. Here is a poor man's version.
581 (let ((buffer (event-buffer event))) 583 (let ((overridden (plist-get override hook Mouse-track-gensym)))
582 (and mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer)) 584 (if (not (eq overridden Mouse-track-gensym))
583 (when buffer 585 (if (and (listp overridden) (not (eq (car overridden) 'lambda)))
584 (let ((value (symbol-value-in-buffer hook buffer nil))) 586 (some #'(lambda (val) (apply val event args)) overridden)
585 (if (and (listp value) (not (eq (car value) 'lambda))) 587 (apply overridden event args))
586 ;; List of functions. 588 (let ((buffer (event-buffer event)))
587 (let (retval) 589 (and mouse-grabbed-buffer (setq buffer mouse-grabbed-buffer))
588 (while (and value (null retval)) 590 (when buffer
589 ;; Found `t': should process default value. We could 591 (let ((value (symbol-value-in-buffer hook buffer nil)))
590 ;; splice it into the buffer-local value, but that 592 (if (and (listp value) (not (eq (car value) 'lambda)))
591 ;; would cons, which is not a good thing for 593 ;; List of functions.
592 ;; mouse-track hooks. 594 (let (retval)
593 (if (eq (car value) t) 595 (while (and value (null retval))
594 (let ((global (default-value hook))) 596 ;; Found `t': should process default value. We could
595 (if (and (listp global) (not (eq (car global) 'lambda))) 597 ;; splice it into the buffer-local value, but that
596 ;; List of functions. 598 ;; would cons, which is not a good thing for
597 (while (and global 599 ;; mouse-track hooks.
598 (null (setq retval 600 (if (eq (car value) t)
599 (apply (car global) event args)))) 601 (let ((global (default-value hook)))
600 (pop global)) 602 (if (and (listp global) (not (eq (car global)
601 ;; lambda 603 'lambda)))
602 (setq retval (apply (car global) event args)))) 604 ;; List of functions.
603 (setq retval (apply (car value) event args))) 605 (while (and global
604 (pop value)) 606 (null (setq retval
605 retval) 607 (apply (car global)
606 ;; lambda 608 event args))))
607 (apply value event args)))))) 609 (pop global))
610 ;; lambda
611 (setq retval (apply (car global) event args))))
612 (setq retval (apply (car value) event args)))
613 (pop value))
614 retval)
615 ;; lambda
616 (apply value event args))))))))
608 617
609 (defun mouse-track-scroll-undefined (random) 618 (defun mouse-track-scroll-undefined (random)
610 ;; the old implementation didn't actually define this function, 619 ;; the old implementation didn't actually define this function,
611 ;; and in normal use it won't ever be called because the timeout 620 ;; and in normal use it won't ever be called because the timeout
612 ;; will either be removed before it fires or will be picked off 621 ;; will either be removed before it fires or will be picked off
613 ;; with next-event and not dispatched. However, if you're 622 ;; with next-event and not dispatched. However, if you're
614 ;; attempting to debug a click-hook (which is pretty damn 623 ;; attempting to debug a click-hook (which is pretty damn
615 ;; difficult to do), this function may get called. 624 ;; difficult to do), this function may get called.
616 ) 625 )
617 626
618 (defun mouse-track (event) 627 (defun mouse-track (event &optional overriding-hooks)
619 "Generalized mouse-button handler. This should be bound to a mouse button. 628 "Generalized mouse-button handler. This should be bound to a mouse button.
620 The behavior of this function is customizable using various hooks and 629 The behavior of this function is customizable using various hooks and
621 variables: see `mouse-track-click-hook', `mouse-track-drag-hook', 630 variables: see `mouse-track-click-hook', `mouse-track-drag-hook',
622 `mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook', 631 `mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook',
623 `mouse-track-cleanup-hook', `mouse-track-multi-click-time', 632 `mouse-track-cleanup-hook', `mouse-track-multi-click-time',
626 635
627 Default handlers are provided to implement standard selecting/positioning 636 Default handlers are provided to implement standard selecting/positioning
628 behavior. You can explicitly request this default behavior, and override 637 behavior. You can explicitly request this default behavior, and override
629 any custom-supplied handlers, by using the function `mouse-track-default' 638 any custom-supplied handlers, by using the function `mouse-track-default'
630 instead of `mouse-track'. 639 instead of `mouse-track'.
640
641 \(In general, you can override specific hooks by using the argument
642 OVERRIDING-HOOKS, which should be a plist of alternating hook names
643 and values.)
631 644
632 Default behavior is as follows: 645 Default behavior is as follows:
633 646
634 If you click-and-drag, the selection will be set to the region between the 647 If you click-and-drag, the selection will be set to the region between the
635 point of the initial click and the point at which you release the button. 648 point of the initial click and the point at which you release the button.
667 (> (abs (- mouse-track-up-y orig-y)) ythresh)) 680 (> (abs (- mouse-track-up-y orig-y)) ythresh))
668 (setq mouse-track-click-count 1) 681 (setq mouse-track-click-count 1)
669 (setq mouse-track-click-count (1+ mouse-track-click-count))) 682 (setq mouse-track-click-count (1+ mouse-track-click-count)))
670 (if (not (event-window event)) 683 (if (not (event-window event))
671 (error "Not over a window.")) 684 (error "Not over a window."))
672 (mouse-track-run-hook 'mouse-track-down-hook 685 (mouse-track-run-hook 'mouse-track-down-hook overriding-hooks
673 event mouse-track-click-count) 686 event mouse-track-click-count)
674 (unwind-protect 687 (unwind-protect
675 (while mouse-down 688 (while mouse-down
676 (setq event (next-event event)) 689 (setq event (next-event event))
677 (cond ((motion-event-p event) 690 (cond ((motion-event-p event)
681 (> (abs (- (event-y-pixel event) orig-y)) 694 (> (abs (- (event-y-pixel event) orig-y))
682 ythresh))) 695 ythresh)))
683 (setq mouse-moved t)) 696 (setq mouse-moved t))
684 (if mouse-moved 697 (if mouse-moved
685 (mouse-track-run-hook 'mouse-track-drag-hook 698 (mouse-track-run-hook 'mouse-track-drag-hook
686 event mouse-track-click-count nil)) 699 overriding-hooks
700 event mouse-track-click-count nil))
687 (mouse-track-set-timeout event)) 701 (mouse-track-set-timeout event))
688 ((and (timeout-event-p event) 702 ((and (timeout-event-p event)
689 (eq (event-function event) 703 (eq (event-function event)
690 'mouse-track-scroll-undefined)) 704 'mouse-track-scroll-undefined))
691 (if mouse-moved 705 (if mouse-moved
692 (mouse-track-run-hook 'mouse-track-drag-hook 706 (mouse-track-run-hook 'mouse-track-drag-hook
693 (event-object event) mouse-track-click-count t)) 707 overriding-hooks
708 (event-object event)
709 mouse-track-click-count t))
694 (mouse-track-set-timeout (event-object event))) 710 (mouse-track-set-timeout (event-object event)))
695 ((button-release-event-p event) 711 ((button-release-event-p event)
696 (setq mouse-track-up-time (event-timestamp event)) 712 (setq mouse-track-up-time (event-timestamp event))
697 (setq mouse-track-up-x (event-x-pixel event)) 713 (setq mouse-track-up-x (event-x-pixel event))
698 (setq mouse-track-up-y (event-y-pixel event)) 714 (setq mouse-track-up-y (event-y-pixel event))
699 (setq mouse-down nil) 715 (setq mouse-down nil)
700 (mouse-track-run-hook 'mouse-track-up-hook 716 (mouse-track-run-hook 'mouse-track-up-hook
701 event mouse-track-click-count) 717 overriding-hooks
718 event mouse-track-click-count)
702 (if mouse-moved 719 (if mouse-moved
703 (mouse-track-run-hook 'mouse-track-drag-up-hook 720 (mouse-track-run-hook 'mouse-track-drag-up-hook
704 event mouse-track-click-count) 721 overriding-hooks
722 event mouse-track-click-count)
705 (mouse-track-run-hook 'mouse-track-click-hook 723 (mouse-track-run-hook 'mouse-track-click-hook
706 event mouse-track-click-count))) 724 overriding-hooks
725 event mouse-track-click-count)))
707 ((or (key-press-event-p event) 726 ((or (key-press-event-p event)
708 (and (misc-user-event-p event) 727 (and (misc-user-event-p event)
709 (eq (event-function event) 'cancel-mode-internal))) 728 (eq (event-function event) 'cancel-mode-internal)))
710 (error "Selection aborted")) 729 (error "Selection aborted"))
711 (t 730 (t
715 (disable-timeout mouse-track-timeout-id)) 734 (disable-timeout mouse-track-timeout-id))
716 (setq mouse-track-timeout-id nil) 735 (setq mouse-track-timeout-id nil)
717 (and (buffer-live-p buffer) 736 (and (buffer-live-p buffer)
718 (save-excursion 737 (save-excursion
719 (set-buffer buffer) 738 (set-buffer buffer)
720 (run-hooks 'mouse-track-cleanup-hook)))))) 739 (let ((override (plist-get overriding-hooks
740 'mouse-track-cleanup-hook
741 Mouse-track-gensym)))
742 (if (not (eq override Mouse-track-gensym))
743 (if (and (listp override) (not (eq (car override) 'lambda)))
744 (mapc #'funcall override)
745 (funcall override))
746 (run-hooks 'mouse-track-cleanup-hook))))))))
721 747
722 748
723 ;;;;;;;;;;;; default handlers: new version of mouse-track 749 ;;;;;;;;;;;; default handlers: new version of mouse-track
724 750
725 (defvar default-mouse-track-type nil) 751 (defvar default-mouse-track-type nil)
1317 ;;;;;;;;;;;; default handlers) 1343 ;;;;;;;;;;;; default handlers)
1318 1344
1319 (defun mouse-track-default (event) 1345 (defun mouse-track-default (event)
1320 "Invoke `mouse-track' with only the default handlers active." 1346 "Invoke `mouse-track' with only the default handlers active."
1321 (interactive "e") 1347 (interactive "e")
1322 (let ((mouse-track-down-hook 'default-mouse-track-down-hook) 1348 (mouse-track event
1323 (mouse-track-drag-hook 'default-mouse-track-drag-hook) 1349 '(mouse-track-down-hook
1324 (mouse-track-drag-up-hook 'default-mouse-track-drag-up-hook) 1350 default-mouse-track-down-hook
1325 (mouse-track-click-hook 'default-mouse-track-click-hook) 1351 mouse-track-up-hook nil
1326 (mouse-track-cleanup-hook 'default-mouse-track-cleanup-hook)) 1352 mouse-track-drag-hook default-mouse-track-drag-hook
1327 (mouse-track event))) 1353 mouse-track-drag-up-hook default-mouse-track-drag-up-hook
1354 mouse-track-click-hook default-mouse-track-click-hook
1355 mouse-track-cleanup-hook default-mouse-track-cleanup-hook)))
1328 1356
1329 (defun mouse-track-do-rectangle (event) 1357 (defun mouse-track-do-rectangle (event)
1330 "Like `mouse-track' but selects rectangles instead of regions." 1358 "Like `mouse-track' but selects rectangles instead of regions."
1331 (interactive "e") 1359 (interactive "e")
1332 (let ((mouse-track-rectangle-p t)) 1360 (let ((mouse-track-rectangle-p t))
1353 custom mouse-track handlers that the user may have installed." 1381 custom mouse-track handlers that the user may have installed."
1354 (interactive "e") 1382 (interactive "e")
1355 (let ((default-mouse-track-adjust t)) 1383 (let ((default-mouse-track-adjust t))
1356 (mouse-track-default event))) 1384 (mouse-track-default event)))
1357 1385
1358 (defvar mouse-track-insert-selected-region nil)
1359
1360 (defun mouse-track-insert-drag-up-hook (event click-count)
1361 (setq mouse-track-insert-selected-region
1362 (default-mouse-track-return-dragged-selection event)))
1363
1364 (defun mouse-track-insert (event &optional delete) 1386 (defun mouse-track-insert (event &optional delete)
1365 "Make a selection with the mouse and insert it at point. 1387 "Make a selection with the mouse and insert it at point.
1366 This is exactly the same as the `mouse-track' command on \\[mouse-track], 1388 This is exactly the same as the `mouse-track' command on \\[mouse-track],
1367 except that point is not moved; the selected text is immediately inserted 1389 except that point is not moved; the selected text is immediately inserted
1368 after being selected\; and the selection is immediately disowned afterwards." 1390 after being selected\; and the selection is immediately disowned afterwards."
1369 (interactive "*e") 1391 (interactive "*e")
1370 (setq mouse-track-insert-selected-region nil) 1392 (let (s selreg)
1371 (let ((mouse-track-drag-up-hook 'mouse-track-insert-drag-up-hook) 1393 (flet ((Mouse-track-insert-drag-up-hook (event count)
1372 (mouse-track-click-hook 'mouse-track-insert-click-hook) 1394 (setq selreg
1373 s) 1395 (default-mouse-track-return-dragged-selection event))
1374 (save-excursion 1396 t)
1375 (save-window-excursion 1397 (Mouse-track-insert-click-hook (event count)
1376 (mouse-track event) 1398 (default-mouse-track-drag-hook event count nil)
1377 (if (consp mouse-track-insert-selected-region) 1399 (setq selreg
1378 (let ((pair mouse-track-insert-selected-region)) 1400 (default-mouse-track-return-dragged-selection event))
1379 (setq s (prog1 1401 t))
1380 (buffer-substring (car pair) (cdr pair)) 1402 (save-excursion
1381 (if delete 1403 (save-window-excursion
1382 (kill-region (car pair) (cdr pair))))))))) 1404 (mouse-track
1383 (or (null s) (equal s "") (insert s)))) 1405 event
1384 1406 '(mouse-track-drag-up-hook
1385 (defun mouse-track-insert-click-hook (event click-count) 1407 Mouse-track-insert-drag-up-hook
1386 (default-mouse-track-drag-hook event click-count nil) 1408 mouse-track-click-hook
1387 (mouse-track-insert-drag-up-hook event click-count) 1409 Mouse-track-insert-click-hook))
1388 t) 1410 (if (consp selreg)
1411 (let ((pair selreg))
1412 (setq s (prog1
1413 (buffer-substring (car pair) (cdr pair))
1414 (if delete
1415 (kill-region (car pair) (cdr pair))))))))))
1416 (or (null s) (equal s "") (insert s))))
1389 1417
1390 (defun mouse-track-delete-and-insert (event) 1418 (defun mouse-track-delete-and-insert (event)
1391 "Make a selection with the mouse and insert it at point. 1419 "Make a selection with the mouse and insert it at point.
1392 This is exactly the same as the `mouse-track' command on \\[mouse-track], 1420 This is exactly the same as the `mouse-track' command on \\[mouse-track],
1393 except that point is not moved; the selected text is immediately inserted 1421 except that point is not moved; the selected text is immediately inserted