[NEW PATCH] mouse-1 click follows link

[Kim F. Storm]

address@hidden (Kim F. Storm) writes:

> Luc Teirlinck <address@hidden> writes:
>
>> As I already said, I believe that there _must_ be substantially better
>> ways to give users the option to have web browser style bindings for
>> true links than the one you proposed.

Ok, here is a different approach, which does not blindly map mouse-1
to mouse-2, but requires explicit marking of "hyper links".

In the patch below, the changes to mouse.el, help.el and tooltip.el
are mostly identical to the previous set of patches, but with this
approch there are additional (small) patches to a few other lisp
packages to properly mark the hyper links in different modes.

I'm convinced that the new approach is superior to the old approach --
as it is still almost the same size and complexity, but there are no
longer any 'surprises' due to 'blind guessing'. (I had a few of those
myself with the old approach).  There may be links that doesn't work
(yet), but they should be trivial to fix.


At its base, the new approach still hooks into mouse-drag-region as
the old patch, but it now uses a mouse-on-link-p function which looks
for an explicit 'follow-link' property or key binding at the point
where you click mouse-1:

 (defun mouse-on-link-p (pos)
   (or (get-char-property pos 'follow-link)
       (save-excursion
        (goto-char pos)
        (let ((b (key-binding [follow-link] t t)))
          (cond
           ((eq b 'mouse-face) (get-char-property pos 'mouse-face))
           ((functionp b) (funcall b pos))
           (t b))))))
 
It identifies a link at POS in the current buffer by several methods,
as there is no single method which works for all modes:

1) If there is a non-nil 'follow-link' property at POS

2) If there is a key binding for [follow-link] at POS, and

  2a) the binding is 'mouse-face' and there is a mouse-face property
      at POS, or

  2b) the binding is a function F, and (F POS) returns non-nil, or

  2c) the binding is anythings else but nil.

If the return value from mouse-on-link-p is a vector or string, the
mouse-1 up event is mapped into the first character/event in the
sequence -- otherwise, mouse-1 is mapped to mouse-2.

Specifically, it returns the value of the property for 1 and 2a, the
return value from F in 2b, and the key binding in 2c.


Buttons and similar links will typically use (1).

If a mode uses mouse-face for all links in a buffer, and all mouse-face
indicates links, it can simply put a binding [follow-link] -> mouse-face
into its local keymap.  (2a)

If a mode uses mouse-face for some links, but also for other stuff, it
can use a binding [follow-link] -> FUNC in its local keymap, where
FUNC is a function that tests whether there is a link at POS.  See
the example for pcvs-defs.el below to make clicking on the file name
open that file, but not when clicking on the 'status' of a file.  (2b)

If the binding for mouse-2 works everywhere in a buffer (and uses other
means to determine what to do), a mode may bind [follow-link] -> t to
let mouse-1 do what mouse-2 does  (2c).


To simplify things, button definitions may now have a follow-link
attribute, and widget definitions may have a :follow-link attribute,
both of which maps into a follow-link property on the relevant overlay
or text.

As you can see, I have found some "buttons" and modes where I think
the mouse-1 click should follow links, but there may be more...



Index: mouse.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/mouse.el,v
retrieving revision 1.257
diff -c -r1.257 mouse.el
*** mouse.el    13 Nov 2004 01:29:45 -0000      1.257
--- mouse.el    27 Nov 2004 00:03:39 -0000
***************
*** 49,54 ****
--- 49,78 ----
    :version "21.4"
    :group 'mouse)
  
+ (defcustom mouse-1-click-follows-link 350
+   "Non-nil means that clicking mouse-1 on a link follows the link.
+ This is only done for links which have the mouse-face property.
+ 
+ If value is the symbol double, a double click follows the link.
+ 
+ If value is an integer, the time elapsed between pressing and
+ releasing the mouse button determines whether to follow the link
+ or perform the normal mouse-1 action (typically set point).
+ The absolute numeric value specifices the maximum duration of a
+ \"short click\" in milliseconds.  A positive value means that a
+ short click follows the link, and a longer click performs the
+ normal action.  A negative value gives the opposite behaviour.
+ 
+ Otherwise, a single mouse-1 click unconditionally follows the link.
+ 
+ Note that dragging the mouse never follows the link."
+   :version "21.4"
+   :type '(choice (const :tag "Disabled" nil)
+                (const :tag "Double click" double)
+                  (number :tag "Single click time limit" :value 350)
+                  (other :tag "Single click" t))
+   :group 'mouse)
+ 
  
  ;; Provide a mode-specific menu on a mouse button.
  
