X-Git-Url: http://git.chise.org/gitweb/?a=blobdiff_plain;f=lisp%2Fgnus-picon.el;h=408b76f94a6680b2609bf003cc93cd50d34b86dd;hb=8047583c8c86a5c6a61bddc27b391042e39e1ce5;hp=ae2d10788594117e26666fbebe1fea0110d704b2;hpb=49d38b41c190eaab2cb34294fac7302a9c9ea353;p=elisp%2Fgnus.git- diff --git a/lisp/gnus-picon.el b/lisp/gnus-picon.el index ae2d107..408b76f 100644 --- 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, 2004 ;; Free Software Foundation, Inc. -;; Author: Wes Hardaker +;; Author: Lars Magne Ingebrigtsen ;; Keywords: news xpm annotation glyph faces ;; This file is part of GNU Emacs. @@ -35,13 +35,14 @@ ;; domain/dom/subdomain/unknown/face.gif ;; Groups: comp.lang.lisp ;; news/comp/lang/lisp/unknown/face.gif - +;; +;; Original implementation by Wes Hardaker . +;; ;;; Code: (eval-when-compile (require 'cl)) (require 'gnus) -(require 'custom) (require 'gnus-art) ;;; User variables: @@ -73,6 +74,15 @@ Some people may want to add \"unknown\" to this list." :type '(repeat string) :group 'gnus-picon) +(defcustom gnus-picon-style 'inline + "How should picons be displayed. +If `inline', the textual representation is replaced. If `right', picons are +added right to the textual representation." + ;; FIXME: `right' needs improvement for XEmacs. + :type '(choice (const inline) + (const right)) + :group 'gnus-picon) + (defface gnus-picon-xbm-face '((t (:foreground "black" :background "white"))) "Face to show xbm picon in." :group 'gnus-picon) @@ -134,14 +144,17 @@ List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.") file nil))) -(defun gnus-picon-insert-glyph (glyph category) +(defun gnus-picon-insert-glyph (glyph category &optional nostring) "Insert GLYPH into the buffer. -GLYPH can be either a glyph or a string." +GLYPH can be either a glyph or a string. When NOSTRING, no textual +replacement is added." + ;; Using NOSTRING prevents wrong BBDB entries with `gnus-picon-style' set to + ;; 'right. (if (stringp glyph) (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) (unless nostring (cdr glyph)) category))) (defun gnus-picon-create-glyph (file) (or (cdr (assoc file gnus-picon-glyph-alist)) @@ -152,114 +165,147 @@ 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))) - spec file point cache) - (dolist (address addresses) - (setq address (car address)) - (when (and (stringp address) - (setq spec (gnus-picon-split-address address))) - (if (setq cache (cdr (assoc address gnus-picon-cache))) - (setq spec cache) - (when (setq file (or (gnus-picon-find-face - address gnus-picon-user-directories) - (gnus-picon-find-face - (concat "unknown@" - (mapconcat - 'identity (cdr spec) ".")) - 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@" - (mapconcat - 'identity (nthcdr (1+ i) spec) ".")) - gnus-picon-domain-directories t)) - (setcar (nthcdr (1+ i) spec) - (cons (gnus-picon-create-glyph file) - (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) - (delete-region (match-beginning 0) (match-end 0)) - (setq point (point)) - (while spec - (goto-char point) - (if (> (length spec) 2) - (insert ".") - (if (= (length spec) 2) - (insert "@"))) - (gnus-picon-insert-glyph (pop spec) category)))))))) + (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)))) + spec file point cache len) + (dolist (address addresses) + (setq address (car address)) + (when (and (stringp address) + (setq spec (gnus-picon-split-address address))) + (if (setq cache (cdr (assoc address gnus-picon-cache))) + (setq spec cache) + (when (setq file (or (gnus-picon-find-face + address gnus-picon-user-directories) + (gnus-picon-find-face + (concat "unknown@" + (mapconcat + 'identity (cdr spec) ".")) + 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@" + (mapconcat + 'identity (nthcdr (1+ i) spec) ".")) + gnus-picon-domain-directories t)) + (setcar (nthcdr (1+ i) spec) + (cons (gnus-picon-create-glyph file) + (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) + (case gnus-picon-style + (right + (when (= (length addresses) 1) + (setq len (apply '+ (mapcar (lambda (x) + (condition-case nil + (car (image-size (car x))) + (error 0))) spec))) + (when (> len 0) + (goto-char (point-at-eol)) + (insert (propertize + " " 'display + (cons 'space + (list :align-to (- (window-width) 1 len)))))) + (goto-char (point-at-eol)) + (setq point (point-at-eol)) + (dolist (image spec) + (unless (stringp image) + (goto-char point) + (gnus-picon-insert-glyph image category 'nostring))))) + (inline + (when (search-forward address nil t) + (delete-region (match-beginning 0) (match-end 0)) + (setq point (point)) + (while spec + (goto-char point) + (if (> (length spec) 2) + (insert ".") + (if (= (length spec) 2) + (insert "@"))) + (gnus-picon-insert-glyph (pop spec) category)))))))))) (defun gnus-picon-transform-newsgroups (header) (interactive) (gnus-with-article-headers - (gnus-article-goto-header header) - (mail-header-narrow-to-field) - (let ((groups (message-tokenize-header (mail-fetch-field header))) - spec file point) - (dolist (group groups) - (unless (setq spec (cdr (assoc group gnus-picon-cache))) - (setq spec (nreverse (split-string group "[.]"))) - (dotimes (i (length spec)) - (when (setq file (gnus-picon-find-face - (concat "unknown@" - (mapconcat - 'identity (nthcdr i spec) ".")) - gnus-picon-news-directories t)) - (setcar (nthcdr i spec) - (cons (gnus-picon-create-glyph file) - (nth i spec))))) - (push (cons group spec) gnus-picon-cache)) - (when (search-forward group nil t) - (delete-region (match-beginning 0) (match-end 0)) - (save-restriction - (narrow-to-region (point) (point)) - (while spec - (goto-char (point-min)) - (if (> (length spec) 1) - (insert ".")) - (gnus-picon-insert-glyph (pop spec) 'newsgroups-picon)) - (goto-char (point-max)))))))) + (gnus-article-goto-header header) + (mail-header-narrow-to-field) + (let ((groups (message-tokenize-header (mail-fetch-field header))) + spec file point) + (dolist (group groups) + (unless (setq spec (cdr (assoc group gnus-picon-cache))) + (setq spec (nreverse (split-string group "[.]"))) + (dotimes (i (length spec)) + (when (setq file (gnus-picon-find-face + (concat "unknown@" + (mapconcat + 'identity (nthcdr i spec) ".")) + gnus-picon-news-directories t)) + (setcar (nthcdr i spec) + (cons (gnus-picon-create-glyph file) + (nth i spec))))) + (push (cons group spec) gnus-picon-cache)) + (when (search-forward group nil t) + (delete-region (match-beginning 0) (match-end 0)) + (save-restriction + (narrow-to-region (point) (point)) + (while spec + (goto-char (point-min)) + (if (> (length spec) 1) + (insert ".")) + (gnus-picon-insert-glyph (pop spec) 'newsgroups-picon)) + (goto-char (point-max)))))))) ;;; 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)