Commit | Line | Data |
---|---|---|
61b1af82 G |
1 | ;;; gnus-gravatar.el --- Gnus Gravatar support |
2 | ||
3 | ;; Copyright (C) 2010 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: Julien Danjou <julien@danjou.info> | |
6 | ;; Keywords: news | |
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 | ;;; Code: | |
26 | ||
27 | (require 'gravatar) | |
28 | ||
29 | (defgroup gnus-gravatar nil | |
30 | "Gnus Gravatar." | |
31 | :group 'gnus-visual) | |
32 | ||
33 | (defcustom gnus-gravatar-size 32 | |
34 | "How big should gravatars be displayed." | |
35 | :type 'integer | |
229b59da | 36 | :version "24.1" |
61b1af82 G |
37 | :group 'gnus-gravatar) |
38 | ||
229b59da G |
39 | (defcustom gnus-gravatar-properties '(:ascent center :relief 1) |
40 | "List of image properties applied to Gravatar images." | |
41 | :type 'list | |
42 | :version "24.1" | |
61b1af82 G |
43 | :group 'gnus-gravatar) |
44 | ||
45 | (defun gnus-gravatar-transform-address (header category) | |
46 | (gnus-with-article-headers | |
47 | (let ((addresses | |
48 | (mail-header-parse-addresses | |
49 | ;; mail-header-parse-addresses does not work (reliably) on | |
50 | ;; decoded headers. | |
51 | (or | |
52 | (ignore-errors | |
53 | (mail-encode-encoded-word-string | |
54 | (or (mail-fetch-field header) ""))) | |
55 | (mail-fetch-field header))))) | |
e70153eb JD |
56 | (let ((gravatar-size gnus-gravatar-size)) |
57 | (dolist (address addresses) | |
58 | (gravatar-retrieve | |
59 | (car address) | |
60 | 'gnus-gravatar-insert | |
b6fda8fc | 61 | (list header address category))))))) |
61b1af82 G |
62 | |
63 | (defun gnus-gravatar-insert (gravatar header address category) | |
64 | "Insert GRAVATAR for ADDRESS in HEADER in current article buffer. | |
65 | Set image category to CATEGORY." | |
66 | (unless (eq gravatar 'error) | |
67 | (gnus-with-article-headers | |
68 | (gnus-article-goto-header header) | |
69 | (mail-header-narrow-to-field) | |
b6fda8fc JD |
70 | (let ((real-name (cdr address)) |
71 | (mail-address (car address))) | |
72 | (when (if real-name ; have a realname, go for it! | |
73 | (and (search-forward real-name nil t) | |
74 | (search-backward real-name nil t)) | |
75 | (and (search-forward mail-address nil t) | |
76 | (search-backward mail-address nil t))) | |
77 | (goto-char (1- (point))) | |
78 | ;; If we're on the " quoting the name, go backward | |
870409d4 | 79 | (when (looking-at "[\"<]") |
b6fda8fc JD |
80 | (goto-char (1- (point)))) |
81 | ;; Do not do anything if there's already a gravatar. This can | |
82 | ;; happens if the buffer has been regenerated in the mean time, for | |
83 | ;; example we were fetching someaddress, and then we change to | |
84 | ;; another mail with the same someaddress. | |
85 | (unless (memq 'gnus-gravatar (text-properties-at (point))) | |
86 | (let ((inhibit-read-only t) | |
87 | (point (point)) | |
88 | (gravatar (append | |
89 | gravatar | |
229b59da | 90 | gnus-gravatar-properties))) |
b6fda8fc JD |
91 | (gnus-put-image gravatar nil category) |
92 | (put-text-property point (point) 'gnus-gravatar address) | |
93 | (gnus-add-wash-type category) | |
94 | (gnus-add-image category gravatar)))))))) | |
61b1af82 G |
95 | |
96 | ;;;###autoload | |
97 | (defun gnus-treat-from-gravatar () | |
98 | "Display gravatar in the From header. | |
99 | If gravatar is already displayed, remove it." | |
100 | (interactive) | |
101 | (gnus-with-article-buffer | |
102 | (if (memq 'from-gravatar gnus-article-wash-types) | |
103 | (gnus-delete-images 'from-gravatar) | |
104 | (gnus-gravatar-transform-address "from" 'from-gravatar)))) | |
105 | ||
106 | ;;;###autoload | |
107 | (defun gnus-treat-mail-gravatar () | |
108 | "Display gravatars in the Cc and To headers. | |
109 | If gravatars are already displayed, remove them." | |
110 | (interactive) | |
111 | (gnus-with-article-buffer | |
112 | (if (memq 'mail-gravatar gnus-article-wash-types) | |
113 | (gnus-delete-images 'mail-gravatar) | |
114 | (gnus-gravatar-transform-address "cc" 'mail-gravatar) | |
115 | (gnus-gravatar-transform-address "to" 'mail-gravatar)))) | |
116 | ||
117 | (provide 'gnus-gravatar) | |
118 | ||
119 | ;;; gnus-gravatar.el ends here |