***************
*** 733,738 ****
--- 757,772 ----
        (run-hooks 'mouse-leave-buffer-hook)
        (mouse-drag-region-1 start-event))))
  
+ (defun mouse-on-link-p (pos)
+   (or (get-char-property pos 'follow-link)
+       (save-excursion
+       (goto-char pos)
+       (let ((b (key-binding [follow-link] t t)))
+         (cond
+          ((eq b 'mouse-face) (get-char-property pos 'mouse-face))
+          ((functionp b) (funcall b pos))
+          (t b))))))
+ 
  (defun mouse-drag-region-1 (start-event)
    (mouse-minibuffer-check start-event)
    (let* ((echo-keystrokes 0)
***************
*** 749,754 ****
--- 783,789 ----
                     (nth 3 bounds)
                   ;; Don't count the mode line.
                   (1- (nth 3 bounds))))
+        on-link remap-double-click
         (click-count (1- (event-click-count start-event))))
      (setq mouse-selection-click-count click-count)
      (setq mouse-selection-click-count-buffer (current-buffer))
***************
*** 758,763 ****
--- 793,805 ----
      (if (< (point) start-point)
        (goto-char start-point))
      (setq start-point (point))
+     (setq on-link (and mouse-1-click-follows-link
+                      (mouse-on-link-p start-point)))
+     (setq remap-double-click (and on-link
+                                 (eq mouse-1-click-follows-link 'double)
+                                 (= click-count 1)))
+     (if remap-double-click  ;; Don't expand mouse overlay in links
+       (setq click-count 0))
      (let ((range (mouse-start-end start-point start-point click-count)))
        (move-overlay mouse-drag-overlay (car range) (nth 1 range)
                    (window-buffer start-window))
***************
*** 880,885 ****
--- 922,949 ----
                         (or end-point
                             (= (window-start start-window)
                                start-window-start)))
+               (if (and on-link
+                        (not end-point)
+                        (consp event)
+                        (or remap-double-click
+                            (and
+                             (not (eq mouse-1-click-follows-link 'double))
+                             (= click-count 0)
+                             (= (event-click-count event) 1)
+                             (not (input-pending-p))
+                             (or (not (integerp mouse-1-click-follows-link))
+                                 (let ((t0 (posn-timestamp (event-start 
start-event)))
+                                       (t1 (posn-timestamp (event-end event))))
+                                   (and (integerp t0) (integerp t1)
+                                        (if (> mouse-1-click-follows-link 0)
+                                            (<= (- t1 t0) 
mouse-1-click-follows-link)
+                                          (< (- t0 t1) 
mouse-1-click-follows-link)))))
+                             (or (not double-click-time)
+                                 (sit-for 0 (if (integerp double-click-time)
+                                                double-click-time 500) t)))))
+                   (if (or (vectorp on-link) (stringp on-link))
+                       (setq event (aref on-link 0))
+                     (setcar event 'mouse-2)))
                (setq unread-command-events
                      (cons event unread-command-events)))))
        (delete-overlay mouse-drag-overlay)))))
