cgit.sxemacs.org Git - gnus/blob - lisp/gnus-gravatar.el

   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
  36   :group 'gnus-gravatar)
  37
  38 (defcustom gnus-gravatar-relief 1
  39   "If non-nil, adds a shadow rectangle around the image. The
  40 value, relief, specifies the width of the shadow lines, in
  41 pixels. If relief is negative, shadows are drawn so that the
  42 image appears as a pressed button; otherwise, it appears as an
  43 unpressed button."
  44   :group 'gnus-gravatar)
  45
  46 (defun gnus-gravatar-transform-address (header category)
  47   (gnus-with-article-headers
  48     (let ((addresses
  49            (mail-header-parse-addresses
  50             ;; mail-header-parse-addresses does not work (reliably) on
  51             ;; decoded headers.
  52             (or
  53              (ignore-errors
  54                (mail-encode-encoded-word-string
  55                 (or (mail-fetch-field header) "")))
  56              (mail-fetch-field header)))))
  57       (dolist (address addresses)
  58         (gravatar-retrieve
  59          (car address)
  60          'gnus-gravatar-insert
  61          (list header (car address) category))))))
  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)
  70       (when (and (search-forward address nil t)
  71                  (or (search-backward ", " nil t)
  72                      (search-backward ": " nil t)))
  73         (goto-char (1+ (point)))
  74         ;; Do not do anything if there's already a gravatar. This can
  75         ;; happens if the buffer has been regenerated in the mean time, for
  76         ;; example we were fetching someaddress, and then we change to
  77         ;; another mail with the same someaddress.
  78         (unless (memq 'gnus-gravatar (text-properties-at (point)))
  79           (let ((inhibit-read-only t)
  80                 (point (point))
  81                 (gravatar (append
  82                            gravatar
  83                            `(:ascent center :relief ,gnus-gravatar-relief))))
  84             (gnus-put-image gravatar nil category)
  85             (put-text-property point (point) 'gnus-gravatar address)
  86             (gnus-add-wash-type category)
  87             (gnus-add-image category gravatar)))))))
  88
  89 ;;;###autoload
  90 (defun gnus-treat-from-gravatar ()
  91   "Display gravatar in the From header.
  92 If gravatar is already displayed, remove it."
  93   (interactive)
  94   (gnus-with-article-buffer
  95     (if (memq 'from-gravatar gnus-article-wash-types)
  96         (gnus-delete-images 'from-gravatar)
  97       (gnus-gravatar-transform-address "from" 'from-gravatar))))
  98
  99 ;;;###autoload
 100 (defun gnus-treat-mail-gravatar ()
 101   "Display gravatars in the Cc and To headers.
 102 If gravatars are already displayed, remove them."
 103   (interactive)
 104     (gnus-with-article-buffer
 105       (if (memq 'mail-gravatar gnus-article-wash-types)
 106           (gnus-delete-images 'mail-gravatar)
 107         (gnus-gravatar-transform-address "cc" 'mail-gravatar)
 108         (gnus-gravatar-transform-address "to" 'mail-gravatar))))
 109
 110 (provide 'gnus-gravatar)
 111
 112 ;;; gnus-gravatar.el ends here