code.delx.au - gnu-emacs/blob - lisp/progmodes/bug-reference.el

   1 ;; bug-reference.el --- buttonize bug references
   2
   3 ;; Copyright (C) 2008, 2009, 2010, 2011, 2012 Free Software Foundation, Inc.
   4
   5 ;; Author: Tom Tromey <tromey@redhat.com>
   6 ;; Created: 21 Mar 2007
   7 ;; Keywords: tools
   8
   9 ;; This file is part of GNU Emacs.
  10
  11 ;; GNU Emacs is free software: you can redistribute it and/or modify
  12 ;; it under the terms of the GNU General Public License as published by
  13 ;; the Free Software Foundation, either version 3 of the License, or
  14 ;; (at your option) any later version.
  15
  16 ;; GNU Emacs is distributed in the hope that it will be useful,
  17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  19 ;; GNU General Public License for more details.
  20
  21 ;; You should have received a copy of the GNU General Public License
  22 ;; along with GNU Emacs.  If not, see <http://www.gnu.org/licenses/>.
  23
  24 ;;; Commentary:
  25
  26 ;; This file provides minor modes for putting clickable overlays on
  27 ;; references to bugs.  A bug reference is text like "PR foo/29292";
  28 ;; this is mapped to a URL using a user-supplied format.
  29
  30 ;; Two minor modes are provided.  One works on any text in the buffer;
  31 ;; the other operates only on comments and strings.
  32
  33 (defvar bug-reference-map
  34   (let ((map (make-sparse-keymap)))
  35     (define-key map [mouse-2] 'bug-reference-push-button)
  36     (define-key map (kbd "C-c RET") 'bug-reference-push-button)
  37     map)
  38   "Keymap used by bug reference buttons.")
  39
  40 ;; E.g., "http://gcc.gnu.org/PR%s"
  41 (defvar bug-reference-url-format nil
  42   "Format used to turn a bug number into a URL.
  43 The bug number is supplied as a string, so this should have a single %s.
  44 There is no default setting for this, it must be set per file.")
  45
  46 ;;;###autoload
  47 (put 'bug-reference-url-format 'safe-local-variable 'stringp)
  48
  49 (defconst bug-reference-bug-regexp
  50   "\\(?:[Bb]ug ?#\\|PR [a-z-+]+/\\)\\([0-9]+\\)"
  51   "Regular expression which matches bug references.")
  52
  53 (defun bug-reference-set-overlay-properties ()
  54   "Set properties of bug reference overlays."
  55   (put 'bug-reference 'evaporate t)
  56   (put 'bug-reference 'face 'link)
  57   (put 'bug-reference 'mouse-face 'highlight)
  58   (put 'bug-reference 'help-echo "mouse-1, C-c RET: visit this bug")
  59   (put 'bug-reference 'keymap bug-reference-map)
  60   (put 'bug-reference 'follow-link t))
  61
  62 (bug-reference-set-overlay-properties)
  63
  64 (defun bug-reference-unfontify (start end)
  65   "Remove bug reference overlays from region."
  66   (dolist (o (overlays-in start end))
  67     (when (eq (overlay-get o 'category) 'bug-reference)
  68       (delete-overlay o))))
  69
  70 (defvar bug-reference-prog-mode)
  71
  72 (defun bug-reference-fontify (start end)
  73   "Apply bug reference overlays to region."
  74   (save-excursion
  75     (let ((beg-line (progn (goto-char start) (line-beginning-position)))
  76           (end-line (progn (goto-char end) (line-end-position))))
  77       ;; Remove old overlays.
  78       (bug-reference-unfontify beg-line end-line)
  79       (goto-char beg-line)
  80       (while (and (< (point) end-line)
  81                   (re-search-forward bug-reference-bug-regexp end-line 'move))
  82         (when (or (not bug-reference-prog-mode)
  83                   ;; This tests for both comment and string syntax.
  84                   (nth 8 (syntax-ppss)))
  85           (let ((overlay (make-overlay (match-beginning 0) (match-end 0)
  86                                        nil t nil)))
  87             (overlay-put overlay 'category 'bug-reference)
  88             ;; Don't put a link if format is undefined
  89             (when bug-reference-url-format
  90               (overlay-put overlay 'bug-reference-url
  91                            (format bug-reference-url-format
  92                                    (match-string-no-properties 1))))))))))
  93
  94 ;; Taken from button.el.
  95 (defun bug-reference-push-button (&optional pos use-mouse-action)
  96   "Open URL corresponding to the bug reference at POS."
  97   (interactive
  98    (list (if (integerp last-command-event) (point) last-command-event)))
  99   (if (and (not (integerp pos)) (eventp pos))
 100       ;; POS is a mouse event; switch to the proper window/buffer
 101       (let ((posn (event-start pos)))
 102         (with-current-buffer (window-buffer (posn-window posn))
 103           (bug-reference-push-button (posn-point posn) t)))
 104     ;; POS is just normal position.
 105     (dolist (o (overlays-at pos))
 106       ;; It should only be possible to have one URL overlay.
 107       (let ((url (overlay-get o 'bug-reference-url)))
 108         (when url
 109           (browse-url url))))))
 110
 111 ;;;###autoload
 112 (define-minor-mode bug-reference-mode
 113   "Minor mode to buttonize bugzilla references in the current buffer."
 114   nil
 115   ""
 116   nil
 117   (if bug-reference-mode
 118       (jit-lock-register #'bug-reference-fontify)
 119     (jit-lock-unregister #'bug-reference-fontify)
 120     (save-restriction
 121       (widen)
 122       (bug-reference-unfontify (point-min) (point-max)))))
 123
 124 ;;;###autoload
 125 (define-minor-mode bug-reference-prog-mode
 126   "Like `bug-reference-mode', but only buttonize in comments and strings."
 127   nil
 128   ""
 129   nil
 130   (if bug-reference-prog-mode
 131       (jit-lock-register #'bug-reference-fontify)
 132     (jit-lock-unregister #'bug-reference-fontify)
 133     (save-restriction
 134       (widen)
 135       (bug-reference-unfontify (point-min) (point-max)))))
 136
 137 ;; arch-tag: b138abce-e5c3-475e-bd58-7afba40387ea
 138 ;;; bug-reference.el ends here