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 (defun gnus-picon-find-user (address directories &optional exact)
106 (let* ((databases gnus-picon-databases)
107 (address (split-string address "[.@]"))
109 database directory found instance base)
110 (while (and (not found)
111 (setq database (pop databases)))
112 (while (and (not found)
113 (setq directory (pop directories)))
114 (setq base (expand-file-name directory database))
115 (while (and (not found)
117 (setq found (gnus-picon-find-image
118 (concat base "/" (mapconcat 'identity
127 (defun gnus-picon-find-image (directory)
128 (let ((types gnus-picon-file-types)
130 (while (and (not found)
131 (setq type (pop types)))
132 (setq found (file-exists-p (setq file (concat directory "face." type)))))
137 (defun gnus-treat-from-picon ()
139 (gnus-with-article-headers
141 (car (mail-header-parse-address (mail-fetch-field "from"))))
145 (setq spec (split-string address "[.@]"))
146 (when (setq file (gnus-picon-find-user
147 address gnus-picon-user-directories))
148 (setcar spec (gnus-picon-find-glyph file)))
149 (dotimes (i (1- (length spec)))
150 (when (setq file (gnus-picon-find-user
153 'identity (nthcdr (1+ i) spec) "."))
154 gnus-picon-domain-directories t))
155 (setcar (nthcdr (1+ i) spec) (gnus-picon-find-glyph file))))
157 (gnus-article-goto-header "from")
158 (mail-header-narrow-to-field)
159 (when (search-forward address nil t)
160 (delete-region (match-beginning 0) (match-end 0))
162 (gnus-picon-insert-glyph (pop spec))
167 (setq first nil)))))))))
169 (defun gnus-picon-insert-glyph (glyph)
170 "Insert GLYPH into the buffer.
171 GLYPH can be either a glyph or a string."
174 (gnus-put-image glyph)))
176 (defun gnus-picon-find-glyph (file)
177 (gnus-create-image file))
179 (provide 'gnus-picon)
181 ;;; gnus-picon.el ends here