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 | ||
fcf2d385 KY |
45 | (defcustom gnus-gravatar-too-ugly (if (boundp 'gnus-article-x-face-too-ugly) |
46 | gnus-article-x-face-too-ugly) | |
47 | "Regexp matching posters whose avatar shouldn't be shown automatically." | |
48 | :type '(choice regexp (const nil)) | |
49 | :version "24.1" | |
50 | :group 'gnus-gravatar) | |
51 | ||
61b1af82 G |
52 | (defun gnus-gravatar-transform-address (header category) |
53 | (gnus-with-article-headers | |
54 | (let ((addresses | |
55 | (mail-header-parse-addresses | |
56 | ;; mail-header-parse-addresses does not work (reliably) on | |
57 | ;; decoded headers. | |
58 | (or | |
59 | (ignore-errors | |
60 | (mail-encode-encoded-word-string | |
61 | (or (mail-fetch-field header) ""))) | |
62 | (mail-fetch-field header))))) | |
e70153eb JD |
63 | (let ((gravatar-size gnus-gravatar-size)) |
64 | (dolist (address addresses) | |
fcf2d385 KY |
65 | (unless (and gnus-gravatar-too-ugly |
66 | (or (string-match gnus-gravatar-too-ugly | |
67 | (car address)) | |
68 | (and (cdr address) | |
69 | (string-match gnus-gravatar-too-ugly | |
70 | (cdr address))))) | |
afba0c4b JD |
71 | (ignore-errors |
72 | (gravatar-retrieve | |
73 | (car address) | |
74 | 'gnus-gravatar-insert | |
75 | (list header address category))))))))) | |
61b1af82 G |
76 | |
77 | (defun gnus-gravatar-insert (gravatar header address category) | |
78 | "Insert GRAVATAR for ADDRESS in HEADER in current article buffer. | |
79 | Set image category to CATEGORY." | |
80 | (unless (eq gravatar 'error) | |
81 | (gnus-with-article-headers | |
82 | (gnus-article-goto-header header) | |
83 | (mail-header-narrow-to-field) | |
b6fda8fc JD |
84 | (let ((real-name (cdr address)) |
85 | (mail-address (car address))) | |
86 | (when (if real-name ; have a realname, go for it! | |
87 | (and (search-forward real-name nil t) | |
88 | (search-backward real-name nil t)) | |
89 | (and (search-forward mail-address nil t) | |
90 | (search-backward mail-address nil t))) | |
91 | (goto-char (1- (point))) | |
92 | ;; If we're on the " quoting the name, go backward | |
870409d4 | 93 | (when (looking-at "[\"<]") |
b6fda8fc JD |
94 | (goto-char (1- (point)))) |
95 | ;; Do not do anything if there's already a gravatar. This can | |
96 | ;; happens if the buffer has been regenerated in the mean time, for | |
97 | ;; example we were fetching someaddress, and then we change to | |
98 | ;; another mail with the same someaddress. | |
99 | (unless (memq 'gnus-gravatar (text-properties-at (point))) | |
100 | (let ((inhibit-read-only t) | |
814cc274 KY |
101 | (point (point))) |
102 | (unless (featurep 'xemacs) | |
103 | (setq gravatar (append gravatar gnus-gravatar-properties))) | |
b6fda8fc JD |
104 | (gnus-put-image gravatar nil category) |
105 | (put-text-property point (point) 'gnus-gravatar address) | |
106 | (gnus-add-wash-type category) | |
107 | (gnus-add-image category gravatar)))))))) | |
61b1af82 G |
108 | |
109 | ;;;###autoload | |
110 | (defun gnus-treat-from-gravatar () | |
111 | "Display gravatar in the From header. | |
112 | If gravatar is already displayed, remove it." | |
113 | (interactive) | |
114 | (gnus-with-article-buffer | |
115 | (if (memq 'from-gravatar gnus-article-wash-types) | |
116 | (gnus-delete-images 'from-gravatar) | |
090f6ea1 KY |
117 | (let ((gnus-gravatar-too-ugly |
118 | (unless buffer-read-only ;; When type `W D g' | |
119 | gnus-gravatar-too-ugly))) | |
120 | (gnus-gravatar-transform-address "from" 'from-gravatar))))) | |
61b1af82 G |
121 | |
122 | ;;;###autoload | |
123 | (defun gnus-treat-mail-gravatar () | |
124 | "Display gravatars in the Cc and To headers. | |
125 | If gravatars are already displayed, remove them." | |
126 | (interactive) | |
127 | (gnus-with-article-buffer | |
128 | (if (memq 'mail-gravatar gnus-article-wash-types) | |
129 | (gnus-delete-images 'mail-gravatar) | |
090f6ea1 KY |
130 | (let ((gnus-gravatar-too-ugly |
131 | (unless buffer-read-only ;; When type `W D h' | |
132 | gnus-gravatar-too-ugly))) | |
133 | (gnus-gravatar-transform-address "cc" 'mail-gravatar) | |
134 | (gnus-gravatar-transform-address "to" 'mail-gravatar))))) | |
61b1af82 G |
135 | |
136 | (provide 'gnus-gravatar) | |
137 | ||
138 | ;;; gnus-gravatar.el ends here |