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-2013 Free Software Foundation, Inc.
   4
   5 ;; Author: Eric Ding <ericding@alum.mit.edu>
   6 ;; Maintainer: FSF
   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 <http://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 (define-obsolete-function-alias
 225   'goto-address-at-mouse 'goto-address-at-point "22.1")
 226
 227 ;;;###autoload
 228 (defun goto-address-at-point (&optional event)
 229   "Send to the e-mail address or load the URL at point.
 230 Send mail to address at point.  See documentation for
 231 `goto-address-find-address-at-point'.  If no address is found
 232 there, then load the URL at or before point."
 233   (interactive (list last-input-event))
 234   (save-excursion
 235     (if event (posn-set-point (event-end event)))
 236     (let ((address (save-excursion (goto-address-find-address-at-point))))
 237       (if (and address
 238                (save-excursion
 239                  (goto-char (previous-single-char-property-change
 240                              (point) 'goto-address nil
 241                              (line-beginning-position)))
 242                  (not (looking-at goto-address-url-regexp))))
 243           (compose-mail address)
 244         (let ((url (browse-url-url-at-point)))
 245           (if url
 246               (browse-url url)
 247             (error "No e-mail address or URL found")))))))
 248
 249 (defun goto-address-find-address-at-point ()
 250   "Find e-mail address around or before point.
 251 Then search backwards to beginning of line for the start of an e-mail
 252 address.  If no e-mail address found, return nil."
 253   (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim)
 254   (if (or (looking-at goto-address-mail-regexp) ; already at start
 255           (and (re-search-forward goto-address-mail-regexp
 256                                   (line-end-position) 'lim)
 257                (goto-char (match-beginning 0))))
 258       (match-string-no-properties 0)))
 259
 260 ;;;###autoload
 261 (defun goto-address ()
 262   "Sets up goto-address functionality in the current buffer.
 263 Allows user to use mouse/keyboard command to click to go to a URL
 264 or to send e-mail.
 265 By default, goto-address binds `goto-address-at-point' to mouse-2 and C-c RET
 266 only on URLs and e-mail addresses.
 267
 268 Also fontifies the buffer appropriately (see `goto-address-fontify-p' and
 269 `goto-address-highlight-p' for more information)."
 270   (interactive)
 271   (if goto-address-highlight-p
 272       (goto-address-fontify)))
 273 ;;;###autoload(put 'goto-address 'safe-local-eval-function t)
 274
 275 ;;;###autoload
 276 (define-minor-mode goto-address-mode
 277   "Minor mode to buttonize URLs and e-mail addresses in the current buffer.
 278 With a prefix argument ARG, enable the mode if ARG is positive,
 279 and disable it otherwise.  If called from Lisp, enable the mode
 280 if ARG is omitted or nil."
 281   nil
 282   ""
 283   nil
 284   (if goto-address-mode
 285       (jit-lock-register #'goto-address-fontify-region)
 286     (jit-lock-unregister #'goto-address-fontify-region)
 287     (save-restriction
 288       (widen)
 289       (goto-address-unfontify (point-min) (point-max)))))
 290
 291 ;;;###autoload
 292 (define-minor-mode goto-address-prog-mode
 293   "Like `goto-address-mode', but only for comments and strings."
 294   nil
 295   ""
 296   nil
 297   (if goto-address-prog-mode
 298       (jit-lock-register #'goto-address-fontify-region)
 299     (jit-lock-unregister #'goto-address-fontify-region)
 300     (save-restriction
 301       (widen)
 302       (goto-address-unfontify (point-min) (point-max)))))
 303
 304 (provide 'goto-addr)
 305
 306 ;;; goto-addr.el ends here