Commit | Line | Data |
---|---|---|
61b1af82 G |
1 | ;;; gnus-gravatar.el --- Gnus Gravatar support |
2 | ||
ab422c4d | 3 | ;; Copyright (C) 2010-2013 Free Software Foundation, Inc. |
61b1af82 G |
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) | |
ab67634f | 28 | (require 'gnus-art) |
ed797193 | 29 | (require 'mail-extr) ;; Because of binding `mail-extr-disable-voodoo'. |
61b1af82 G |
30 | |
31 | (defgroup gnus-gravatar nil | |
32 | "Gnus Gravatar." | |
33 | :group 'gnus-visual) | |
34 | ||
ed797193 G |
35 | (defcustom gnus-gravatar-size nil |
36 | "How big should gravatars be displayed. | |
37 | If nil, default to `gravatar-size'." | |
61b1af82 | 38 | :type 'integer |
229b59da | 39 | :version "24.1" |
61b1af82 G |
40 | :group 'gnus-gravatar) |
41 | ||
229b59da G |
42 | (defcustom gnus-gravatar-properties '(:ascent center :relief 1) |
43 | "List of image properties applied to Gravatar images." | |
44 | :type 'list | |
45 | :version "24.1" | |
61b1af82 G |
46 | :group 'gnus-gravatar) |
47 | ||
ab67634f | 48 | (defcustom gnus-gravatar-too-ugly gnus-article-x-face-too-ugly |
fcf2d385 KY |
49 | "Regexp matching posters whose avatar shouldn't be shown automatically." |
50 | :type '(choice regexp (const nil)) | |
51 | :version "24.1" | |
52 | :group 'gnus-gravatar) | |
53 | ||
7417851c | 54 | (defun gnus-gravatar-transform-address (header category &optional force) |
61b1af82 | 55 | (gnus-with-article-headers |
ed797193 | 56 | (let* ((mail-extr-disable-voodoo t) |
ade9369c | 57 | (mail-extr-ignore-realname-equals-mailbox-name nil) |
ed797193 G |
58 | (addresses (mail-extract-address-components |
59 | (or (mail-fetch-field header) "") t)) | |
70041e9a | 60 | (gravatar-size (or gnus-gravatar-size gravatar-size)) |
ed797193 | 61 | name) |
7417851c | 62 | (dolist (address addresses) |
ed797193 G |
63 | (when (and (setq name (car address)) |
64 | (string-match "\\` +" name)) | |
65 | (setcar address (setq name (substring name (match-end 0))))) | |
7417851c KY |
66 | (when (or force |
67 | (not (and gnus-gravatar-too-ugly | |
68 | (or (string-match gnus-gravatar-too-ugly | |
3b84b005 | 69 | (or (cadr address) "")) |
e7424f06 | 70 | (and name |
7417851c KY |
71 | (string-match gnus-gravatar-too-ugly |
72 | name)))))) | |
73 | (ignore-errors | |
74 | (gravatar-retrieve | |
ed797193 | 75 | (cadr address) |
7417851c KY |
76 | 'gnus-gravatar-insert |
77 | (list header address category)))))))) | |
61b1af82 G |
78 | |
79 | (defun gnus-gravatar-insert (gravatar header address category) | |
80 | "Insert GRAVATAR for ADDRESS in HEADER in current article buffer. | |
81 | Set image category to CATEGORY." | |
82 | (unless (eq gravatar 'error) | |
3b0468c4 | 83 | (gnus-with-article-buffer |
cb51ba08 | 84 | (let ((mark (point-marker)) |
cb51ba08 LI |
85 | (inhibit-point-motion-hooks t) |
86 | (case-fold-search t)) | |
87 | (save-restriction | |
88 | (article-narrow-to-head) | |
89 | ;; The buffer can be gone at this time | |
90 | (when (buffer-live-p (current-buffer)) | |
91 | (gnus-article-goto-header header) | |
92 | (mail-header-narrow-to-field) | |
93 | (let ((real-name (car address)) | |
94 | (mail-address (cadr address))) | |
95 | (when (if real-name | |
96 | (re-search-forward | |
97 | (concat (gnus-replace-in-string | |
98 | (regexp-quote real-name) "[\t ]+" "[\t\n ]+") | |
99 | "\\|" | |
100 | (regexp-quote mail-address)) | |
101 | nil t) | |
102 | (search-forward mail-address nil t)) | |
103 | (goto-char (1- (match-beginning 0))) | |
104 | ;; If we're on the " quoting the name, go backward | |
105 | (when (looking-at "[\"<]") | |
106 | (goto-char (1- (point)))) | |
107 | ;; Do not do anything if there's already a gravatar. This can | |
108 | ;; happens if the buffer has been regenerated in the mean time, for | |
109 | ;; example we were fetching someaddress, and then we change to | |
110 | ;; another mail with the same someaddress. | |
111 | (unless (memq 'gnus-gravatar (text-properties-at (point))) | |
112 | (let ((point (point))) | |
113 | (unless (featurep 'xemacs) | |
114 | (setq gravatar (append gravatar gnus-gravatar-properties))) | |
115 | (gnus-put-image gravatar (buffer-substring (point) (1+ point)) category) | |
116 | (put-text-property point (point) 'gnus-gravatar address) | |
117 | (gnus-add-wash-type category) | |
118 | (gnus-add-image category gravatar))))))) | |
119 | (goto-char (marker-position mark)))))) | |
61b1af82 G |
120 | |
121 | ;;;###autoload | |
7417851c | 122 | (defun gnus-treat-from-gravatar (&optional force) |
61b1af82 G |
123 | "Display gravatar in the From header. |
124 | If gravatar is already displayed, remove it." | |
7417851c | 125 | (interactive (list t)) ;; When type `W D g' |
61b1af82 G |
126 | (gnus-with-article-buffer |
127 | (if (memq 'from-gravatar gnus-article-wash-types) | |
7417851c KY |
128 | (gnus-delete-images 'from-gravatar) |
129 | (gnus-gravatar-transform-address "from" 'from-gravatar force)))) | |
61b1af82 G |
130 | |
131 | ;;;###autoload | |
7417851c | 132 | (defun gnus-treat-mail-gravatar (&optional force) |
61b1af82 G |
133 | "Display gravatars in the Cc and To headers. |
134 | If gravatars are already displayed, remove them." | |
7417851c | 135 | (interactive (list t)) ;; When type `W D h' |
61b1af82 G |
136 | (gnus-with-article-buffer |
137 | (if (memq 'mail-gravatar gnus-article-wash-types) | |
138 | (gnus-delete-images 'mail-gravatar) | |
7417851c KY |
139 | (gnus-gravatar-transform-address "cc" 'mail-gravatar force) |
140 | (gnus-gravatar-transform-address "to" 'mail-gravatar force)))) | |
61b1af82 G |
141 | |
142 | (provide 'gnus-gravatar) | |
143 | ||
144 | ;;; gnus-gravatar.el ends here |