(MH-0158): New character.

[chise/xemacs-chise.git-] / lisp / mouse.el

diff --git a/lisp/mouse.el b/lisp/mouse.el
index 54dafc7..0c76138 100644 (file)
--- a/lisp/mouse.el
+++ b/lisp/mouse.el
@@ -2,7 +2,7 @@
 
 ;; Copyright (C) 1988, 1992-4, 1997 Free Software Foundation, Inc.
 ;; Copyright (C) 1995 Tinker Systems
 
 ;; Copyright (C) 1988, 1992-4, 1997 Free Software Foundation, Inc.
 ;; Copyright (C) 1995 Tinker Systems

-;; Copyright (C) 1995, 1996 Ben Wing.
+;; Copyright (C) 1995, 1996, 2000 Ben Wing.

 
 ;; Maintainer: XEmacs Development Team
 ;; Keywords: mouse, dumped
 
 ;; Maintainer: XEmacs Development Team
 ;; Keywords: mouse, dumped

@@ -30,6 +30,15 @@
 
 ;; This file is dumped with XEmacs (when window system support is compiled in).
 
 
 ;; This file is dumped with XEmacs (when window system support is compiled in).
 

+;;; Authorship:
+
+;; Probably originally derived from FSF 19 pre-release.
+;; much hacked upon by Jamie Zawinski and crew, pre-1994.
+;;   (only mouse-motion stuff currently remains from that era)
+;; all mouse-track stuff completely rewritten by Ben Wing, 1995-1996.
+;; mouse-eval-sexp and *-inside-extent-p from Stig, 1995.
+;; vertical divider code c. 1998 from ?.
+

 ;;; Code:
 
 (provide 'mouse)
 ;;; Code:
 
 (provide 'mouse)

@@ -39,16 +48,7 @@
 (global-set-key '(control button1) 'mouse-track-insert)
 (global-set-key '(control shift button1) 'mouse-track-delete-and-insert)
 (global-set-key '(meta button1) 'mouse-track-do-rectangle)
 (global-set-key '(control button1) 'mouse-track-insert)
 (global-set-key '(control shift button1) 'mouse-track-delete-and-insert)
 (global-set-key '(meta button1) 'mouse-track-do-rectangle)

-
-;; drops are now handled in dragdrop.el (ograf@fga.de)
-
-;; enable drag regions (ograf@fga.de)
-;; if button2 is dragged from within a region, this becomes a drop
-;;
-;; this must be changed to the new api
-(if (featurep '(or offix cde mswindows))
-    (global-set-key 'button2 'mouse-drag-or-yank)
-  (global-set-key 'button2 'mouse-yank))
+(global-set-key 'button2 'mouse-track)

 
 (defgroup mouse nil
   "Window system-independent mouse support."
 
 (defgroup mouse nil
   "Window system-independent mouse support."

@@ -84,10 +84,13 @@ If set to `symbol', double-click will always attempt to highlight a
   "Function that is called upon by `mouse-yank' to actually insert text.")
 
 (defun mouse-consolidated-yank ()
   "Function that is called upon by `mouse-yank' to actually insert text.")
 
 (defun mouse-consolidated-yank ()

-  "Insert the current selection or, if there is none under X insert the X cutbuffer.
-A mark is pushed, so that the inserted text lies between point and mark."
+  "Insert the current selection or, if there is none under X insert
+the X cutbuffer.  A mark is pushed, so that the inserted text lies
+between point and mark."

   (interactive)
   (interactive)

-  (if (not (console-on-window-system-p))
+  (if (and (not (console-on-window-system-p))
+          (and (featurep 'gpm)
+               (not gpm-minor-mode)))

       (yank)
     (push-mark)
     (if (region-active-p)
       (yank)
     (push-mark)
     (if (region-active-p)

@@ -116,7 +119,7 @@ A mark is pushed, so that the inserted text lies between point and mark."
   (interactive "P")
   ;; we fallback to the clipboard if the current selection is not existent
   (let ((text (if check-cutbuffer-p
   (interactive "P")
   ;; we fallback to the clipboard if the current selection is not existent
   (let ((text (if check-cutbuffer-p

-                 (or (get-selection-no-error) 
+                 (or (get-selection-no-error)

                      (get-cutbuffer)
                      (get-selection-no-error 'CLIPBOARD)
                      (error "No selection, clipboard or cut buffer available"))
                      (get-cutbuffer)
                      (get-selection-no-error 'CLIPBOARD)
                      (error "No selection, clipboard or cut buffer available"))

@@ -182,7 +185,6 @@ location."
 (defun click-inside-extent-p (click extent)
   "Return non-nil if the button event is within the primary selection-extent.
 Return nil otherwise."
 (defun click-inside-extent-p (click extent)
   "Return non-nil if the button event is within the primary selection-extent.
 Return nil otherwise."

-  ;; stig@hackvan.com

   (let ((ewin (event-window click))
        (epnt (event-point click)))
     (and ewin
   (let ((ewin (event-window click))
        (epnt (event-point click)))
     (and ewin

@@ -203,7 +205,6 @@ Return nil otherwise."
   "Return t if point is within the bounds of the primary selection extent.
 Return t is point is at the end position of the extent.
 Return nil otherwise."
   "Return t if point is within the bounds of the primary selection extent.
 Return t is point is at the end position of the extent.
 Return nil otherwise."

-  ;; stig@hackvan.com

   (and extent
        (eq (current-buffer)
           (extent-object extent))
   (and extent
        (eq (current-buffer)
           (extent-object extent))

@@ -211,40 +212,33 @@ Return nil otherwise."
        (>= (extent-end-position extent) (point))))
 
 (defun point-inside-selection-p ()
        (>= (extent-end-position extent) (point))))
 
 (defun point-inside-selection-p ()

-  ;; by Stig@hackvan.com

   (or (point-inside-extent-p primary-selection-extent)
       (point-inside-extent-p zmacs-region-extent)))
 
   (or (point-inside-extent-p primary-selection-extent)
       (point-inside-extent-p zmacs-region-extent)))
 

-(defun mouse-drag-or-yank (event)
-  "Either drag or paste the current selection.
-If the variable `mouse-yank-at-point' is non-nil,
-move the cursor to the location of the click before pasting.
-This functions has to be improved.  Currently it is just a (working) test."
-  ;; by Oliver Graf <ograf@fga.de>
-  (interactive "e")
-  (if (click-inside-extent-p event zmacs-region-extent)
-      ;; okay, this is a drag
-      (cond ((featurep 'offix)
-            (offix-start-drag-region event
-                                     (extent-start-position zmacs-region-extent)
-                                     (extent-end-position zmacs-region-extent)))
-           ((featurep 'cde)
-            ;; should also work with CDE
-            (cde-start-drag-region event
-                                   (extent-start-position zmacs-region-extent)
-                                   (extent-end-position zmacs-region-extent)))
-           (t (error "No offix or CDE support compiled in")))
-    ;; no drag, call region-funct
-    (and (not mouse-yank-at-point)
-        (mouse-set-point event))
-    (funcall mouse-yank-function))
-  )
+(defun mouse-begin-drag-n-drop (event)
+  "Begin a drag-n-drop operation.
+EVENT should be the button event that initiated the drag.
+Returns whether a drag was begun."
+  ;; #### barely implemented.
+  (when (click-inside-selection-p event)
+    (cond ((featurep 'offix)
+          (offix-start-drag-region
+           event
+           (extent-start-position zmacs-region-extent)
+           (extent-end-position zmacs-region-extent))
+          t)
+         ((featurep 'cde)
+          ;; should also work with CDE
+          (cde-start-drag-region event
+                                 (extent-start-position zmacs-region-extent)
+                                 (extent-end-position zmacs-region-extent))
+          t))))

 
 (defun mouse-eval-sexp (click force-window)
   "Evaluate the sexp under the mouse.  Usually, this is the last sexp before
 the click, but if you click on a left paren, then it is the sexp beginning
 with the paren that is evaluated.  Also, since strings evaluate to themselves,
 
 (defun mouse-eval-sexp (click force-window)
   "Evaluate the sexp under the mouse.  Usually, this is the last sexp before
 the click, but if you click on a left paren, then it is the sexp beginning
 with the paren that is evaluated.  Also, since strings evaluate to themselves,

-they're fed to re-search-forward and the matched region is highlighted until
+they're fed to `re-search-forward' and the matched region is highlighted until

 the mouse button is released.
 
 Perhaps the most useful thing about this function is that the evaluation of
 the mouse button is released.
 
 Perhaps the most useful thing about this function is that the evaluation of

@@ -253,7 +247,6 @@ click, but to the current window and the current position of point.  Thus,
 you can use `mouse-eval-sexp' to interactively test code that acts upon a
 buffer...something you cannot do with the standard `eval-last-sexp' function.
 It's also fantastic for debugging regular expressions."
 you can use `mouse-eval-sexp' to interactively test code that acts upon a
 buffer...something you cannot do with the standard `eval-last-sexp' function.
 It's also fantastic for debugging regular expressions."

-  ;; by Stig@hackvan.com

   (interactive "e\nP")
   (let (exp val result-str)
     (setq exp (save-window-excursion
   (interactive "e\nP")
   (let (exp val result-str)
     (setq exp (save-window-excursion

@@ -350,7 +343,7 @@ Display cursor at that position for a second."
       (switch-to-buffer val))))
 
 (defun narrow-window-to-region (m n)
       (switch-to-buffer val))))
 
 (defun narrow-window-to-region (m n)

-  "Narrow window to region between point and last mark"
+  "Narrow window to region between point and last mark."

   (interactive "r")
   (save-excursion
     (save-restriction
   (interactive "r")
   (save-excursion
     (save-restriction

@@ -499,6 +492,36 @@ A value of nil disables the timeout feature."
   :type '(choice integer (const :tag "Disabled" nil))
   :group 'mouse)
 
   :type '(choice integer (const :tag "Disabled" nil))
   :group 'mouse)
 

+(defcustom mouse-track-activate-strokes '(button1-double-click button2-click)
+  "List of mouse strokes that can cause \"activation\" of the text extent
+under the mouse.  The exact meaning of \"activation\" is dependent on the
+text clicked on and the mode of the buffer, but typically entails actions
+such as following a hyperlink or selecting an entry in a completion buffer.
+
+Possible list entries are
+
+button1-click
+button1-double-click
+button1-triple-click
+button1-down
+button2-click
+button2-double-click
+button2-triple-click
+button2-down
+
+As a general rule, you should not use the \"-down\" values, because this
+makes it impossible to have other simultaneous actions, such as selection."
+  :type '(set
+         button1-click
+         button1-double-click
+         button1-triple-click
+         button1-down
+         button2-click
+         button2-double-click
+         button2-triple-click
+         button2-down)
+  :group 'mouse)
+

 (defvar mouse-track-x-threshold '(face-width 'default)
   "Minimum number of pixels in the X direction for a drag to be initiated.
 If the mouse is moved more than either the X or Y threshold while the
 (defvar mouse-track-x-threshold '(face-width 'default)
   "Minimum number of pixels in the X direction for a drag to be initiated.
 If the mouse is moved more than either the X or Y threshold while the

@@ -535,6 +558,15 @@ produce a number.")
                         'mouse-track-scroll-undefined
                         (copy-event event)))))
 
                         'mouse-track-scroll-undefined
                         (copy-event event)))))
 

+(defun mouse-track-do-activate (event)
+  "Execute the activate function under EVENT, if any.
+Return true if the function was activated."
+  (let ((ex (extent-at-event event 'activate-function)))
+    (when ex
+      (funcall (extent-property ex 'activate-function)
+              event ex)
+      t)))
+

 (defun mouse-track-run-hook (hook event &rest args)
   ;; ugh, can't use run-hook-with-args-until-success because we have
   ;; to get the value using symbol-value-in-buffer.  Doing a
 (defun mouse-track-run-hook (hook event &rest args)
   ;; ugh, can't use run-hook-with-args-until-success because we have
   ;; to get the value using symbol-value-in-buffer.  Doing a

@@ -581,9 +613,9 @@ produce a number.")
 )
 
 (defun mouse-track (event)
 )
 
 (defun mouse-track (event)

-  "Make a selection with the mouse.  This should be bound to a mouse button.
-The behavior of XEmacs during mouse selection is customizable using various
-hooks and variables: see `mouse-track-click-hook', `mouse-track-drag-hook',
+  "Generalized mouse-button handler.  This should be bound to a mouse button.
+The behavior of this function is customizable using various hooks and
+variables: see `mouse-track-click-hook', `mouse-track-drag-hook',

 `mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook',
 `mouse-track-cleanup-hook', `mouse-track-multi-click-time',
 `mouse-track-scroll-delay', `mouse-track-x-threshold', and
 `mouse-track-drag-up-hook', `mouse-track-down-hook', `mouse-track-up-hook',
 `mouse-track-cleanup-hook', `mouse-track-multi-click-time',
 `mouse-track-scroll-delay', `mouse-track-x-threshold', and

@@ -716,7 +748,7 @@ at the initial click position."
       (let* ((edges (window-pixel-edges window))
             (row (event-y-pixel event))
             (text-start (nth 1 edges))
       (let* ((edges (window-pixel-edges window))
             (row (event-y-pixel event))
             (text-start (nth 1 edges))

-            (text-end (+ (nth 3 edges))))
+            (text-end (nth 3 edges)))

        (if (or (< row text-start)
                (> row text-end))
            nil ;; Scroll
        (if (or (< row text-start)
                (> row text-end))
            nil ;; Scroll

@@ -1106,9 +1138,26 @@ at the initial click position."
                   (disown-selection)))))
       (setq default-mouse-track-down-event nil))))
 
                   (disown-selection)))))
       (setq default-mouse-track-down-event nil))))
 

+;; return t if the button or motion event involved the specified button.
+(defun default-mouse-track-event-is-with-button (event n)
+  (cond ((button-event-p event)
+        (= n (event-button event)))
+       ((motion-event-p event)
+        (memq (cdr
+               (assq n '((1 . button1) (2 . button2) (3 . button3)
+                         (4 . button4) (5 . button5))))
+              (event-modifiers event)))))
+

 (defun default-mouse-track-down-hook (event click-count)
 (defun default-mouse-track-down-hook (event click-count)

-  (setq default-mouse-track-down-event (copy-event event))
-  nil)
+  (cond ((default-mouse-track-event-is-with-button event 1)
+        (if (and (memq 'button1-down mouse-track-activate-strokes)
+                 (mouse-track-do-activate event))
+            t
+          (setq default-mouse-track-down-event (copy-event event))
+          nil))
+       ((default-mouse-track-event-is-with-button event 2)
+        (and (memq 'button2-down mouse-track-activate-strokes)
+             (mouse-track-do-activate event)))))

 
 (defun default-mouse-track-cleanup-extents-hook ()
   (remove-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)
 
 (defun default-mouse-track-cleanup-extents-hook ()
   (remove-hook 'pre-command-hook 'default-mouse-track-cleanup-extents-hook)

@@ -1129,7 +1178,8 @@ at the initial click position."
       (if (consp extent)               ; rectangle-p
          (mapcar func extent)
        (if extent
       (if (consp extent)               ; rectangle-p
          (mapcar func extent)
        (if extent

-           (funcall func extent))))))
+           (funcall func extent)))))
+  t)

 
 (defun default-mouse-track-cleanup-extent ()
   (let ((dead-func
 
 (defun default-mouse-track-cleanup-extent ()
   (let ((dead-func

@@ -1149,13 +1199,16 @@ at the initial click position."
          (setq default-mouse-track-extent nil)))))
 
 (defun default-mouse-track-drag-hook (event click-count was-timeout)
          (setq default-mouse-track-extent nil)))))
 
 (defun default-mouse-track-drag-hook (event click-count was-timeout)

-  (default-mouse-track-deal-with-down-event click-count)
-  (default-mouse-track-set-point event default-mouse-track-window)
-  (default-mouse-track-cleanup-extent)
-  (default-mouse-track-next-move default-mouse-track-min-anchor
-    default-mouse-track-max-anchor
-    default-mouse-track-extent)
-  t)
+  (cond ((default-mouse-track-event-is-with-button event 1)
+        (default-mouse-track-deal-with-down-event click-count)
+        (default-mouse-track-set-point event default-mouse-track-window)
+        (default-mouse-track-cleanup-extent)
+        (default-mouse-track-next-move default-mouse-track-min-anchor
+          default-mouse-track-max-anchor
+          default-mouse-track-extent)
+        t)
+       ((default-mouse-track-event-is-with-button event 2)
+        (mouse-begin-drag-n-drop event))))

 
 (defun default-mouse-track-return-dragged-selection (event)
   (default-mouse-track-cleanup-extent)
 
 (defun default-mouse-track-return-dragged-selection (event)
   (default-mouse-track-cleanup-extent)

@@ -1206,15 +1259,45 @@ at the initial click position."
     result))
 
 (defun default-mouse-track-drag-up-hook (event click-count)
     result))
 
 (defun default-mouse-track-drag-up-hook (event click-count)

-  (let ((result (default-mouse-track-return-dragged-selection event)))
-    (if result
-       (default-mouse-track-maybe-own-selection result 'PRIMARY)))
-  t)
+  (when (default-mouse-track-event-is-with-button event 1)
+    (let ((result (default-mouse-track-return-dragged-selection event)))
+      (if result
+         (default-mouse-track-maybe-own-selection result 'PRIMARY)))
+    t))

 
 (defun default-mouse-track-click-hook (event click-count)
 
 (defun default-mouse-track-click-hook (event click-count)

-  (default-mouse-track-drag-hook event click-count nil)
-  (default-mouse-track-drag-up-hook event click-count)
-  t)
+  (cond ((default-mouse-track-event-is-with-button event 1)
+        (if (and
+             (or (and (= click-count 1)
+                      (memq 'button1-click
+                            mouse-track-activate-strokes))
+                 (and (= click-count 2)
+                      (memq 'button1-double-click
+                            mouse-track-activate-strokes))
+                 (and (= click-count 3)
+                      (memq 'button1-triple-click
+                            mouse-track-activate-strokes)))
+             (mouse-track-do-activate event))
+            t
+          (default-mouse-track-drag-hook event click-count nil)
+          (default-mouse-track-drag-up-hook event click-count)
+          t))
+       ((default-mouse-track-event-is-with-button event 2)
+        (if (and
+             (or (and (= click-count 1)
+                      (memq 'button2-click
+                            mouse-track-activate-strokes))
+                 (and (= click-count 2)
+                      (memq 'button2-double-click
+                            mouse-track-activate-strokes))
+                 (and (= click-count 3)
+                      (memq 'button2-triple-click
+                            mouse-track-activate-strokes)))
+             (mouse-track-do-activate event))
+            t
+          (mouse-yank event)
+          t))))
+

 
 (add-hook 'mouse-track-down-hook 'default-mouse-track-down-hook)
 (add-hook 'mouse-track-drag-hook 'default-mouse-track-drag-hook)
 
 (add-hook 'mouse-track-down-hook 'default-mouse-track-down-hook)
 (add-hook 'mouse-track-drag-hook 'default-mouse-track-drag-hook)

@@ -1379,7 +1462,7 @@ and `mode-motion-hook'."
         ;; vars is a list of glyph variables to check for a pointer
         ;; value.
         (vars (cond
         ;; vars is a list of glyph variables to check for a pointer
         ;; value.
         (vars (cond

-               ;; Checking if button is non-nil is not sufficent
+               ;; Checking if button is non-nil is not sufficient

                ;; since the pointer could be over a blank portion
                ;; of the toolbar.
                ((event-over-toolbar-p event)
                ;; since the pointer could be over a blank portion
                ;; of the toolbar.
                ((event-over-toolbar-p event)

@@ -1467,7 +1550,7 @@ and `mode-motion-hook'."
 ;;
 (defun drag-window-divider (event)
   "Handle resizing windows by dragging window dividers.
 ;;
 (defun drag-window-divider (event)
   "Handle resizing windows by dragging window dividers.

-This is an intenal function, normally bound to button1 event in
+This is an internal function, normally bound to button1 event in

 window-divider-map. You would not call it, but you may bind it to
 other mouse buttons."
   (interactive "e")
 window-divider-map. You would not call it, but you may bind it to
 other mouse buttons."
   (interactive "e")

@@ -1521,10 +1604,10 @@ other mouse buttons."
                 (setq last-timestamp (event-timestamp event))
                 ;; Enlarge the window, calculating change in characters
                 ;; of default font. Do not let the window to become
                 (setq last-timestamp (event-timestamp event))
                 ;; Enlarge the window, calculating change in characters
                 ;; of default font. Do not let the window to become

-                ;; less than alolwed minimum (not because that's critical
+                ;; less than allowed minimum (not because that's critical

                 ;; for the code performance, just the visual effect is
                 ;; better: when cursor goes to the left of the next left
                 ;; for the code performance, just the visual effect is
                 ;; better: when cursor goes to the left of the next left

-                ;; divider, the vindow being resized shrinks to minimal
+                ;; divider, the window being resized shrinks to minimal

                 ;; size.
                 (enlarge-window (max (- window-min-width (window-width window))
                                      (/ (- (event-x-pixel event) old-right)
                 ;; size.
                 (enlarge-window (max (- window-min-width (window-width window))
                                      (/ (- (event-x-pixel event) old-right)

@@ -1534,7 +1617,7 @@ other mouse buttons."
                 ;; if the change caused more than two windows to resize
                 ;; (shifting the whole stack right is ugly), or if the
                 ;; left window side has slipped (right side cannot be
                 ;; if the change caused more than two windows to resize
                 ;; (shifting the whole stack right is ugly), or if the
                 ;; left window side has slipped (right side cannot be

-                ;; moved any funrther to the right, so enlarge-window
+                ;; moved any further to the right, so enlarge-window

                 ;; plays bad games with the left edge.
                 (if (or (/= (count-windows) (length old-edges-all-windows))
                         (/= old-left (car (window-pixel-edges window)))
                 ;; plays bad games with the left edge.
                 (if (or (/= (count-windows) (length old-edges-all-windows))
                         (/= old-left (car (window-pixel-edges window)))