lisp/net/goto-addr.el

   1 ;;; goto-addr.el --- click to browse URL or to send to e-mail address
   2
   3 ;; Copyright (C) 1995, 2000-2018 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric Ding <ericding@alum.mit.edu>
   6 ;; Maintainer: emacs-devel@gnu.org
   7 ;; Created: 15 Aug 1995
   8 ;; Keywords: mh-e, www, mouse, mail
   9
  10 ;; This file is part of GNU Emacs.
  11
  12 ;; GNU Emacs is free software: you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation, either version 3 of the License, or
  15 ;; (at your option) any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; 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/>.
  24
  25 ;;; Commentary:
  26
  27 ;; This package allows you to click or hit a key sequence while on a
  28 ;; URL or e-mail address, and either load the URL into a browser of
  29 ;; your choice using the browse-url package, or if it's an e-mail
  30 ;; address, to send an e-mail to that address.  By default, we bind to
  31 ;; the [mouse-2] and the [C-c return] key sequences.
  32
  33 ;; INSTALLATION
  34 ;;
  35 ;; To use goto-address in a particular mode (for example, while
  36 ;; reading mail in mh-e), add this to your init file:
  37 ;;
  38 ;; (add-hook 'mh-show-mode-hook 'goto-address)
  39 ;;
  40 ;; The mouse click method is bound to [mouse-2] on highlighted URLs or
  41 ;; e-mail addresses only; it functions normally everywhere else.  To bind
  42 ;; another mouse click to the function, add the following to your .emacs
  43 ;; (for example):
  44 ;;
  45 ;; (setq goto-address-highlight-keymap
  46 ;;   (let ((m (make-sparse-keymap)))
  47 ;;     (define-key m [S-mouse-2] 'goto-address-at-point)
  48 ;;     m))
  49 ;;
  50
  51 ;; Known bugs/features:
  52 ;; * goto-address-mail-regexp only catches foo@bar.org style addressing,
  53 ;;   not stuff like X.400 addresses, etc.
  54 ;; * regexp also catches Message-Id line, since it is in the format of
  55 ;;   an Internet e-mail address (like Compuserve addresses)
  56 ;; * If the buffer is fontified after goto-address-fontify is run
  57 ;;   (say, using font-lock-fontify-buffer), then font-lock faces will
  58 ;;   override goto-address faces.
  59
  60 ;;; Code:
  61
  62 (require 'thingatpt)
  63 (autoload 'browse-url-url-at-point "browse-url")
  64
  65 ;; XEmacs needs the following definitions.
  66 (unless (fboundp 'overlays-in)
  67   (require 'overlay))
  68 (unless (fboundp 'line-beginning-position)
  69   (defalias 'line-beginning-position 'point-at-bol))
  70 (unless (fboundp 'line-end-position)
  71   (defalias 'line-end-position 'point-at-eol))
  72 (unless (fboundp 'match-string-no-properties)
  73   (defalias 'match-string-no-properties 'match-string))
  74
  75 (defgroup goto-address nil
  76   "Click to browse URL or to send to e-mail address."
  77   :group 'mouse
  78   :group 'comm)
  79
  80
  81 ;; I don't expect users to want fontify'ing without highlighting.
  82 (defcustom goto-address-fontify-p t
  83   "Non-nil means URLs and e-mail addresses in buffer are fontified.
  84 But only if `goto-address-highlight-p' is also non-nil."
  85   :type 'boolean
  86   :group 'goto-address)
  87
  88 (defcustom goto-address-highlight-p t
  89   "Non-nil means URLs and e-mail addresses in buffer are highlighted."
  90   :type 'boolean
  91   :group 'goto-address)
  92
  93 (defcustom goto-address-fontify-maximum-size 30000
  94   "Maximum size of file in which to fontify and/or highlight URLs.
  95 A value of t means there is no limit--fontify regardless of the size."
  96   :type '(choice (integer :tag "Maximum size") (const :tag "No limit" t))
  97   :group 'goto-address)
  98
  99 (defvar goto-address-mail-regexp
 100   ;; Actually pretty much any char could appear in the username part.  -stef
 101   "[-a-zA-Z0-9=._+]+@\\([-a-zA-z0-9_]+\\.\\)+[a-zA-Z0-9]+"
 102   "A regular expression probably matching an e-mail address.")
 103
 104 (defvar goto-address-url-regexp
 105   (concat
 106    "\\<\\("
 107    (mapconcat 'identity
 108               (delete "mailto:"
 109                       ;; Remove `data:', as it's not terribly useful to follow
 110                       ;; those.  Leaving them causes `use Data::Dumper;' to be
 111                       ;; fontified oddly in Perl files.
 112                       (delete "data:"
 113                               (copy-sequence thing-at-point-uri-schemes)))
 114               "\\|")
 115    "\\)"
 116    thing-at-point-url-path-regexp)
 117   ;; (concat "\\b\\(s?https?\\|ftp\\|file\\|gopher\\|news\\|"
 118   ;;      "telnet\\|wais\\):\\(//[-a-zA-Z0-9_.]+:"
 119   ;;      "[0-9]*\\)?[-a-zA-Z0-9_=?#$@~`%&*+|\\/.,]*"
 120   ;;      "[-a-zA-Z0-9_=#$@~`%&*+|\\/]")
 121   "A regular expression probably matching a URL.")
 122
 123 (defvar goto-address-highlight-keymap
 124   (let ((m (make-sparse-keymap)))
 125     (define-key m (if (featurep 'xemacs) (kbd "<button2>") (kbd "<mouse-2>"))
 126       'goto-address-at-point)
 127     (define-key m (kbd "C-c RET") 'goto-address-at-point)
 128     m)
 129   "Keymap to hold goto-addr's mouse key defs under highlighted URLs.")
 130
 131 (defcustom goto-address-url-face 'link
 132   "Face to use for URLs."
 133   :type 'face
 134   :group 'goto-address)
 135
 136 (defcustom goto-address-url-mouse-face 'highlight
 137   "Face to use for URLs when the mouse is on them."
 138   :type 'face
 139   :group 'goto-address)
 140
 141 (defcustom goto-address-mail-face 'italic
 142   "Face to use for e-mail addresses."
 143   :type 'face
 144   :group 'goto-address)
 145
 146 (defcustom goto-address-mail-mouse-face 'secondary-selection
 147   "Face to use for e-mail addresses when the mouse is on them."
 148   :type 'face
 149   :group 'goto-address)
 150
 151 (defun goto-address-unfontify (start end)
 152   "Remove `goto-address' fontification from the given region."
 153   (dolist (overlay (overlays-in start end))
 154     (if (overlay-get overlay 'goto-address)
 155         (delete-overlay overlay))))
 156
 157 (defvar goto-address-prog-mode)
 158
 159 (defun goto-address-fontify (&optional start end)
 160   "Fontify the URLs and e-mail addresses in the current buffer.
 161 This function implements `goto-address-highlight-p'
 162 and `goto-address-fontify-p'."
 163   ;; Clean up from any previous go.
 164   (goto-address-unfontify (or start (point-min)) (or end (point-max)))
 165   (save-excursion
 166     (let ((inhibit-point-motion-hooks t))
 167       (goto-char (or start (point-min)))
 168       (when (or (eq t goto-address-fontify-maximum-size)
 169                 (< (- (or end (point-max)) (point))
 170                    goto-address-fontify-maximum-size))
 171         (while (re-search-forward goto-address-url-regexp end t)
 172           (let* ((s (match-beginning 0))
 173                  (e (match-end 0))
 174                  this-overlay)
 175             (when (or (not goto-address-prog-mode)
 176                       ;; This tests for both comment and string
 177                       ;; syntax.
 178                       (nth 8 (syntax-ppss)))
 179               (setq this-overlay (make-overlay s e))
 180               (and goto-address-fontify-p
 181                    (overlay-put this-overlay 'face goto-address-url-face))
 182               (overlay-put this-overlay 'evaporate t)
 183               (overlay-put this-overlay
 184                            'mouse-face goto-address-url-mouse-face)
 185               (overlay-put this-overlay 'follow-link t)
 186               (overlay-put this-overlay
 187                            'help-echo "mouse-2, C-c RET: follow URL")
 188               (overlay-put this-overlay
 189                            'keymap goto-address-highlight-keymap)
 190               (overlay-put this-overlay 'goto-address t))))
 191         (goto-char (or start (point-min)))
 192         (while (re-search-forward goto-address-mail-regexp end t)
 193           (let* ((s (match-beginning 0))
 194                  (e (match-end 0))
 195                  this-overlay)
 196             (when (or (not goto-address-prog-mode)
 197                       ;; This tests for both comment and string
 198                       ;; syntax.
 199                       (nth 8 (syntax-ppss)))
 200               (setq this-overlay (make-overlay s e))
 201               (and goto-address-fontify-p
 202                    (overlay-put this-overlay 'face goto-address-mail-face))
 203               (overlay-put this-overlay 'evaporate t)
 204               (overlay-put this-overlay 'mouse-face
 205                            goto-address-mail-mouse-face)
 206               (overlay-put this-overlay 'follow-link t)
 207               (overlay-put this-overlay
 208                            'help-echo "mouse-2, C-c RET: mail this address")
 209               (overlay-put this-overlay
 210                            'keymap goto-address-highlight-keymap)
 211               (overlay-put this-overlay 'goto-address t))))))))
 212
 213 (defun goto-address-fontify-region (start end)
 214   "Fontify URLs and e-mail addresses in the given region."
 215   (save-excursion
 216     (let ((beg-line (progn (goto-char start) (line-beginning-position)))
 217           (end-line (progn (goto-char end) (line-end-position))))
 218       (goto-address-fontify beg-line end-line))))
 219
 220 ;; code to find and goto addresses; much of this has been blatantly
 221 ;; snarfed from browse-url.el
 222
 223 ;;;###autoload
 224 (defun goto-address-at-point (&optional event)
 225   "Send to the e-mail address or load the URL at point.
 226 Send mail to address at point.  See documentation for
 227 `goto-address-find-address-at-point'.  If no address is found
 228 there, then load the URL at or before point."
 229   (interactive (list last-input-event))
 230   (save-excursion
 231     (if event (posn-set-point (event-end event)))
 232     (let ((address (save-excursion (goto-address-find-address-at-point))))
 233       (if (and address
 234                (save-excursion
 235                  (goto-char (previous-single-char-property-change
 236                              (point) 'goto-address nil
 237                              (line-beginning-position)))
 238                  (not (looking-at goto-address-url-regexp))))
 239           (compose-mail address)
 240         (let ((url (browse-url-url-at-point)))
 241           (if url
 242               (browse-url url)
 243             (error "No e-mail address or URL found")))))))
 244
 245 (defun goto-address-find-address-at-point ()
 246   "Find e-mail address around or before point.
 247 Then search backwards to beginning of line for the start of an e-mail
 248 address.  If no e-mail address found, return nil."
 249   (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim)
 250   (if (or (looking-at goto-address-mail-regexp) ; already at start
 251           (and (re-search-forward goto-address-mail-regexp
 252                                   (line-end-position) 'lim)
 253                (goto-char (match-beginning 0))))
 254       (match-string-no-properties 0)))
 255
 256 ;;;###autoload
 257 (defun goto-address ()
 258   "Sets up goto-address functionality in the current buffer.
 259 Allows user to use mouse/keyboard command to click to go to a URL
 260 or to send e-mail.
 261 By default, goto-address binds `goto-address-at-point' to mouse-2 and C-c RET
 262 only on URLs and e-mail addresses.
 263
 264 Also fontifies the buffer appropriately (see `goto-address-fontify-p' and
 265 `goto-address-highlight-p' for more information)."
 266   (interactive)
 267   (if goto-address-highlight-p
 268       (goto-address-fontify)))
 269 ;;;###autoload(put 'goto-address 'safe-local-eval-function t)
 270
 271 ;;;###autoload
 272 (define-minor-mode goto-address-mode
 273   "Minor mode to buttonize URLs and e-mail addresses in the current buffer.
 274 With a prefix argument ARG, enable the mode if ARG is positive,
 275 and disable it otherwise.  If called from Lisp, enable the mode
 276 if ARG is omitted or nil."
 277   nil
 278   ""
 279   nil
 280   (if goto-address-mode
 281       (jit-lock-register #'goto-address-fontify-region)
 282     (jit-lock-unregister #'goto-address-fontify-region)
 283     (save-restriction
 284       (widen)
 285       (goto-address-unfontify (point-min) (point-max)))))
 286
 287 ;;;###autoload
 288 (define-minor-mode goto-address-prog-mode
 289   "Like `goto-address-mode', but only for comments and strings."
 290   nil
 291   ""
 292   nil
 293   (if goto-address-prog-mode
 294       (jit-lock-register #'goto-address-fontify-region)
 295     (jit-lock-unregister #'goto-address-fontify-region)
 296     (save-restriction
 297       (widen)
 298       (goto-address-unfontify (point-min) (point-max)))))
 299
 300 (provide 'goto-addr)
 301
 302 ;;; goto-addr.el ends here