goto-addr.el 10.7 KB
Newer Older
Gerd Moellmann's avatar
Gerd Moellmann committed
1 2
;;; goto-addr.el --- click to browse URL or to send to e-mail address

Paul Eggert's avatar
Paul Eggert committed
3
;; Copyright (C) 1995, 2000-2019 Free Software Foundation, Inc.
Gerd Moellmann's avatar
Gerd Moellmann committed
4

Dave Love's avatar
Dave Love committed
5
;; Author: Eric Ding <ericding@alum.mit.edu>
6
;; Maintainer: emacs-devel@gnu.org
Gerd Moellmann's avatar
Gerd Moellmann committed
7 8 9 10 11
;; Created: 15 Aug 1995
;; Keywords: mh-e, www, mouse, mail

;; This file is part of GNU Emacs.

12
;; GNU Emacs is free software: you can redistribute it and/or modify
Gerd Moellmann's avatar
Gerd Moellmann committed
13
;; it under the terms of the GNU General Public License as published by
14 15
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
Gerd Moellmann's avatar
Gerd Moellmann committed
16 17 18 19 20 21 22

;; GNU Emacs is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
23
;; along with GNU Emacs.  If not, see <https://www.gnu.org/licenses/>.
Gerd Moellmann's avatar
Gerd Moellmann committed
24 25 26 27 28 29 30 31 32 33 34 35

;;; Commentary:

;; This package allows you to click or hit a key sequence while on a
;; URL or e-mail address, and either load the URL into a browser of
;; your choice using the browse-url package, or if it's an e-mail
;; address, to send an e-mail to that address.  By default, we bind to
;; the [mouse-2] and the [C-c return] key sequences.

