code.delx.au - gnu-emacs/blob - 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 ()
 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 (point-min) (point-max))
 165   (save-excursion
 166     (let ((inhibit-point-motion-hooks t))
 167       (goto-char (point-min))
 168       (when (or (eq t goto-address-fontify-maximum-size)
 169                 (< (- (point-max) (point)) goto-address-fontify-maximum-size))
 170         (while (re-search-forward goto-address-url-regexp nil t)
 171           (let* ((s (match-beginning 0))
 172                  (e (match-end 0))
 173                  this-overlay)
 174             (when (or (not goto-address-prog-mode)
 175                       ;; This tests for both comment and string
 176                       ;; syntax.
 177                       (nth 8 (syntax-ppss)))
 178               (setq this-overlay (make-overlay s e))
 179               (and goto-address-fontify-p
 180                    (overlay-put this-overlay 'face goto-address-url-face))
 181               (overlay-put this-overlay 'evaporate t)
 182               (overlay-put this-overlay
 183                            'mouse-face goto-address-url-mouse-face)
 184               (overlay-put this-overlay 'follow-link t)
 185               (overlay-put this-overlay
 186                            'help-echo "mouse-2, C-c RET: follow URL")
 187               (overlay-put this-overlay
 188                            'keymap goto-address-highlight-keymap)
 189               (overlay-put this-overlay 'goto-address t))))
 190         (goto-char (point-min))
 191         (while (re-search-forward goto-address-mail-regexp nil t)
 192           (let* ((s (match-beginning 0))
 193                  (e (match-end 0))
 194                  this-overlay)
 195             (when (or (not goto-address-prog-mode)
 196                       ;; This tests for both comment and string
 197                       ;; syntax.
 198                       (nth 8 (syntax-ppss)))
 199               (setq this-overlay (make-overlay s e))
 200               (and goto-address-fontify-p
 201                    (overlay-put this-overlay 'face goto-address-mail-face))
 202               (overlay-put this-overlay 'evaporate t)
 203               (overlay-put this-overlay 'mouse-face
 204                            goto-address-mail-mouse-face)
 205               (overlay-put this-overlay 'follow-link t)
 206               (overlay-put this-overlay
 207                            'help-echo "mouse-2, C-c RET: mail this address")
 208               (overlay-put this-overlay
 209                            'keymap goto-address-highlight-keymap)
 210               (overlay-put this-overlay 'goto-address t))))))))
 211
 212 (defun goto-address-fontify-region (start end)
 213   "Fontify URLs and e-mail addresses in the given region."
 214   (save-excursion
 215     (save-restriction
 216       (let ((beg-line (progn (goto-char start) (line-beginning-position)))
 217             (end-line (progn (goto-char end) (line-end-position))))
 218         (narrow-to-region beg-line end-line)
 219         (goto-address-fontify)))))
 220
 221 ;; code to find and goto addresses; much of this has been blatantly
 222 ;; snarfed from browse-url.el
 223
 224 ;;;###autoload
 225 (define-obsolete-function-alias
 226   'goto-address-at-mouse 'goto-address-at-point "22.1")
 227
 228 ;;;###autoload
 229 (defun goto-address-at-point (&optional event)
 230   "Send to the e-mail address or load the URL at point.
 231 Send mail to address at point.  See documentation for
 232 `goto-address-find-address-at-point'.  If no address is found
 233 there, then load the URL at or before point."
 234   (interactive (list last-input-event))
 235   (save-excursion
 236     (if event (posn-set-point (event-end event)))
 237     (let ((address (save-excursion (goto-address-find-address-at-point))))
 238       (if (and address
 239                (save-excursion
 240                  (goto-char (previous-single-char-property-change
 241                              (point) 'goto-address nil
 242                              (line-beginning-position)))
 243                  (not (looking-at goto-address-url-regexp))))
 244           (compose-mail address)
 245         (let ((url (browse-url-url-at-point)))
 246           (if url
 247               (browse-url url)
 248             (error "No e-mail address or URL found")))))))
 249
 250 (defun goto-address-find-address-at-point ()
 251   "Find e-mail address around or before point.
 252 Then search backwards to beginning of line for the start of an e-mail
 253 address.  If no e-mail address found, return nil."
 254   (re-search-backward "[^-_A-z0-9.@]" (line-beginning-position) 'lim)
 255   (if (or (looking-at goto-address-mail-regexp) ; already at start
 256           (and (re-search-forward goto-address-mail-regexp
 257                                   (line-end-position) 'lim)
 258                (goto-char (match-beginning 0))))
 259       (match-string-no-properties 0)))
 260
 261 ;;;###autoload
 262 (defun goto-address ()
 263   "Sets up goto-address functionality in the current buffer.
 264 Allows user to use mouse/keyboard command to click to go to a URL
 265 or to send e-mail.
 266 By default, goto-address binds `goto-address-at-point' to mouse-2 and C-c RET
 267 only on URLs and e-mail addresses.
 268
 269 Also fontifies the buffer appropriately (see `goto-address-fontify-p' and
 270 `goto-address-highlight-p' for more information)."
 271   (interactive)
 272   (if goto-address-highlight-p
 273       (goto-address-fontify)))
 274 ;;;###autoload(put 'goto-address 'safe-local-eval-function t)
 275
 276 ;;;###autoload
 277 (define-minor-mode goto-address-mode
 278   "Minor mode to buttonize URLs and e-mail addresses in the current buffer.
 279 With a prefix argument ARG, enable the mode if ARG is positive,
 280 and disable it otherwise.  If called from Lisp, enable the mode
 281 if ARG is omitted or nil."
 282   nil
 283   ""
 284   nil
 285   (if goto-address-mode
 286       (jit-lock-register #'goto-address-fontify-region)
 287     (jit-lock-unregister #'goto-address-fontify-region)
 288     (save-restriction
 289       (widen)
 290       (goto-address-unfontify (point-min) (point-max)))))
 291
 292 ;;;###autoload
 293 (define-minor-mode goto-address-prog-mode
 294   "Like `goto-address-mode', but only for comments and strings."
 295   nil
 296   ""
 297   nil
 298   (if goto-address-prog-mode
 299       (jit-lock-register #'goto-address-fontify-region)
 300     (jit-lock-unregister #'goto-address-fontify-region)
 301     (save-restriction
 302       (widen)
 303       (goto-address-unfontify (point-min) (point-max)))))
 304
 305 (provide 'goto-addr)
 306
 307 ;;; goto-addr.el ends here