Index: help.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/help.el,v
retrieving revision 1.271
diff -c -r1.271 help.el
*** help.el     30 Oct 2004 01:07:20 -0000      1.271
--- help.el     27 Nov 2004 00:12:10 -0000
***************
*** 609,625 ****
            (princ "\n   which is ")
            (describe-function-1 defn)
            (when up-event
!             (let ((defn (or (string-key-binding up-event) (key-binding 
up-event))))
                (unless (or (null defn) (integerp defn) (equal defn 'undefined))
!                 (princ "\n\n-------------- up event ---------------\n\n")
!                 (princ (key-description up-event))
                  (if (windowp window)
                      (princ " at that spot"))
                  (princ " runs the command ")
                  (prin1 defn)
                  (princ "\n   which is ")
!                 (describe-function-1 defn))))
!           (print-help-return-message)))))))
  
  
  (defun describe-mode (&optional buffer)
--- 609,666 ----
            (princ "\n   which is ")
            (describe-function-1 defn)
            (when up-event
!             (let ((ev (aref up-event 0))
!                   (descr (key-description up-event))
!                   (hdr "\n\n-------------- up event ---------------\n\n")
!                   defn
!                   mouse-1-tricky mouse-1-remapped)
!               (when (and (consp ev)
!                          (eq (car ev) 'mouse-1)
!                          (windowp window)
!                          mouse-1-click-follows-link
!                          (not (eq mouse-1-click-follows-link 'double))
!                          (with-current-buffer (window-buffer window)
!                            (mouse-on-link-p (posn-point (event-start ev)))))
!                 (setq mouse-1-tricky (integerp mouse-1-click-follows-link)
!                       mouse-1-remapped (or (not mouse-1-tricky)
!                                            (> mouse-1-click-follows-link 0)))
!                 (if mouse-1-remapped
!                     (setcar ev 'mouse-2)))
!               (setq defn (or (string-key-binding up-event) (key-binding 
up-event)))
                (unless (or (null defn) (integerp defn) (equal defn 'undefined))
!                 (princ (if mouse-1-tricky
!                            "\n\n----------------- up-event (short click) 
----------------\n\n"
!                          hdr))
!                 (setq hdr nil)
!                 (princ descr)
                  (if (windowp window)
                      (princ " at that spot"))
+                 (if mouse-1-remapped
+                     (princ " is remapped to <mouse-2>\n  which" ))
                  (princ " runs the command ")
                  (prin1 defn)
                  (princ "\n   which is ")
!                 (describe-function-1 defn))
!               (when mouse-1-tricky
!                 (setcar ev
!                         (if (> mouse-1-click-follows-link 0) 'mouse-1 
'mouse-2))
!                 (setq defn (or (string-key-binding up-event) (key-binding 
up-event)))
!                 (unless (or (null defn) (integerp defn) (equal defn 
'undefined))
!                   (princ (or hdr
!                              "\n\n----------------- up-event (long click) 
----------------\n\n"))
!                   (princ "Pressing ")
!                   (princ descr)
!                   (if (windowp window)
!                       (princ " at that spot"))
!                   (princ (format " for longer than %d milli-seconds\n"
!                                  (abs mouse-1-click-follows-link)))
!                   (if (not mouse-1-remapped)
!                       (princ " remaps it to <mouse-2> which" ))
!                   (princ " runs the command ")
!                   (prin1 defn)
!                   (princ "\n   which is ")
!                   (describe-function-1 defn))))
!           (print-help-return-message))))))))
  
  
  (defun describe-mode (&optional buffer)
***************
*** 692,697 ****
--- 733,739 ----
                (princ "  ")
                (insert-button pretty-minor-mode
                               'action (car help-button-cache)
+                              'follow-link t
                               'help-echo "mouse-2, RET: show full information")
                (princ (format " minor mode (%s):\n"
                               (if indicator
Index: tooltip.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/tooltip.el,v
retrieving revision 1.38
diff -c -r1.38 tooltip.el
*** tooltip.el  25 Nov 2004 02:55:37 -0000      1.38
--- tooltip.el  27 Nov 2004 00:12:10 -0000
***************
*** 476,482 ****
  (defun tooltip-show-help-function (msg)
    "Function installed as `show-help-function'.
  MSG is either a help string to display, or nil to cancel the display."
!   (let ((previous-help tooltip-help-message))
      (setq tooltip-help-message msg)
      (cond ((null msg)
           ;; Cancel display.  This also cancels a delayed tip, if
--- 477,501 ----
  (defun tooltip-show-help-function (msg)
    "Function installed as `show-help-function'.
  MSG is either a help string to display, or nil to cancel the display."
!   (let ((previous-help tooltip-help-message)
!       mp pos)
!     (if (and mouse-1-click-follows-link
!            (stringp msg)
!            (save-match-data
!              (string-match "^mouse-2" msg))
!            (setq mp (mouse-pixel-position))
!            (consp (setq pos (cdr mp)))
!            (setq pos (posn-at-x-y (car pos) (cdr pos) (car mp)))
!            (windowp (posn-window pos)))
!       (with-current-buffer (window-buffer (posn-window pos))
!         (if (mouse-on-link-p (posn-point pos))
!             (setq msg (concat
!                   (cond
!                    ((eq mouse-1-click-follows-link 'double) "double-")
!                    ((and (integerp mouse-1-click-follows-link)
!                          (< mouse-1-click-follows-link 0)) "Long ")
!                    (t ""))
!                   "mouse-1" (substring msg 7))))))
      (setq tooltip-help-message msg)
      (cond ((null msg)
           ;; Cancel display.  This also cancels a delayed tip, if
Index: apropos.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/apropos.el,v
retrieving revision 1.98
diff -c -r1.98 apropos.el
*** apropos.el  27 Oct 2004 17:46:33 -0000      1.98
--- apropos.el  27 Nov 2004 00:03:39 -0000
***************
*** 163,168 ****
--- 163,169 ----
  (define-button-type 'apropos-symbol
    'face apropos-symbol-face
    'help-echo "mouse-2, RET: Display more help on this symbol"
+   'follow-link t
    'action #'apropos-symbol-button-display-help
    'skip t)
  
***************
*** 174,192 ****
  
  (define-button-type 'apropos-function
    'apropos-label "Function"
    'action (lambda (button)
!           (describe-function (button-get button 'apropos-symbol)))
!   'help-echo "mouse-2, RET: Display more help on this function")
  (define-button-type 'apropos-macro
    'apropos-label "Macro"
    'action (lambda (button)
!           (describe-function (button-get button 'apropos-symbol)))
!   'help-echo "mouse-2, RET: Display more help on this macro")
  (define-button-type 'apropos-command
    'apropos-label "Command"
    'action (lambda (button)
!           (describe-function (button-get button 'apropos-symbol)))
!   'help-echo "mouse-2, RET: Display more help on this command")
  
  ;; We used to use `customize-variable-other-window' instead for a
  ;; customizable variable, but that is slow.  It is better to show an
--- 175,198 ----
  
  (define-button-type 'apropos-function
    'apropos-label "Function"
+   'help-echo "mouse-2, RET: Display more help on this function"
+   'follow-link t
    'action (lambda (button)
!           (describe-function (button-get button 'apropos-symbol))))
! 
  (define-button-type 'apropos-macro
    'apropos-label "Macro"
+   'help-echo "mouse-2, RET: Display more help on this macro"
+   'follow-link t
    'action (lambda (button)
!           (describe-function (button-get button 'apropos-symbol))))
! 
  (define-button-type 'apropos-command
    'apropos-label "Command"
+   'help-echo "mouse-2, RET: Display more help on this command"
+   'follow-link t
    'action (lambda (button)
!           (describe-function (button-get button 'apropos-symbol))))
  
  ;; We used to use `customize-variable-other-window' instead for a
  ;; customizable variable, but that is slow.  It is better to show an
***************
*** 196,213 ****
--- 202,222 ----
  (define-button-type 'apropos-variable
    'apropos-label "Variable"
    'help-echo "mouse-2, RET: Display more help on this variable"
+   'follow-link t
    'action (lambda (button)
            (describe-variable (button-get button 'apropos-symbol))))
  
  (define-button-type 'apropos-face
    'apropos-label "Face"
    'help-echo "mouse-2, RET: Display more help on this face"
+   'follow-link t
    'action (lambda (button)
            (describe-face (button-get button 'apropos-symbol))))
  
  (define-button-type 'apropos-group
    'apropos-label "Group"
    'help-echo "mouse-2, RET: Display more help on this group"
+   'follow-link t
    'action (lambda (button)
            (customize-group-other-window
             (button-get button 'apropos-symbol))))
***************
*** 215,226 ****
--- 224,237 ----
  (define-button-type 'apropos-widget
    'apropos-label "Widget"
    'help-echo "mouse-2, RET: Display more help on this widget"
+   'follow-link t
    'action (lambda (button)
            (widget-browse-other-window (button-get button 'apropos-symbol))))
  
  (define-button-type 'apropos-plist
    'apropos-label "Plist"
    'help-echo "mouse-2, RET: Display more help on this plist"
+   'follow-link t
    'action (lambda (button)
            (apropos-describe-plist (button-get button 'apropos-symbol))))
  
Index: help-fns.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/help-fns.el,v
retrieving revision 1.58
diff -c -r1.58 help-fns.el
*** help-fns.el 9 Nov 2004 08:20:44 -0000       1.58
--- help-fns.el 27 Nov 2004 00:03:39 -0000
***************
*** 564,569 ****
--- 564,570 ----
                  (insert " value is shown ")
                  (insert-button "below"
                                 'action help-button-cache
+                                'follow-link t
                                 'help-echo "mouse-2, RET: show value")
                  (insert ".\n\n")))
              ;; Add a note for variables that have been make-var-buffer-local.
Index: help-mode.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/help-mode.el,v
retrieving revision 1.29
diff -c -r1.29 help-mode.el
*** help-mode.el        1 Aug 2004 05:53:50 -0000       1.29
--- help-mode.el        27 Nov 2004 00:03:40 -0000
***************
*** 68,73 ****
--- 68,74 ----
  ;; Button types used by help
  
  (define-button-type 'help-xref
+   'follow-link t
    'action #'help-button-action)
  
  (defun help-button-action (button)
Index: pcvs-defs.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/pcvs-defs.el,v
retrieving revision 1.29
diff -c -r1.29 pcvs-defs.el
*** pcvs-defs.el        15 Oct 2004 23:35:58 -0000      1.29
--- pcvs-defs.el        27 Nov 2004 00:03:40 -0000
***************
*** 380,385 ****
--- 380,387 ----
      ("+" .    cvs-mode-tree)
      ;; mouse bindings
      ([mouse-2] . cvs-mode-find-file)
+     ([follow-link] . (lambda (pos)
+                      (if (eq (get-char-property pos 'face) 
'cvs-filename-face) t)))
      ([(down-mouse-3)] . cvs-menu)
      ;; dired-like bindings
      ("\C-o" .   cvs-mode-display-file)
Index: wid-edit.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/wid-edit.el,v
retrieving revision 1.130
diff -c -r1.130 wid-edit.el
*** wid-edit.el 8 Aug 2004 19:35:15 -0000       1.130
--- wid-edit.el 27 Nov 2004 00:03:40 -0000
***************
*** 327,332 ****
--- 327,333 ----
    (let ((keymap (widget-get widget :keymap))
        (face (or (widget-get widget :value-face) 'widget-field-face))
        (help-echo (widget-get widget :help-echo))
+       (follow-link (widget-get widget :follow-link))
        (rear-sticky
         (or (not widget-field-add-space) (widget-get widget :size))))
      (if (functionp help-echo)
***************
*** 343,348 ****
--- 344,350 ----
        ;; works in the field when, say, Custom uses `suppress-keymap'.
        (overlay-put overlay 'local-map keymap)
        (overlay-put overlay 'face face)
+       (overlay-put overlay 'follow-link follow-link)
        (overlay-put overlay 'help-echo help-echo))
        (setq to (1- to))
        (setq rear-sticky t))
***************
*** 352,357 ****
--- 354,360 ----
        (overlay-put overlay 'field widget)
        (overlay-put overlay 'local-map keymap)
        (overlay-put overlay 'face face)
+       (overlay-put overlay 'follow-link follow-link)
        (overlay-put overlay 'help-echo help-echo)))
    (widget-specify-secret widget))
  
***************
*** 376,381 ****
--- 379,385 ----
  (defun widget-specify-button (widget from to)
    "Specify button for WIDGET between FROM and TO."
    (let ((overlay (make-overlay from to nil t nil))
+       (follow-link (widget-get widget :follow-link))
        (help-echo (widget-get widget :help-echo)))
      (widget-put widget :button-overlay overlay)
      (if (functionp help-echo)
***************
*** 387,392 ****
--- 391,397 ----
      (unless (widget-get widget :suppress-face)
        (overlay-put overlay 'face (widget-apply widget :button-face-get)))
      (overlay-put overlay 'pointer 'hand)
+     (overlay-put overlay 'follow-link follow-link)
      (overlay-put overlay 'help-echo help-echo)))
  
  (defun widget-mouse-help (window overlay point)
***************
*** 1694,1699 ****
--- 1699,1705 ----
    "An embedded link."
    :button-prefix 'widget-link-prefix
    :button-suffix 'widget-link-suffix
+   :follow-link "\C-m"
    :help-echo "Follow the link."
    :format "%[%t%]")
  
Index: gnus/gnus-group.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/gnus/gnus-group.el,v
retrieving revision 1.31
diff -c -r1.31 gnus-group.el
*** gnus/gnus-group.el  29 Oct 2004 02:23:24 -0000      1.31
--- gnus/gnus-group.el  27 Nov 2004 00:03:41 -0000
***************
*** 591,596 ****
--- 591,597 ----
    "\M-e" gnus-group-edit-group-method
    "^" gnus-group-enter-server-mode
    gnus-mouse-2 gnus-mouse-pick-group
+   [follow-link] mouse-face
    "<" beginning-of-buffer
    ">" end-of-buffer
    "\C-c\C-b" gnus-bug
Index: gnus/gnus-sum.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/gnus/gnus-sum.el,v
retrieving revision 1.54
diff -c -r1.54 gnus-sum.el
*** gnus/gnus-sum.el    22 Nov 2004 20:24:59 -0000      1.54
--- gnus/gnus-sum.el    27 Nov 2004 00:03:42 -0000
***************
*** 1703,1708 ****
--- 1703,1709 ----
    "Q" gnus-summary-exit-no-update
    "\C-c\C-i" gnus-info-find-node
    gnus-mouse-2 gnus-mouse-pick-article
+   [follow-link] mouse-face
    "m" gnus-summary-mail-other-window
    "a" gnus-summary-post-news
    "i" gnus-summary-news-other-window

-- 
Kim F. Storm <address@hidden> http://www.cua.dk