X-Git-Url: http://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-gravatar.el;h=33bcb6b15981444e97be65737d002afe08cd127b;hb=26c3b2dde98792a08f156f68542767c99554c7f0;hp=2444c9e781849e918b7a804ef479b0affb794e0b;hpb=114e900b7dd8c60b81cd723f3c5643181d56c81c;p=gnus

diff --git a/lisp/gnus-gravatar.el b/lisp/gnus-gravatar.el
index 2444c9e78..33bcb6b15 100644
--- a/lisp/gnus-gravatar.el
+++ b/lisp/gnus-gravatar.el
@@ -1,6 +1,6 @@
 ;;; gnus-gravatar.el --- Gnus Gravatar support
 
-;; Copyright (C) 2010 Free Software Foundation, Inc.
+;; Copyright (C) 2010-2013 Free Software Foundation, Inc.
 
 ;; Author: Julien Danjou <julien@danjou.info>
 ;; Keywords: news
@@ -26,20 +26,22 @@
 
 (require 'gravatar)
 (require 'gnus-art)
+(require 'mail-extr) ;; Because of binding `mail-extr-disable-voodoo'.
 
 (defgroup gnus-gravatar nil
   "Gnus Gravatar."
   :group 'gnus-visual)
 
-(defcustom gnus-gravatar-size 32
-  "How big should gravatars be displayed."
-  :type 'integer
+(defcustom gnus-gravatar-size nil
+  "How big should gravatars be displayed.
+If nil, default to `gravatar-size'."
+  :type '(choice (const nil) integer)
   :version "24.1"
   :group 'gnus-gravatar)
 
 (defcustom gnus-gravatar-properties '(:ascent center :relief 1)
   "List of image properties applied to Gravatar images."
-  :type 'list
+  :type 'sexp
   :version "24.1"
   :group 'gnus-gravatar)
 
@@ -51,31 +53,26 @@
 
 (defun gnus-gravatar-transform-address (header category &optional force)
   (gnus-with-article-headers
-    (let ((addresses
-           (mail-header-parse-addresses
-            ;; mail-header-parse-addresses does not work (reliably) on
-            ;; decoded headers.
-            (or
-             (ignore-errors
-               (mail-encode-encoded-word-string
-                (or (mail-fetch-field header) "")))
-             (mail-fetch-field header))))
-	  (gravatar-size gnus-gravatar-size)
-	  name)
+    (let* ((mail-extr-disable-voodoo t)
+           (mail-extr-ignore-realname-equals-mailbox-name nil)
+	   (addresses (mail-extract-address-components
+		       (or (mail-fetch-field header) "") t))
+	   (gravatar-size (or gnus-gravatar-size gravatar-size))
+	   name)
       (dolist (address addresses)
-	(when (and (setq name (cdr address))
-		   (string-match "\\`\\*+ " name)) ;; (X-)Faces exist.
-	  (setcdr address (setq name (substring name (match-end 0)))))
+	(when (and (setq name (car address))
+		   (string-match "\\` +" name))
+	  (setcar address (setq name (substring name (match-end 0)))))
 	(when (or force
 		  (not (and gnus-gravatar-too-ugly
 			    (or (string-match gnus-gravatar-too-ugly
-					      (car address))
+					      (or (cadr address) ""))
 				(and name
 				     (string-match gnus-gravatar-too-ugly
 						   name))))))
 	  (ignore-errors
 	    (gravatar-retrieve
-	     (car address)
+	     (cadr address)
 	     'gnus-gravatar-insert
 	     (list header address category))))))))
 
@@ -83,35 +80,43 @@
   "Insert GRAVATAR for ADDRESS in HEADER in current article buffer.
 Set image category to CATEGORY."
   (unless (eq gravatar 'error)
-    (gnus-with-article-headers
-      ;; The buffer can be gone at this time
-      (when (buffer-live-p (current-buffer))
-        (gnus-article-goto-header header)
-        (mail-header-narrow-to-field)
-        (let ((real-name (cdr address))
-              (mail-address (car address)))
-          (when (if real-name             ; have a realname, go for it!
-                    (and (search-forward real-name nil t)
-                         (search-backward real-name nil t))
-                  (and (search-forward mail-address nil t)
-                       (search-backward mail-address nil t)))
-            (goto-char (1- (point)))
-            ;; If we're on the " quoting the name, go backward
-            (when (looking-at "[\"<]")
-              (goto-char (1- (point))))
-            ;; Do not do anything if there's already a gravatar. This can
-            ;; happens if the buffer has been regenerated in the mean time, for
-            ;; example we were fetching someaddress, and then we change to
-            ;; another mail with the same someaddress.
-            (unless (memq 'gnus-gravatar (text-properties-at (point)))
-              (let ((inhibit-read-only t)
-                    (point (point)))
-                (unless (featurep 'xemacs)
-                  (setq gravatar (append gravatar gnus-gravatar-properties)))
-                (gnus-put-image gravatar nil category)
-                (put-text-property point (point) 'gnus-gravatar address)
-                (gnus-add-wash-type category)
-                (gnus-add-image category gravatar)))))))))
+    (gnus-with-article-buffer
+      (let ((mark (point-marker))
+	    (inhibit-point-motion-hooks t)
+	    (case-fold-search t))
+	(save-restriction
+	  (article-narrow-to-head)
+	  ;; The buffer can be gone at this time
+	  (when (buffer-live-p (current-buffer))
+	    (gnus-article-goto-header header)
+	    (mail-header-narrow-to-field)
+	    (let ((real-name (car address))
+		  (mail-address (cadr address)))
+	      (when (if real-name
+			(re-search-forward
+			 (concat (gnus-replace-in-string
+				  (regexp-quote real-name) "[\t ]+" "[\t\n ]+")
+				 "\\|"
+				 (regexp-quote mail-address))
+			 nil t)
+		      (search-forward mail-address nil t))
+		(goto-char (1- (match-beginning 0)))
+		;; If we're on the " quoting the name, go backward
+		(when (looking-at "[\"<]")
+		  (goto-char (1- (point))))
+		;; Do not do anything if there's already a gravatar. This can
+		;; happens if the buffer has been regenerated in the mean time, for
+		;; example we were fetching someaddress, and then we change to
+		;; another mail with the same someaddress.
+		(unless (memq 'gnus-gravatar (text-properties-at (point)))
+		  (let ((point (point)))
+		    (unless (featurep 'xemacs)
+		      (setq gravatar (append gravatar gnus-gravatar-properties)))
+		    (gnus-put-image gravatar (buffer-substring (point) (1+ point)) category)
+		    (put-text-property point (point) 'gnus-gravatar address)
+		    (gnus-add-wash-type category)
+		    (gnus-add-image category gravatar)))))))
+	(goto-char (marker-position mark))))))
 
 ;;;###autoload
 (defun gnus-treat-from-gravatar (&optional force)