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       (let ((gravatar-size gnus-gravatar-size))
  58         (dolist (address addresses)
  59           (gravatar-retrieve
  60            (car address)
  61            'gnus-gravatar-insert
  62            (list header (car address) category)))))))
  63
  64 (defun gnus-gravatar-insert (gravatar header address category)
  65   "Insert GRAVATAR for ADDRESS in HEADER in current article buffer.
  66 Set image category to CATEGORY."
  67   (unless (eq gravatar 'error)
  68     (gnus-with-article-headers
  69       (gnus-article-goto-header header)
  70       (mail-header-narrow-to-field)
  71       (when (and (search-forward address nil t)
  72                  (or (search-backward ", " nil t)
  73                      (search-backward ": " nil t)))
  74         (goto-char (1+ (point)))
  75         ;; Do not do anything if there's already a gravatar. This can
  76         ;; happens if the buffer has been regenerated in the mean time, for
  77         ;; example we were fetching someaddress, and then we change to
  78         ;; another mail with the same someaddress.
  79         (unless (memq 'gnus-gravatar (text-properties-at (point)))
  80           (let ((inhibit-read-only t)
  81                 (point (point))
  82                 (gravatar (append
  83                            gravatar
  84                            `(:ascent center :relief ,gnus-gravatar-relief))))
  85             (gnus-put-image gravatar nil category)
  86             (put-text-property point (point) 'gnus-gravatar address)
  87             (gnus-add-wash-type category)
  88             (gnus-add-image category gravatar)))))))
  89
  90 ;;;###autoload
  91 (defun gnus-treat-from-gravatar ()
  92   "Display gravatar in the From header.
  93 If gravatar is already displayed, remove it."
  94   (interactive)
  95   (gnus-with-article-buffer
  96     (if (memq 'from-gravatar gnus-article-wash-types)
  97         (gnus-delete-images 'from-gravatar)
  98       (gnus-gravatar-transform-address "from" 'from-gravatar))))
  99
 100 ;;;###autoload
 101 (defun gnus-treat-mail-gravatar ()
 102   "Display gravatars in the Cc and To headers.
 103 If gravatars are already displayed, remove them."
 104   (interactive)
 105     (gnus-with-article-buffer
 106       (if (memq 'mail-gravatar gnus-article-wash-types)
 107           (gnus-delete-images 'mail-gravatar)
 108         (gnus-gravatar-transform-address "cc" 'mail-gravatar)
 109         (gnus-gravatar-transform-address "to" 'mail-gravatar))))
 110
 111 (provide 'gnus-gravatar)
 112
 113 ;;; gnus-gravatar.el ends here