;; INSTALLATION
;;
;; To use goto-address in a particular mode (for example, while
36
;; reading mail in mh-e), add this to your init file:
Gerd Moellmann's avatar
Gerd Moellmann committed
37 38 39
;;
;; (add-hook 'mh-show-mode-hook 'goto-address)
;;
40
;; The mouse click method is bound to [mouse-2] on highlighted URLs or
Gerd Moellmann's avatar
Gerd Moellmann committed
41 42 43 44 45 46
;; e-mail addresses only; it functions normally everywhere else.  To bind
;; another mouse click to the function, add the following to your .emacs
;; (for example):
;;
;; (setq goto-address-highlight-keymap
;;   (let ((m (make-sparse-keymap)))
47
;;     (define-key m [S-mouse-2] 'goto-address-at-point)
Gerd Moellmann's avatar
Gerd Moellmann committed
48 49 50 51 52 53 54 55
;;     m))
;;

;; Known bugs/features:
;; * goto-address-mail-regexp only catches foo@bar.org style addressing,
;;   not stuff like X.400 addresses, etc.
;; * regexp also catches Message-Id line, since it is in the format of
;;   an Internet e-mail address (like Compuserve addresses)
56 57
;; * If the buffer is fontified after goto-address-fontify is run
;;   (say, using font-lock-fontify-buffer), then font-lock faces will
Gerd Moellmann's avatar
Gerd Moellmann committed
58 59 60 61
;;   override goto-address faces.

;;; Code:

Phil Sainty's avatar
Phil Sainty committed
62
(require 'seq)
63 64
(require 'thingatpt)
(autoload 'browse-url-url-at-point "browse-url")
Gerd Moellmann's avatar
Gerd Moellmann committed
65 66 67 68

(defgroup goto-address nil
  "Click to browse URL or to send to e-mail address."
  :group 'mouse
69
  :group 'comm)
Gerd Moellmann's avatar
Gerd Moellmann committed
70 71


72
;; I don't expect users to want fontify'ing without highlighting.
Gerd Moellmann's avatar
Gerd Moellmann committed
73
(defcustom goto-address-fontify-p t
74
  "Non-nil means URLs and e-mail addresses in buffer are fontified.
Gerd Moellmann's avatar
Gerd Moellmann committed
75 76 77 78 79
But only if `goto-address-highlight-p' is also non-nil."
  :type 'boolean
  :group 'goto-address)

(defcustom goto-address-highlight-p t
80
  "Non-nil means URLs and e-mail addresses in buffer are highlighted."
Gerd Moellmann's avatar
Gerd Moellmann committed
81 82 83 84
  :type 'boolean
  :group 'goto-address)

(defcustom goto-address-fontify-maximum-size 30000
85
  "Maximum size of file in which to fontify and/or highlight URLs.
86 87
A value of t means there is no limit--fontify regardless of the size."
  :type '(choice (integer :tag "Maximum size") (const :tag "No limit" t))
Gerd Moellmann's avatar
Gerd Moellmann committed
88 89 90
  :group 'goto-address)

(defvar goto-address-mail-regexp
91
  ;; Actually pretty much any char could appear in the username part.  -stef
92
  "[-a-zA-Z0-9=._+]+@\\([-a-zA-Z0-9_]+\\.\\)+[a-zA-Z0-9]+"
Gerd Moellmann's avatar
Gerd Moellmann committed
93 94
  "A regular expression probably matching an e-mail address.")

Phil Sainty's avatar
Phil Sainty committed
95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116
(defvar goto-address-uri-schemes-ignored
  ;; By default we exclude `mailto:' (email addresses are matched
  ;; by `goto-address-mail-regexp') and also `data:', as it is not
  ;; terribly useful to follow those URIs, and leaving them causes
  ;; `use Data::Dumper;' to be fontified oddly in Perl files.
  '("mailto:" "data:")
  "List of URI schemes to exclude from `goto-address-uri-schemes'.

Customisations to this variable made after goto-addr is loaded
will have no effect.")

(defvar goto-address-uri-schemes
  ;; We use `thing-at-point-uri-schemes', with a few exclusions,
  ;; as listed in `goto-address-uri-schemes-ignored'.
  (seq-reduce (lambda (accum elt) (delete elt accum))
              goto-address-uri-schemes-ignored
              (copy-sequence thing-at-point-uri-schemes))
  "List of URI schemes matched by `goto-address-url-regexp'.

Customisations to this variable made after goto-addr is loaded
will have no effect.")

117
(defvar goto-address-url-regexp
Phil Sainty's avatar
Phil Sainty committed
118 119 120
  (concat "\\<"
          (regexp-opt goto-address-uri-schemes t)
          thing-at-point-url-path-regexp)
Gerd Moellmann's avatar
Gerd Moellmann committed
121 122 123 124
  "A regular expression probably matching a URL.")

(defvar goto-address-highlight-keymap
  (let ((m (make-sparse-keymap)))
125
    (define-key m (kbd "<mouse-2>") 'goto-address-at-point)
126
    (define-key m (kbd "C-c RET") 'goto-address-at-point)
Gerd Moellmann's avatar
Gerd Moellmann committed
127
    m)
128
  "Keymap to hold goto-addr's mouse key defs under highlighted URLs.")
Gerd Moellmann's avatar
Gerd Moellmann committed
129

130
(defcustom goto-address-url-face 'link
131
  "Face to use for URLs."
Gerd Moellmann's avatar
Gerd Moellmann committed
132 133 134 135
  :type 'face
  :group 'goto-address)

(defcustom goto-address-url-mouse-face 'highlight
136
  "Face to use for URLs when the mouse is on them."
Gerd Moellmann's avatar
Gerd Moellmann committed
137 138 139 140
  :type 'face
  :group 'goto-address)

(defcustom goto-address-mail-face 'italic
141
  "Face to use for e-mail addresses."
Gerd Moellmann's avatar
Gerd Moellmann committed
142 143 144 145
  :type 'face
  :group 'goto-address)

(defcustom goto-address-mail-mouse-face 'secondary-selection
146
  "Face to use for e-mail addresses when the mouse is on them."
Gerd Moellmann's avatar
Gerd Moellmann committed
147 148 149
  :type 'face
  :group 'goto-address)

150 151 152 153 154 155
(defun goto-address-unfontify (start end)
  "Remove `goto-address' fontification from the given region."
  (dolist (overlay (overlays-in start end))
    (if (overlay-get overlay 'goto-address)
	(delete-overlay overlay))))

156 157
(defvar goto-address-prog-mode)

158
(defun goto-address-fontify (&optional start end)
159
  "Fontify the URLs and e-mail addresses in the current buffer.
Gerd Moellmann's avatar
Gerd Moellmann committed
160 161
This function implements `goto-address-highlight-p'
and `goto-address-fontify-p'."
162
  ;; Clean up from any previous go.
163
  (goto-address-unfontify (or start (point-min)) (or end (point-max)))
Gerd Moellmann's avatar
Gerd Moellmann committed
164
  (save-excursion
165
    (let ((inhibit-point-motion-hooks t))
166
      (goto-char (or start (point-min)))
167
      (when (or (eq t goto-address-fontify-maximum-size)
168 169 170
		(< (- (or end (point-max)) (point))
                   goto-address-fontify-maximum-size))
	(while (re-search-forward goto-address-url-regexp end t)
171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188 189
	  (let* ((s (match-beginning 0))
		 (e (match-end 0))
		 this-overlay)
	    (when (or (not goto-address-prog-mode)
		      ;; This tests for both comment and string
		      ;; syntax.
		      (nth 8 (syntax-ppss)))
	      (setq this-overlay (make-overlay s e))
	      (and goto-address-fontify-p
		   (overlay-put this-overlay 'face goto-address-url-face))
	      (overlay-put this-overlay 'evaporate t)
	      (overlay-put this-overlay
			   'mouse-face goto-address-url-mouse-face)
	      (overlay-put this-overlay 'follow-link t)
	      (overlay-put this-overlay
			   'help-echo "mouse-2, C-c RET: follow URL")
	      (overlay-put this-overlay
			   'keymap goto-address-highlight-keymap)
	      (overlay-put this-overlay 'goto-address t))))
190 191
	(goto-char (or start (point-min)))
	(while (re-search-forward goto-address-mail-regexp end t)
192 193 194 195 196 197 198 199 200 201 202 203 204 205 206 207 208 209 210 211 212 213 214
	  (let* ((s (match-beginning 0))
		 (e (match-end 0))
		 this-overlay)
	    (when (or (not goto-address-prog-mode)
		      ;; This tests for both comment and string
		      ;; syntax.
		      (nth 8 (syntax-ppss)))
	      (setq this-overlay (make-overlay s e))
	      (and goto-address-fontify-p
		   (overlay-put this-overlay 'face goto-address-mail-face))
	      (overlay-put this-overlay 'evaporate t)
	      (overlay-put this-overlay 'mouse-face
			   goto-address-mail-mouse-face)
	      (overlay-put this-overlay 'follow-link t)
	      (overlay-put this-overlay
			   'help-echo "mouse-2, C-c RET: mail this address")
	      (overlay-put this-overlay
			   'keymap goto-address-highlight-keymap)
	      (overlay-put this-overlay 'goto-address t))))))))

(defun goto-address-fontify-region (start end)
  "Fontify URLs and e-mail addresses in the given region."
  (save-excursion
215 216 217
    (let ((beg-line (progn (goto-char start) (line-beginning-position)))
          (end-line (progn (goto-char end) (line-end-position))))
      (goto-address-fontify beg-line end-line))))
Gerd Moellmann's avatar
Gerd Moellmann committed
218

219 220
;; code to find and goto addresses; much of this has been blatantly
;; snarfed from browse-url.el
Gerd Moellmann's avatar
Gerd Moellmann committed
221 222

;;;###autoload
223
(defun goto-address-at-point (&optional event)
Gerd Moellmann's avatar
Gerd Moellmann committed
224 225 226 227
  "Send to the e-mail address or load the URL at point.
Send mail to address at point.  See documentation for
`goto-address-find-address-at-point'.  If no address is found
there, then load the URL at or before point."
228
  (interactive (list last-input-event))
Gerd Moellmann's avatar
Gerd Moellmann committed
229
  (save-excursion
230
    (if event (posn-set-point (event-end event)))
Gerd Moellmann's avatar
Gerd Moellmann committed
231
    (let ((address (save-excursion (goto-address-find-address-at-point))))
232
      (if (and address
233 234 235 236 237
	       (save-excursion
		 (goto-char (previous-single-char-property-change
			     (point) 'goto-address nil
			     (line-beginning-position)))
		 (not (looking-at goto-address-url-regexp))))
238 239 240 241 242
	  (compose-mail address)
	(let ((url (browse-url-url-at-point)))
	  (if url
	      (browse-url url)
	    (error "No e-mail address or URL found")))))))
Gerd Moellmann's avatar
Gerd Moellmann committed
243 244 245 246

(defun goto-address-find-address-at-point ()
  "Find e-mail address around or before point.
Then search backwards to beginning of line for the start of an e-mail
247
address.  If no e-mail address found, return nil."
248
  (re-search-backward "[^-_A-Za-z0-9.@]" (line-beginning-position) 'lim)
249 250 251 252 253
  (if (or (looking-at goto-address-mail-regexp)	; already at start
	  (and (re-search-forward goto-address-mail-regexp
				  (line-end-position) 'lim)
	       (goto-char (match-beginning 0))))
      (match-string-no-properties 0)))
Gerd Moellmann's avatar
Gerd Moellmann committed
254 255 256 257 258 259

;;;###autoload
(defun goto-address ()
  "Sets up goto-address functionality in the current buffer.
Allows user to use mouse/keyboard command to click to go to a URL
or to send e-mail.
260 261
By default, goto-address binds `goto-address-at-point' to mouse-2 and C-c RET
only on URLs and e-mail addresses.
Gerd Moellmann's avatar
Gerd Moellmann committed
262 263 264 265 266 267

Also fontifies the buffer appropriately (see `goto-address-fontify-p' and
`goto-address-highlight-p' for more information)."
  (interactive)
  (if goto-address-highlight-p
      (goto-address-fontify)))
268
;;;###autoload(put 'goto-address 'safe-local-eval-function t)
Gerd Moellmann's avatar
Gerd Moellmann committed
269

270 271
;;;###autoload
(define-minor-mode goto-address-mode
272
  "Minor mode to buttonize URLs and e-mail addresses in the current buffer."
273 274 275 276 277 278 279 280 281 282 283 284
  nil
  ""
  nil
  (if goto-address-mode
      (jit-lock-register #'goto-address-fontify-region)
    (jit-lock-unregister #'goto-address-fontify-region)
    (save-restriction
      (widen)
      (goto-address-unfontify (point-min) (point-max)))))

;;;###autoload
(define-minor-mode goto-address-prog-mode
Chong Yidong's avatar
Chong Yidong committed
285
  "Like `goto-address-mode', but only for comments and strings."
286 287 288 289 290 291 292 293 294 295
  nil
  ""
  nil
  (if goto-address-prog-mode
      (jit-lock-register #'goto-address-fontify-region)
    (jit-lock-unregister #'goto-address-fontify-region)
    (save-restriction
      (widen)
      (goto-address-unfontify (point-min) (point-max)))))

Gerd Moellmann's avatar
Gerd Moellmann committed
296 297
(provide 'goto-addr)

298
;;; goto-addr.el ends here