From: storm@cua.dk (Kim F. Storm)
Subject: [PATCH] mouse-1 click follows link
Date: Fri, 29 Oct 2004 15:04:46 +0200 [thread overview]
Message-ID: <m3sm7xhdzl.fsf@kfs-l.imdomain.dk> (raw)
Here is the full patch (without doc updates) for the proposed
mouse-1-click-follows-link functionality, including rewriting of
tooltips and making C-h k aware of the remapping.
Index: mouse.el
===================================================================
RCS file: /cvsroot/emacs/emacs/lisp/mouse.el,v
retrieving revision 1.253
diff -c -r1.253 mouse.el
*** mouse.el 28 Oct 2004 23:33:23 -0000 1.253
--- mouse.el 29 Oct 2004 12:57:49 -0000
***************
*** 48,53 ****
--- 48,77 ----
:type 'boolean
: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 milli-seconds. 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)
+
\f
;; Provide a mode-specific menu on a mouse button.
***************
*** 731,736 ****
--- 755,764 ----
(run-hooks 'mouse-leave-buffer-hook)
(mouse-drag-region-1 start-event))))
+ (defun mouse-on-link-p (pos)
+ (and (get-char-property pos 'mouse-face)
+ (not (get-char-property pos 'dont-follow-link))))
+
(defun mouse-drag-region-1 (start-event)
(mouse-minibuffer-check start-event)
(let* ((echo-keystrokes 0)
***************
*** 746,751 ****
--- 774,780 ----
(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))
***************
*** 755,760 ****
--- 784,796 ----
(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))
***************
*** 877,882 ****
--- 913,938 ----
(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)))))
+ (setcar event 'mouse-2))
(setq unread-command-events
(cons event unread-command-events)))))
(delete-overlay mouse-drag-overlay)))))
*** help.el 25 Oct 2004 14:43:57 +0200 1.270
--- help.el 29 Oct 2004 12:35:18 +0200
***************
*** 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)))))))
\f
(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))))))))
\f
(defun describe-mode (&optional buffer)
*** tooltip.el 01 Sep 2003 17:45:17 +0200 1.34
--- tooltip.el 29 Oct 2004 12:36:23 +0200
***************
*** 480,486 ****
(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
--- 481,505 ----
(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
--
Kim F. Storm <storm@cua.dk> http://www.cua.dk
next reply other threads:[~2004-10-29 13:04 UTC|newest]
Thread overview: 28+ messages / expand[flat|nested] mbox.gz Atom feed top
2004-10-29 13:04 Kim F. Storm [this message]
2004-10-29 23:54 ` [PATCH] mouse-1 click follows link Luc Teirlinck
2004-10-30 22:04 ` Kim F. Storm
2004-10-31 0:09 ` Luc Teirlinck
2004-10-31 12:49 ` Kim F. Storm
2004-11-01 7:24 ` Richard Stallman
2004-10-31 0:34 ` Luc Teirlinck
2004-10-31 12:53 ` Kim F. Storm
2004-10-31 15:24 ` Luc Teirlinck
2004-10-31 18:37 ` David Kastrup
2004-10-31 20:03 ` Luc Teirlinck
2004-10-31 20:13 ` David Kastrup
2004-10-31 21:40 ` Stefan
2004-10-31 23:39 ` Kim F. Storm
2004-11-01 0:33 ` Stefan
2004-11-27 0:44 ` [NEW PATCH] " Kim F. Storm
[not found] ` <E1CYJ5T-0002qS-UR@fencepost.gnu.org>
2004-12-14 15:15 ` Kim F. Storm
2004-12-14 20:13 ` Robert J. Chassell
2004-12-14 23:33 ` Kim F. Storm
2004-12-16 23:08 ` Kevin Rodgers
2004-12-17 9:57 ` Kim F. Storm
2004-12-17 10:20 ` Alex Schroeder
2004-12-15 8:46 ` Richard Stallman
2004-12-16 12:24 ` Richard Stallman
2004-12-16 15:12 ` Kim F. Storm
2004-12-18 0:20 ` Richard Stallman
2004-12-18 13:50 ` Robert J. Chassell
2004-12-17 15:48 ` Kim F. Storm
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://www.gnu.org/software/emacs/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=m3sm7xhdzl.fsf@kfs-l.imdomain.dk \
--to=storm@cua.dk \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/emacs.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).