1 ;;; gnus-picon.el --- displaying pretty icons in Gnus
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001
4 ;; Free Software Foundation, Inc.
6 ;; Author: Wes Hardaker <hardaker@ece.ucdavis.edu>
7 ;; Keywords: news xpm annotation glyph faces
9 ;; This file is part of GNU Emacs.
11 ;; GNU Emacs is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
28 ;; There are three picon types relevant to Gnus:
30 ;; Persons: person@subdomain.dom
31 ;; users/dom/subdomain/person/face.gif
32 ;; usenix/dom/subdomain/person/face.gif
33 ;; misc/MISC/person/face.gif
34 ;; Domains: subdomain.dom
35 ;; domain/dom/subdomain/unknown/face.gif
36 ;; Groups: comp.lang.lisp
37 ;; news/comp/lang/lisp/unknown/face.gif
49 "Show pictures of people, domains, and newsgroups.
50 For this to work, you must switch on the `gnus-treat-display-picon'
54 (defcustom gnus-picon-databases '("/usr/lib/picon" "/usr/local/faces")
55 "*Defines the location of the faces database.
56 For information on obtaining this database of pretty pictures, please
57 see http://www.cs.indiana.edu/picons/ftp/index.html"
61 (defcustom gnus-picon-news-directories '("news")
62 "*List of directories to search for newsgroups faces."
63 :type '(repeat string)
66 (defcustom gnus-picon-user-directories '("users" "usenix" "local" "misc")
67 "*List of directories to search for user faces."
68 :type '(repeat string)
71 (defcustom gnus-picon-domain-directories '("domains")
72 "*List of directories to search for domain faces.
73 Some people may want to add \"unknown\" to this list."
74 :type '(repeat string)
77 (defcustom gnus-picon-file-types
78 (let ((types (list "xbm")))
79 (when (gnus-image-type-available-p 'gif)
81 (when (gnus-image-type-available-p 'xpm)
84 "*List of suffixes on picon file names to try."
85 :type '(repeat string)
88 (defface gnus-picon-xbm-face '((t (:foreground "black" :background "white")))
89 "Face to show xbm picon in."
92 (defface gnus-picon-face '((t (:foreground "black" :background "white")))
93 "Face to show picon in."
96 ;;; Internal variables:
98 (defvar gnus-picon-setup-p nil)
99 (defvar gnus-picon-glyph-alist nil
101 List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.")
105 (defsubst gnus-picon-split-address (address)
106 (setq address (split-string address "@"))
107 (if (stringp (cadr address))
108 (cons (car address) (split-string (cadr address) "\\."))
109 (if (stringp (car address))
110 (split-string (car address) "\\."))))
112 (defun gnus-picon-find-face (address directories &optional exact)
113 (let* ((databases gnus-picon-databases)
114 (address (gnus-picon-split-address address))
116 database directory found instance base)
117 (while (and (not found)
118 (setq database (pop databases)))
119 (while (and (not found)
120 (setq directory (pop directories)))
121 (setq base (expand-file-name directory database))
122 ;; Kludge to search misc/MISC for users.
123 (when (string= directory "misc")
124 (setq address '("MISC")))
125 (while (and (not found)
127 (setq found (gnus-picon-find-image
128 (concat base "/" (mapconcat 'identity
137 (defun gnus-picon-find-image (directory)
138 (let ((types gnus-picon-file-types)
140 (while (and (not found)
141 (setq type (pop types)))
142 (setq found (file-exists-p (setq file (concat directory "face." type)))))
147 (defun gnus-picon-insert-glyph (glyph)
148 "Insert GLYPH into the buffer.
149 GLYPH can be either a glyph or a string."
152 (gnus-put-image glyph)))
154 (defun gnus-picon-create-glyph (file)
155 (or (cdr (assoc file gnus-picon-glyph-alist))
156 (cdar (push (cons file (gnus-create-image file))
157 gnus-picon-glyph-alist))))
159 ;;; Functions that does picon transformations:
161 (defun gnus-picon-transform-address (header)
163 (gnus-with-article-headers
165 (mail-header-parse-addresses (mail-fetch-field header)))
167 (dolist (address addresses)
168 (setq address (car address)
170 (when (and (stringp address)
171 (setq spec (gnus-picon-split-address address)))
172 (when (setq file (gnus-picon-find-face
173 address gnus-picon-user-directories))
174 (setcar spec (gnus-picon-create-glyph file)))
175 (dotimes (i (1- (length spec)))
176 (when (setq file (gnus-picon-find-face
179 'identity (nthcdr (1+ i) spec) "."))
180 gnus-picon-domain-directories t))
181 (setcar (nthcdr (1+ i) spec) (gnus-picon-create-glyph file))))
183 (gnus-article-goto-header header)
184 (mail-header-narrow-to-field)
185 (when (search-forward address nil t)
186 (delete-region (match-beginning 0) (match-end 0))
188 (gnus-picon-insert-glyph (pop spec))
193 (setq first nil))))))))))
195 (defun gnus-picon-transform-newsgroups (header)
197 (gnus-with-article-headers
200 (message-tokenize-header (mail-fetch-field header))
201 (lambda (g1 g2) (> (length g1) (length g2)))))
203 (dolist (group groups)
204 (setq spec (nreverse (split-string group "[.]")))
205 (dotimes (i (length spec))
206 (when (setq file (gnus-picon-find-face
209 'identity (nthcdr i spec) "."))
210 gnus-picon-news-directories t))
211 (setcar (nthcdr i spec) (gnus-picon-create-glyph file))))
213 (gnus-article-goto-header header)
214 (mail-header-narrow-to-field)
215 (when (search-forward group nil t)
216 (delete-region (match-beginning 0) (match-end 0))
217 (setq spec (nreverse spec))
219 (gnus-picon-insert-glyph (pop spec))
225 (defun gnus-treat-from-picon ()
227 (gnus-picon-transform-address "from"))
229 (defun gnus-treat-mail-picon ()
231 (gnus-picon-transform-address "cc")
232 (gnus-picon-transform-address "to"))
234 (defun gnus-treat-newsgroups-picon ()
236 (gnus-picon-transform-newsgroups "newsgroups")
237 (gnus-picon-transform-newsgroups "followup-to"))
239 (provide 'gnus-picon)
241 ;;; gnus-picon.el ends here