Commit | Line | Data |
---|---|---|
23f87bed MB |
1 | ;;; gnus-picon.el --- displaying pretty icons in Gnus |
2 | ||
e84b4b86 | 3 | ;; Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, |
114f9c96 | 4 | ;; 2005, 2006, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
23f87bed MB |
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 | ||
5e809f55 | 11 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
23f87bed | 12 | ;; it under the terms of the GNU General Public License as published by |
5e809f55 GM |
13 | ;; the Free Software Foundation, either version 3 of the License, or |
14 | ;; (at your option) any later version. | |
23f87bed MB |
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 | |
5e809f55 | 18 | ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the |
23f87bed MB |
19 | ;; GNU General Public License for more details. |
20 | ||
21 | ;; You should have received a copy of the GNU General Public License | |
5e809f55 | 22 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
23f87bed MB |
23 | |
24 | ;;; Commentary: | |
25 | ||
26 | ;; There are three picon types relevant to Gnus: | |
27 | ;; | |
28 | ;; Persons: person@subdomain.dom | |
29 | ;; users/dom/subdomain/person/face.gif | |
30 | ;; usenix/dom/subdomain/person/face.gif | |
31 | ;; misc/MISC/person/face.gif | |
32 | ;; Domains: subdomain.dom | |
33 | ;; domain/dom/subdomain/unknown/face.gif | |
34 | ;; Groups: comp.lang.lisp | |
35 | ;; news/comp/lang/lisp/unknown/face.gif | |
36 | ;; | |
37 | ;; Original implementation by Wes Hardaker <hardaker@ece.ucdavis.edu>. | |
38 | ;; | |
39 | ;;; Code: | |
40 | ||
b882f02c GM |
41 | ;; For Emacs < 22.2. |
42 | (eval-and-compile | |
43 | (unless (fboundp 'declare-function) (defmacro declare-function (&rest r)))) | |
44 | ||
c1d7d285 MB |
45 | (eval-when-compile (require 'cl)) |
46 | ||
23f87bed | 47 | (require 'gnus) |
23f87bed MB |
48 | (require 'gnus-art) |
49 | ||
50 | ;;; User variables: | |
51 | ||
52 | (defcustom gnus-picon-news-directories '("news") | |
53 | "*List of directories to search for newsgroups faces." | |
54 | :type '(repeat string) | |
55 | :group 'gnus-picon) | |
56 | ||
57 | (defcustom gnus-picon-user-directories '("users" "usenix" "local" "misc") | |
58 | "*List of directories to search for user faces." | |
59 | :type '(repeat string) | |
60 | :group 'gnus-picon) | |
61 | ||
62 | (defcustom gnus-picon-domain-directories '("domains") | |
63 | "*List of directories to search for domain faces. | |
64 | Some people may want to add \"unknown\" to this list." | |
65 | :type '(repeat string) | |
66 | :group 'gnus-picon) | |
67 | ||
68 | (defcustom gnus-picon-file-types | |
69 | (let ((types (list "xbm"))) | |
70 | (when (gnus-image-type-available-p 'gif) | |
71 | (push "gif" types)) | |
72 | (when (gnus-image-type-available-p 'xpm) | |
73 | (push "xpm" types)) | |
74 | types) | |
75 | "*List of suffixes on picon file names to try." | |
76 | :type '(repeat string) | |
77 | :group 'gnus-picon) | |
78 | ||
01c52d31 MB |
79 | (defcustom gnus-picon-style 'inline |
80 | "How should picons be displayed. | |
81 | If `inline', the textual representation is replaced. If `right', picons are | |
82 | added right to the textual representation." | |
83 | ;; FIXME: `right' needs improvement for XEmacs. | |
84 | :type '(choice (const inline) | |
85 | (const right)) | |
86 | :group 'gnus-picon) | |
87 | ||
0f49874b | 88 | (defface gnus-picon-xbm '((t (:foreground "black" :background "white"))) |
23f87bed MB |
89 | "Face to show xbm picon in." |
90 | :group 'gnus-picon) | |
0f49874b MB |
91 | ;; backward-compatibility alias |
92 | (put 'gnus-picon-xbm-face 'face-alias 'gnus-picon-xbm) | |
3d493bef | 93 | (put 'gnus-picon-xbm-face 'obsolete-face "22.1") |
23f87bed | 94 | |
0f49874b | 95 | (defface gnus-picon '((t (:foreground "black" :background "white"))) |
23f87bed MB |
96 | "Face to show picon in." |
97 | :group 'gnus-picon) | |
0f49874b MB |
98 | ;; backward-compatibility alias |
99 | (put 'gnus-picon-face 'face-alias 'gnus-picon) | |
3d493bef | 100 | (put 'gnus-picon-face 'obsolete-face "22.1") |
23f87bed MB |
101 | |
102 | ;;; Internal variables: | |
103 | ||
104 | (defvar gnus-picon-setup-p nil) | |
105 | (defvar gnus-picon-glyph-alist nil | |
106 | "Picon glyphs cache. | |
107 | List of pairs (KEY . GLYPH) where KEY is either a filename or an URL.") | |
108 | (defvar gnus-picon-cache nil) | |
109 | ||
110 | ;;; Functions: | |
111 | ||
112 | (defsubst gnus-picon-split-address (address) | |
113 | (setq address (split-string address "@")) | |
114 | (if (stringp (cadr address)) | |
115 | (cons (car address) (split-string (cadr address) "\\.")) | |
116 | (if (stringp (car address)) | |
117 | (split-string (car address) "\\.")))) | |
118 | ||
119 | (defun gnus-picon-find-face (address directories &optional exact) | |
120 | (let* ((address (gnus-picon-split-address address)) | |
121 | (user (pop address)) | |
122 | (faddress address) | |
123 | database directory result instance base) | |
124 | (catch 'found | |
125 | (dolist (database gnus-picon-databases) | |
126 | (dolist (directory directories) | |
127 | (setq address faddress | |
128 | base (expand-file-name directory database)) | |
129 | (while address | |
130 | (when (setq result (gnus-picon-find-image | |
131 | (concat base "/" (mapconcat 'downcase | |
132 | (reverse address) | |
133 | "/") | |
134 | "/" (downcase user) "/"))) | |
135 | (throw 'found result)) | |
136 | (if exact | |
137 | (setq address nil) | |
138 | (pop address))) | |
139 | ;; Kludge to search MISC as well. But not in "news". | |
140 | (unless (string= directory "news") | |
141 | (when (setq result (gnus-picon-find-image | |
142 | (concat base "/MISC/" user "/"))) | |
143 | (throw 'found result)))))))) | |
144 | ||
145 | (defun gnus-picon-find-image (directory) | |
146 | (let ((types gnus-picon-file-types) | |
147 | found type file) | |
148 | (while (and (not found) | |
149 | (setq type (pop types))) | |
150 | (setq found (file-exists-p (setq file (concat directory "face." type))))) | |
151 | (if found | |
152 | file | |
153 | nil))) | |
154 | ||
01c52d31 | 155 | (defun gnus-picon-insert-glyph (glyph category &optional nostring) |
23f87bed | 156 | "Insert GLYPH into the buffer. |
01c52d31 MB |
157 | GLYPH can be either a glyph or a string. When NOSTRING, no textual |
158 | replacement is added." | |
159 | ;; Using NOSTRING prevents wrong BBDB entries with `gnus-picon-style' set to | |
160 | ;; 'right. | |
23f87bed MB |
161 | (if (stringp glyph) |
162 | (insert glyph) | |
163 | (gnus-add-wash-type category) | |
164 | (gnus-add-image category (car glyph)) | |
01c52d31 | 165 | (gnus-put-image (car glyph) (unless nostring (cdr glyph)) category))) |
23f87bed MB |
166 | |
167 | (defun gnus-picon-create-glyph (file) | |
168 | (or (cdr (assoc file gnus-picon-glyph-alist)) | |
169 | (cdar (push (cons file (gnus-create-image file)) | |
170 | gnus-picon-glyph-alist)))) | |
171 | ||
172 | ;;; Functions that does picon transformations: | |
173 | ||
b882f02c GM |
174 | (declare-function image-size "image.c" (spec &optional pixels frame)) |
175 | ||
23f87bed MB |
176 | (defun gnus-picon-transform-address (header category) |
177 | (gnus-with-article-headers | |
01c52d31 MB |
178 | (let ((addresses |
179 | (mail-header-parse-addresses | |
180 | ;; mail-header-parse-addresses does not work (reliably) on | |
181 | ;; decoded headers. | |
182 | (or | |
183 | (ignore-errors | |
184 | (mail-encode-encoded-word-string | |
185 | (or (mail-fetch-field header) ""))) | |
186 | (mail-fetch-field header)))) | |
187 | spec file point cache len) | |
188 | (dolist (address addresses) | |
189 | (setq address (car address)) | |
190 | (when (and (stringp address) | |
191 | (setq spec (gnus-picon-split-address address))) | |
192 | (if (setq cache (cdr (assoc address gnus-picon-cache))) | |
193 | (setq spec cache) | |
194 | (when (setq file (or (gnus-picon-find-face | |
195 | address gnus-picon-user-directories) | |
196 | (gnus-picon-find-face | |
197 | (concat "unknown@" | |
198 | (mapconcat | |
199 | 'identity (cdr spec) ".")) | |
200 | gnus-picon-user-directories))) | |
201 | (setcar spec (cons (gnus-picon-create-glyph file) | |
202 | (car spec)))) | |
203 | ||
204 | (dotimes (i (1- (length spec))) | |
205 | (when (setq file (gnus-picon-find-face | |
206 | (concat "unknown@" | |
207 | (mapconcat | |
208 | 'identity (nthcdr (1+ i) spec) ".")) | |
209 | gnus-picon-domain-directories t)) | |
210 | (setcar (nthcdr (1+ i) spec) | |
211 | (cons (gnus-picon-create-glyph file) | |
212 | (nth (1+ i) spec))))) | |
213 | (setq spec (nreverse spec)) | |
214 | (push (cons address spec) gnus-picon-cache)) | |
215 | ||
216 | (gnus-article-goto-header header) | |
217 | (mail-header-narrow-to-field) | |
218 | (case gnus-picon-style | |
219 | (right | |
220 | (when (= (length addresses) 1) | |
221 | (setq len (apply '+ (mapcar (lambda (x) | |
222 | (condition-case nil | |
223 | (car (image-size (car x))) | |
224 | (error 0))) spec))) | |
225 | (when (> len 0) | |
226 | (goto-char (point-at-eol)) | |
227 | (insert (propertize | |
228 | " " 'display | |
229 | (cons 'space | |
230 | (list :align-to (- (window-width) 1 len)))))) | |
231 | (goto-char (point-at-eol)) | |
232 | (setq point (point-at-eol)) | |
233 | (dolist (image spec) | |
234 | (unless (stringp image) | |
235 | (goto-char point) | |
236 | (gnus-picon-insert-glyph image category 'nostring))))) | |
237 | (inline | |
238 | (when (search-forward address nil t) | |
239 | (delete-region (match-beginning 0) (match-end 0)) | |
240 | (setq point (point)) | |
241 | (while spec | |
242 | (goto-char point) | |
243 | (if (> (length spec) 2) | |
244 | (insert ".") | |
245 | (if (= (length spec) 2) | |
246 | (insert "@"))) | |
247 | (gnus-picon-insert-glyph (pop spec) category)))))))))) | |
23f87bed MB |
248 | |
249 | (defun gnus-picon-transform-newsgroups (header) | |
250 | (interactive) | |
251 | (gnus-with-article-headers | |
01c52d31 MB |
252 | (gnus-article-goto-header header) |
253 | (mail-header-narrow-to-field) | |
254 | (let ((groups (message-tokenize-header (mail-fetch-field header))) | |
255 | spec file point) | |
256 | (dolist (group groups) | |
257 | (unless (setq spec (cdr (assoc group gnus-picon-cache))) | |
258 | (setq spec (nreverse (split-string group "[.]"))) | |
259 | (dotimes (i (length spec)) | |
260 | (when (setq file (gnus-picon-find-face | |
261 | (concat "unknown@" | |
262 | (mapconcat | |
263 | 'identity (nthcdr i spec) ".")) | |
264 | gnus-picon-news-directories t)) | |
265 | (setcar (nthcdr i spec) | |
266 | (cons (gnus-picon-create-glyph file) | |
267 | (nth i spec))))) | |
268 | (push (cons group spec) gnus-picon-cache)) | |
269 | (when (search-forward group nil t) | |
270 | (delete-region (match-beginning 0) (match-end 0)) | |
271 | (save-restriction | |
272 | (narrow-to-region (point) (point)) | |
273 | (while spec | |
274 | (goto-char (point-min)) | |
275 | (if (> (length spec) 1) | |
276 | (insert ".")) | |
277 | (gnus-picon-insert-glyph (pop spec) 'newsgroups-picon)) | |
278 | (goto-char (point-max)))))))) | |
23f87bed MB |
279 | |
280 | ;;; Commands: | |
281 | ||
282 | ;; #### NOTE: the test for buffer-read-only is the same as in | |
283 | ;; article-display-[x-]face. See the comment up there. | |
284 | ||
285 | ;;;###autoload | |
286 | (defun gnus-treat-from-picon () | |
287 | "Display picons in the From header. | |
288 | If picons are already displayed, remove them." | |
289 | (interactive) | |
290 | (let ((wash-picon-p buffer-read-only)) | |
291 | (gnus-with-article-buffer | |
01c52d31 MB |
292 | (if (and wash-picon-p (memq 'from-picon gnus-article-wash-types)) |
293 | (gnus-delete-images 'from-picon) | |
294 | (gnus-picon-transform-address "from" 'from-picon))))) | |
23f87bed MB |
295 | |
296 | ;;;###autoload | |
297 | (defun gnus-treat-mail-picon () | |
298 | "Display picons in the Cc and To headers. | |
299 | If picons are already displayed, remove them." | |
300 | (interactive) | |
301 | (let ((wash-picon-p buffer-read-only)) | |
302 | (gnus-with-article-buffer | |
01c52d31 MB |
303 | (if (and wash-picon-p (memq 'mail-picon gnus-article-wash-types)) |
304 | (gnus-delete-images 'mail-picon) | |
305 | (gnus-picon-transform-address "cc" 'mail-picon) | |
306 | (gnus-picon-transform-address "to" 'mail-picon))))) | |
23f87bed MB |
307 | |
308 | ;;;###autoload | |
309 | (defun gnus-treat-newsgroups-picon () | |
310 | "Display picons in the Newsgroups and Followup-To headers. | |
311 | If picons are already displayed, remove them." | |
312 | (interactive) | |
313 | (let ((wash-picon-p buffer-read-only)) | |
314 | (gnus-with-article-buffer | |
01c52d31 MB |
315 | (if (and wash-picon-p (memq 'newsgroups-picon gnus-article-wash-types)) |
316 | (gnus-delete-images 'newsgroups-picon) | |
317 | (gnus-picon-transform-newsgroups "newsgroups") | |
318 | (gnus-picon-transform-newsgroups "followup-to"))))) | |
23f87bed MB |
319 | |
320 | (provide 'gnus-picon) | |
321 | ||
23f87bed | 322 | ;;; gnus-picon.el ends here |