Import Gnus v5.10.5.

[elisp/gnus.git-] / lisp / gnus-picon.el

diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el
index e273667..9303dc1 100644 (file)
--- a/lisp/gnus-picon.el
+++ b/lisp/gnus-picon.el
@@ -1,9 +1,9 @@
 ;;; gnus-picon.el --- displaying pretty icons in Gnus
 
-;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002
+;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003
 ;;      Free Software Foundation, Inc.
 
-;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
+;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
 ;; Keywords: news xpm annotation glyph faces
 
 ;; This file is part of GNU Emacs.
@@ -35,7 +35,9 @@
 ;;          domain/dom/subdomain/unknown/face.gif
 ;; Groups:  comp.lang.lisp
 ;;          news/comp/lang/lisp/unknown/face.gif
-
+;;
+;; Original implementation by Wes Hardaker <hardaker@ece.ucdavis.edu>.
+;;
 ;;; Code:
 
 (require 'gnus)
@@ -139,7 +141,7 @@ GLYPH can be either a glyph or a string."
       (insert glyph)
     (gnus-add-wash-type category)
     (gnus-add-image category (car glyph))
-    (gnus-put-image (car glyph) (cdr glyph))))
+    (gnus-put-image (car glyph) (cdr glyph) category)))
 
 (defun gnus-picon-create-glyph (file)
   (or (cdr (assoc file gnus-picon-glyph-alist))
@@ -151,7 +153,14 @@ GLYPH can be either a glyph or a string."
 (defun gnus-picon-transform-address (header category)
   (gnus-with-article-headers
     (let ((addresses
-          (mail-header-parse-addresses (mail-fetch-field header)))
+          (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))))
          spec file point cache)
       (dolist (address addresses)
        (setq address (car address))
@@ -168,7 +177,7 @@ GLYPH can be either a glyph or a string."
                                  gnus-picon-user-directories)))
              (setcar spec (cons (gnus-picon-create-glyph file)
                                 (car spec))))
-             
+
            (dotimes (i (1- (length spec)))
              (when (setq file (gnus-picon-find-face
                                (concat "unknown@"
@@ -180,7 +189,7 @@ GLYPH can be either a glyph or a string."
                              (nth (1+ i) spec)))))
            (setq spec (nreverse spec))
            (push (cons address spec) gnus-picon-cache))
-         
+
          (gnus-article-goto-header header)
          (mail-header-narrow-to-field)
          (when (search-forward address nil t)
@@ -227,37 +236,46 @@ GLYPH can be either a glyph or a string."
 
 ;;; Commands:
 
+;; #### NOTE: the test for buffer-read-only is the same as in
+;; article-display-[x-]face. See the comment up there.
+
 ;;;###autoload
 (defun gnus-treat-from-picon ()
   "Display picons in the From header.
 If picons are already displayed, remove them."
   (interactive)
-  (gnus-with-article-buffer
-    (if (memq 'from-picon gnus-article-wash-types)
-       (gnus-delete-images 'from-picon)
-      (gnus-picon-transform-address "from" 'from-picon))))
+  (let ((wash-picon-p buffer-read-only))
+    (gnus-with-article-buffer
+      (if (and wash-picon-p (memq 'from-picon gnus-article-wash-types))
+         (gnus-delete-images 'from-picon)
+       (gnus-picon-transform-address "from" 'from-picon)))
+    ))
 
 ;;;###autoload
 (defun gnus-treat-mail-picon ()
   "Display picons in the Cc and To headers.
 If picons are already displayed, remove them."
   (interactive)
-  (gnus-with-article-buffer
-    (if (memq 'mail-picon gnus-article-wash-types)
-       (gnus-delete-images 'mail-picon)
-      (gnus-picon-transform-address "cc" 'mail-picon)
-      (gnus-picon-transform-address "to" 'mail-picon))))
+  (let ((wash-picon-p buffer-read-only))
+    (gnus-with-article-buffer
+      (if (and wash-picon-p (memq 'mail-picon gnus-article-wash-types))
+         (gnus-delete-images 'mail-picon)
+       (gnus-picon-transform-address "cc" 'mail-picon)
+       (gnus-picon-transform-address "to" 'mail-picon)))
+    ))
 
 ;;;###autoload
 (defun gnus-treat-newsgroups-picon ()
   "Display picons in the Newsgroups and Followup-To headers.
 If picons are already displayed, remove them."
   (interactive)
-  (gnus-with-article-buffer
-    (if (memq 'newsgroups-picon gnus-article-wash-types)
-       (gnus-delete-images 'newsgroups-picon)
-      (gnus-picon-transform-newsgroups "newsgroups")
-      (gnus-picon-transform-newsgroups "followup-to"))))
+  (let ((wash-picon-p buffer-read-only))
+    (gnus-with-article-buffer
+      (if (and wash-picon-p (memq 'newsgroups-picon gnus-article-wash-types))
+         (gnus-delete-images 'newsgroups-picon)
+       (gnus-picon-transform-newsgroups "newsgroups")
+       (gnus-picon-transform-newsgroups "followup-to")))
+    ))
 
 (provide 'gnus-picon)