1;;; gnus-picon.el --- displaying pretty icons in Gnus
2
3;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
4;;   2005, 2006, 2007 Free Software Foundation, Inc.
5
6;; Author: Lars Magne Ingebrigtsen <larsi@gnus.org>
7;; Keywords: news xpm annotation glyph faces
8
9;; This file is part of GNU Emacs.
10
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)
14;; any later version.
15
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.
20
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., 51 Franklin Street, Fifth Floor,
24;; Boston, MA 02110-1301, USA.
25
26;;; Commentary:
27
28;; There are three picon types relevant to Gnus:
29;;
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
38;;
39;; Original implementation by Wes Hardaker <hardaker@ece.ucdavis.edu>.
40;;
41;;; Code:
42
43(eval-when-compile (require 'cl))
44
45(require 'gnus)
46(require 'gnus-art)
47
48;;; User variables:
49
50(defcustom gnus-picon-news-directories '("news")
51  "*List of directories to search for newsgroups faces."
52  :type '(repeat string)
53  :group 'gnus-picon)
54
55(defcustom gnus-picon-user-directories '("users" "usenix" "local" "misc")
56  "*List of directories to search for user faces."
57  :type '(repeat string)
58  :group 'gnus-picon)
59
60(defcustom gnus-picon-domain-directories '("domains")
61  "*List of directories to search for domain faces.
62Some people may want to add \"unknown\" to this list."
63  :type '(repeat string)
64  :group 'gnus-picon)
65
66(defcustom gnus-picon-file-types
67  (let ((types (list "xbm")))
68    (when (gnus-image-type-available-p 'gif)
69      (push "gif" types))
70    (when (gnus-image-type-available-p 'xpm)
71      (push "xpm" types))
72    types)
73  "*List of suffixes on picon file names to try."
74  :type '(repeat string)
75  :group 'gnus-picon)
76
77(defface gnus-picon-xbm '((t (:foreground "black" :background "white")))
78  "Face to show xbm picon in."
79  :group 'gnus-picon)
80;; backward-compatibility alias
81(put 'gnus-picon-xbm-face 'face-alias 'gnus-picon-xbm)
82
83(defface gnus-picon '((t (:foreground "black" :background "white")))
84  "Face to show picon in."
85  :group 'gnus-picon)
86;; backward-compatibility alias
87(put 'gnus-picon-face 'face-alias 'gnus-picon)
88
89;;; Internal variables:
90
91(defvar gnus-picon-setup-p nil)
92(defvar gnus-picon-glyph-alist nil
93  "Picon glyphs cache.
94List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.")
95(defvar gnus-picon-cache nil)
96
97;;; Functions:
98
99(defsubst gnus-picon-split-address (address)
100  (setq address (split-string address "@"))
101  (if (stringp (cadr address))
102      (cons (car address) (split-string (cadr address) "\\."))
103    (if (stringp (car address))
104	(split-string (car address) "\\."))))
105
106(defun gnus-picon-find-face (address directories &optional exact)
107  (let* ((address (gnus-picon-split-address address))
108	 (user (pop address))
109	 (faddress address)
110	 database directory result instance base)
111    (catch 'found
112      (dolist (database gnus-picon-databases)
113	(dolist (directory directories)
114	  (setq address faddress
115		base (expand-file-name directory database))
116	  (while address
117	    (when (setq result (gnus-picon-find-image
118				(concat base "/" (mapconcat 'downcase
119							    (reverse address)
120							    "/")
121					"/" (downcase user) "/")))
122	      (throw 'found result))
123	    (if exact
124		(setq address nil)
125	      (pop address)))
126	  ;; Kludge to search MISC as well.  But not in "news".
127	  (unless (string= directory "news")
128	    (when (setq result (gnus-picon-find-image
129				(concat base "/MISC/" user "/")))
130	      (throw 'found result))))))))
131
132(defun gnus-picon-find-image (directory)
133  (let ((types gnus-picon-file-types)
134	found type file)
135    (while (and (not found)
136		(setq type (pop types)))
137      (setq found (file-exists-p (setq file (concat directory "face." type)))))
138    (if found
139	file
140      nil)))
141
142(defun gnus-picon-insert-glyph (glyph category)
143  "Insert GLYPH into the buffer.
144GLYPH can be either a glyph or a string."
145  (if (stringp glyph)
146      (insert glyph)
147    (gnus-add-wash-type category)
148    (gnus-add-image category (car glyph))
149    (gnus-put-image (car glyph) (cdr glyph) category)))
150
151(defun gnus-picon-create-glyph (file)
152  (or (cdr (assoc file gnus-picon-glyph-alist))
153      (cdar (push (cons file (gnus-create-image file))
154		  gnus-picon-glyph-alist))))
155
156;;; Functions that does picon transformations:
157
158(defun gnus-picon-transform-address (header category)
159  (gnus-with-article-headers
160    (let ((addresses
161	   (mail-header-parse-addresses
162	    ;; mail-header-parse-addresses does not work (reliably) on
163	    ;; decoded headers.
164	    (or
165	     (ignore-errors
166	       (mail-encode-encoded-word-string
167		(or (mail-fetch-field header) "")))
168	     (mail-fetch-field header))))
169	  spec file point cache)
170      (dolist (address addresses)
171	(setq address (car address))
172	(when (and (stringp address)
173		   (setq spec (gnus-picon-split-address address)))
174	  (if (setq cache (cdr (assoc address gnus-picon-cache)))
175	      (setq spec cache)
176	    (when (setq file (or (gnus-picon-find-face
177				  address gnus-picon-user-directories)
178				 (gnus-picon-find-face
179				  (concat "unknown@"
180					  (mapconcat
181					   'identity (cdr spec) "."))
182				  gnus-picon-user-directories)))
183	      (setcar spec (cons (gnus-picon-create-glyph file)
184				 (car spec))))
185
186	    (dotimes (i (1- (length spec)))
187	      (when (setq file (gnus-picon-find-face
188				(concat "unknown@"
189					(mapconcat
190					 'identity (nthcdr (1+ i) spec) "."))
191				gnus-picon-domain-directories t))
192		(setcar (nthcdr (1+ i) spec)
193			(cons (gnus-picon-create-glyph file)
194			      (nth (1+ i) spec)))))
195	    (setq spec (nreverse spec))
196	    (push (cons address spec) gnus-picon-cache))
197
198	  (gnus-article-goto-header header)
199	  (mail-header-narrow-to-field)
200	  (when (search-forward address nil t)
201	    (delete-region (match-beginning 0) (match-end 0))
202	    (setq point (point))
203	    (while spec
204	      (goto-char point)
205	      (if (> (length spec) 2)
206		  (insert ".")
207		(if (= (length spec) 2)
208		  (insert "@")))
209	      (gnus-picon-insert-glyph (pop spec) category))))))))
210
211(defun gnus-picon-transform-newsgroups (header)
212  (interactive)
213  (gnus-with-article-headers
214    (gnus-article-goto-header header)
215    (mail-header-narrow-to-field)
216    (let ((groups (message-tokenize-header (mail-fetch-field header)))
217	  spec file point)
218      (dolist (group groups)
219	(unless (setq spec (cdr (assoc group gnus-picon-cache)))
220	  (setq spec (nreverse (split-string group "[.]")))
221	  (dotimes (i (length spec))
222	    (when (setq file (gnus-picon-find-face
223			      (concat "unknown@"
224				      (mapconcat
225				       'identity (nthcdr i spec) "."))
226			      gnus-picon-news-directories t))
227	      (setcar (nthcdr i spec)
228		      (cons (gnus-picon-create-glyph file)
229			    (nth i spec)))))
230	    (push (cons group spec) gnus-picon-cache))
231	(when (search-forward group nil t)
232	  (delete-region (match-beginning 0) (match-end 0))
233	  (save-restriction
234	    (narrow-to-region (point) (point))
235	    (while spec
236	      (goto-char (point-min))
237	      (if (> (length spec) 1)
238		  (insert "."))
239	      (gnus-picon-insert-glyph (pop spec) 'newsgroups-picon))
240	    (goto-char (point-max))))))))
241
242;;; Commands:
243
244;; #### NOTE: the test for buffer-read-only is the same as in
245;; article-display-[x-]face. See the comment up there.
246
247;;;###autoload
248(defun gnus-treat-from-picon ()
249  "Display picons in the From header.
250If picons are already displayed, remove them."
251  (interactive)
252  (let ((wash-picon-p buffer-read-only))
253    (gnus-with-article-buffer
254      (if (and wash-picon-p (memq 'from-picon gnus-article-wash-types))
255	  (gnus-delete-images 'from-picon)
256	(gnus-picon-transform-address "from" 'from-picon)))
257    ))
258
259;;;###autoload
260(defun gnus-treat-mail-picon ()
261  "Display picons in the Cc and To headers.
262If picons are already displayed, remove them."
263  (interactive)
264  (let ((wash-picon-p buffer-read-only))
265    (gnus-with-article-buffer
266      (if (and wash-picon-p (memq 'mail-picon gnus-article-wash-types))
267	  (gnus-delete-images 'mail-picon)
268	(gnus-picon-transform-address "cc" 'mail-picon)
269	(gnus-picon-transform-address "to" 'mail-picon)))
270    ))
271
272;;;###autoload
273(defun gnus-treat-newsgroups-picon ()
274  "Display picons in the Newsgroups and Followup-To headers.
275If picons are already displayed, remove them."
276  (interactive)
277  (let ((wash-picon-p buffer-read-only))
278    (gnus-with-article-buffer
279      (if (and wash-picon-p (memq 'newsgroups-picon gnus-article-wash-types))
280	  (gnus-delete-images 'newsgroups-picon)
281	(gnus-picon-transform-newsgroups "newsgroups")
282	(gnus-picon-transform-newsgroups "followup-to")))
283    ))
284
285(provide 'gnus-picon)
286
287;;; arch-tag: fe9aede0-1b1b-463a-b4ab-807f98bcb31f
288;;; gnus-picon.el ends here
289