unofficial mirror of emacs-devel@gnu.org 
 help / color / mirror / code / Atom feed
* Patch: goto-address minor modes
@ 2008-01-06 16:33 Tom Tromey
  2008-01-07 17:14 ` Richard Stallman
  0 siblings, 1 reply; 16+ messages in thread
From: Tom Tromey @ 2008-01-06 16:33 UTC (permalink / raw)
  To: emacs-devel

I like goto-address, but it can be pretty slow on a very large
ChangeLog.  Recently I saw Stefan's note about glasses mode, and
jit-lock-register... exactly what I needed to fix this.

This patch adds two new minor modes: goto-address-mode and
goto-address-prog-mode (name inspired by flyspell).  These modes use
jit-lock to apply overlays that buttonize URLs and email addresses.
The "prog" mode only adds an overlay when the matched text appears in
a string or comment.

Tom

2008-01-06  Tom Tromey  <tromey@redhat.com>

	* net/goto-addr.el (goto-address-unfontify): New function.
	(goto-address-fontify): Use it.  Respect goto-address-prog-mode.
	(goto-address-fontify-region): New function.
	(goto-address-mode): Likewise.
	(goto-address-prog-mode): Likewise.

Index: lisp/net/goto-addr.el
===================================================================
RCS file: /sources/emacs/emacs/lisp/net/goto-addr.el,v
retrieving revision 1.30
diff -u -r1.30 goto-addr.el
--- lisp/net/goto-addr.el	26 Jul 2007 05:27:18 -0000	1.30
+++ lisp/net/goto-addr.el	6 Jan 2008 16:55:12 -0000
@@ -1,7 +1,7 @@
 ;;; goto-addr.el --- click to browse URL or to send to e-mail address
 
 ;; Copyright (C) 1995, 2000, 2001, 2002, 2003, 2004,
-;;   2005, 2006, 2007 Free Software Foundation, Inc.
+;;   2005, 2006, 2007, 2008 Free Software Foundation, Inc.
 
 ;; Author: Eric Ding <ericding@alum.mit.edu>
 ;; Maintainer: FSF
@@ -151,51 +151,73 @@
   :type 'face
   :group 'goto-address)
 
+(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))))
+
 (defun goto-address-fontify ()
   "Fontify the URLs and e-mail addresses in the current buffer.
 This function implements `goto-address-highlight-p'
 and `goto-address-fontify-p'."
   ;; Clean up from any previous go.
-  (dolist (overlay (overlays-in (point-min) (point-max)))
-    (if (overlay-get overlay 'goto-address)
-	(delete-overlay overlay)))
+  (goto-address-unfontify (point-min) (point-max))
   (save-excursion
     (let ((inhibit-point-motion-hooks t))
       (goto-char (point-min))
-      (if (or (eq t goto-address-fontify-maximum-size)
-	      (< (- (point-max) (point)) goto-address-fontify-maximum-size))
-	  (progn
-	    (while (re-search-forward goto-address-url-regexp nil t)
-              (let* ((s (match-beginning 0))
-                     (e (match-end 0))
-                     (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)))
-	    (goto-char (point-min))
-	    (while (re-search-forward goto-address-mail-regexp nil t)
-              (let* ((s (match-beginning 0))
-                     (e (match-end 0))
-                     (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))))))))
+      (when (or (eq t goto-address-fontify-maximum-size)
+		(< (- (point-max) (point)) goto-address-fontify-maximum-size))
+	(while (re-search-forward goto-address-url-regexp nil t)
+	  (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))))
+	(goto-char (point-min))
+	(while (re-search-forward goto-address-mail-regexp nil t)
+	  (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
+    (save-restriction
+      (let ((beg-line (progn (goto-char start) (line-beginning-position)))
+	    (end-line (progn (goto-char end) (line-end-position))))
+	(narrow-to-region beg-line end-line)
+	(goto-address-fontify)))))
 
 ;; code to find and goto addresses; much of this has been blatantly
 ;; snarfed from browse-url.el
@@ -252,6 +274,32 @@
       (goto-address-fontify)))
 ;;;###autoload(put 'goto-address 'safe-local-eval-function t)
 
+;;;###autoload
+(define-minor-mode goto-address-mode
+  "Minor mode to buttonize URLs and e-mail addresses in the current buffer."
+  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
+  "Turn on `goto-address-mode', but only in comments and strings."
+  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)))))
+
 (provide 'goto-addr)
 
 ;; arch-tag: ca47c505-5661-425d-a471-62bc6e75cf0a

^ permalink raw reply	[flat|nested] 16+ messages in thread

end of thread, other threads:[~2009-01-15  0:25 UTC | newest]

Thread overview: 16+ messages (download: mbox.gz follow: Atom feed
-- links below jump to the message on this page --
2008-01-06 16:33 Patch: goto-address minor modes Tom Tromey
2008-01-07 17:14 ` Richard Stallman
2008-01-07 16:59   ` Tom Tromey
2008-01-08 19:07     ` Richard Stallman
2008-03-22 17:47     ` Reiner Steib
2009-01-14  0:27       ` Juri Linkov
2009-01-14  3:25         ` Chong Yidong
2009-01-14  6:11         ` Dan Nicolaescu
2009-01-14  8:33           ` Lennart Borgman
2009-01-14 10:27             ` Juri Linkov
2009-01-14 15:30             ` Dan Nicolaescu
2009-01-14 20:11               ` Lennart Borgman
2009-01-14 21:21               ` Juri Linkov
2009-01-14 22:01                 ` Stefan Monnier
2009-01-14 23:55                   ` Juri Linkov
2009-01-15  0:25                   ` Lennart Borgman

Code repositories for project(s) associated with this public inbox

	https://git.savannah.gnu.org/cgit/emacs.git

This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).