(require 'gnus)
(require 'custom)
(require 'gnus-art)
-(require 'gnus-win)
;;; User variables:
(defgroup picon nil
- "Show pictures of people, domains, and newsgroups.
-For this to work, you must switch on the `gnus-treat-display-picon'
-variable."
+ "Show pictures of people, domains, and newsgroups."
:group 'gnus-visual)
(defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces")
:type '(repeat string)
:group 'picon)
-(defcustom gnus-picon-user-directories '("users" "usenix" "local" "misc")
+(defcustom gnus-picon-user-directories '("users" "usenix" "local"
+ "misc" "unknown")
"*List of directories to search for user faces."
:type '(repeat string)
:group 'picon)
(defsubst gnus-picon-split-address (address)
(setq address (split-string address "@"))
- (if (cdr address)
- (cons (car address) (split-string (nth 1 address) "\\."))
- (split-string (car address) "\\.")))
+ (if (stringp (cadr address))
+ (cons (car address) (split-string (cadr address) "\\."))
+ (if (stringp (car address))
+ (split-string (car address) "\\."))))
(defun gnus-picon-find-face (address directories &optional exact)
- (let* ((databases gnus-picon-databases)
- (address (gnus-picon-split-address address))
+ (let* ((address (gnus-picon-split-address address))
(user (pop address))
- database directory found instance base)
- (while (and (not found)
- (setq database (pop databases)))
- (while (and (not found)
- (setq directory (pop directories)))
- (setq base (expand-file-name directory database))
- ;; Kludge to search misc/MISC for users.
- (when (string= directory "misc")
- (setq address '("MISC")))
- (while (and (not found)
- address)
- (setq found (gnus-picon-find-image
- (concat base "/" (mapconcat 'identity
- (reverse address)
- "/")
- "/" user "/")))
- (if exact
- (setq address nil)
- (pop address)))))
- found))
+ (faddress address)
+ database directory result instance base)
+ (catch 'found
+ (dolist (database gnus-picon-databases)
+ (dolist (directory directories)
+ (setq address faddress
+ base (expand-file-name directory database))
+ (while address
+ (when (setq result (gnus-picon-find-image
+ (concat base "/" (mapconcat 'identity
+ (reverse address)
+ "/")
+ "/" user "/")))
+ (throw 'found result))
+ (if exact
+ (setq address nil)
+ (pop address)))
+ ;; Kludge to search MISC as well.
+ (when (setq result (gnus-picon-find-image
+ (concat base "/MISC/" user "/")))
+ (throw 'found result)))))))
(defun gnus-picon-find-image (directory)
(let ((types gnus-picon-file-types)
file
nil)))
-(defun gnus-picon-insert-glyph (glyph)
+(defun gnus-picon-insert-glyph (glyph category)
"Insert GLYPH into the buffer.
GLYPH can be either a glyph or a string."
(if (stringp glyph)
(insert glyph)
- (gnus-put-image glyph)))
+ (gnus-add-wash-type category)
+ (gnus-add-image category (car glyph))
+ (gnus-put-image (car glyph) (cdr glyph))))
(defun gnus-picon-create-glyph (file)
(or (cdr (assoc file gnus-picon-glyph-alist))
;;; Functions that does picon transformations:
-(defun gnus-picon-transform-address (header)
- (interactive)
+(defun gnus-picon-transform-address (header category)
(gnus-with-article-headers
(let ((addresses
(mail-header-parse-addresses (mail-fetch-field header)))
(dolist (address addresses)
(setq address (car address)
first t)
- (when (stringp address)
- (setq spec (gnus-picon-split-address address))
- (when (setq file (gnus-picon-find-face
- address gnus-picon-user-directories))
- (setcar spec (gnus-picon-create-glyph file)))
+ (when (and (stringp address)
+ (setq spec (gnus-picon-split-address address)))
+ (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) (gnus-picon-create-glyph file))))
+ (setcar (nthcdr (1+ i) spec)
+ (cons (gnus-picon-create-glyph file)
+ (nth (1+ i) spec)))))
(gnus-article-goto-header header)
(mail-header-narrow-to-field)
(when (search-forward address nil t)
(delete-region (match-beginning 0) (match-end 0))
(while spec
- (gnus-picon-insert-glyph (pop spec))
+ (gnus-picon-insert-glyph (pop spec) category)
(when spec
(if (not first)
(insert ".")
(mapconcat
'identity (nthcdr i spec) "."))
gnus-picon-news-directories t))
- (setcar (nthcdr i spec) (gnus-picon-create-glyph file))))
+ (setcar (nthcdr i spec)
+ (cons (gnus-picon-create-glyph file)
+ (nth i spec)))))
(gnus-article-goto-header header)
(mail-header-narrow-to-field)
(delete-region (match-beginning 0) (match-end 0))
(setq spec (nreverse spec))
(while spec
- (gnus-picon-insert-glyph (pop spec))
+ (gnus-picon-insert-glyph (pop spec) 'newsgroups-picon)
(when spec
(insert "."))))))))
;;; Commands:
+;;;###autoload
(defun gnus-treat-from-picon ()
+ "Display picons in the From header.
+If picons are already displayed, remove them."
(interactive)
- (gnus-picon-transform-address "from"))
+ (gnus-with-article-buffer
+ (if (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-picon-transform-address "cc")
- (gnus-picon-transform-address "to"))
+ (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))))
+;;;###autoload
(defun gnus-treat-newsgroups-picon ()
+ "Display picons in the Newsgroups and Followup-To headers.
+If picons are already displayed, remove them."
(interactive)
- (gnus-picon-transform-newsgroups "newsgroups")
- (gnus-picon-transform-newsgroups "followup-to"))
+ (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"))))
(provide 'gnus-picon)
projects / gnus / blobdiff