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