|
88155
|
1 ;;; gnus-picon.el --- displaying pretty icons in Gnus
|
|
|
2
|
|
|
3 ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004,
|
|
|
4 ;; 2005 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.
|
|
|
62 Some 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.
|
|
|
94 List 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.
|
|
|
144 GLYPH 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.
|
|
|
250 If 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.
|
|
|
262 If 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.
|
|
|
275 If 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
|
