From: Julien Danjou Date: Fri, 24 Sep 2010 16:35:44 +0000 (+0200) Subject: Add Gravatar support X-Git-Url: https://cgit.sxemacs.org/?a=commitdiff_plain;h=e0fa5bdbb734014fe95f2902cbd9a86bbbe4e5c7;p=gnus Add Gravatar support Signed-off-by: Julien Danjou --- diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 0ae68ff43..a3d97aa24 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,3 +1,13 @@ +2010-09-24 Julien Danjou + + * gnus-sum.el: Add support for Gravatars. + + * gnus-art.el: Add support for Gravatars. + + * gnus-gravatar.el: Add this file. + + * gravatar.el: Add this file. + 2010-09-24 Lars Magne Ingebrigtsen * gnus-sum.el (gnus-summary-fetch-faq): Removed. diff --git a/lisp/gnus-art.el b/lisp/gnus-art.el index d92d29d62..231f9e90e 100644 --- a/lisp/gnus-art.el +++ b/lisp/gnus-art.el @@ -1529,10 +1529,40 @@ node `(gnus)Picons' for details." :type gnus-article-treat-head-custom) (put 'gnus-treat-newsgroups-picon 'highlight t) +(defcustom gnus-treat-from-gravatar + (when (display-images-p) 'head) + "Display gravatars in the From header. +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles' and Info +node `(gnus)Gravatars' for details." + :version "24.1" + :group 'gnus-article-treat + :group 'gnus-gravatar + :link '(custom-manual "(gnus)Customizing Articles") + :link '(custom-manual "(gnus)Gravatars") + :type gnus-article-treat-head-custom) +(put 'gnus-treat-from-gravatar 'highlight t) + +(defcustom gnus-treat-mail-gravatar + (when (display-images-p) 'head) + "Display gravatars in To and Cc headers. +Valid values are nil, t, `head', `first', `last', an integer or a +predicate. See Info node `(gnus)Customizing Articles' and Info +node `(gnus)Gravatars' for details." + :version "24.1" + :group 'gnus-article-treat + :group 'gnus-gravatar + :link '(custom-manual "(gnus)Customizing Articles") + :link '(custom-manual "(gnus)Gravatars") + :type gnus-article-treat-head-custom) +(put 'gnus-treat-mail-gravatar 'highlight t) + (defcustom gnus-treat-body-boundary (if (or gnus-treat-newsgroups-picon gnus-treat-mail-picon - gnus-treat-from-picon) + gnus-treat-from-picon + gnus-treat-from-gravatar + gnus-treat-mail-gravatar) ;; If there's much decoration, the user might prefer a boundery. 'head nil) @@ -1669,6 +1699,8 @@ This requires GNU Libidn, and by default only enabled if it is found." (gnus-treat-from-picon gnus-treat-from-picon) (gnus-treat-mail-picon gnus-treat-mail-picon) (gnus-treat-newsgroups-picon gnus-treat-newsgroups-picon) + (gnus-treat-from-gravatar gnus-treat-from-gravatar) + (gnus-treat-mail-gravatar gnus-treat-mail-gravatar) (gnus-treat-highlight-headers gnus-article-highlight-headers) (gnus-treat-highlight-signature gnus-article-highlight-signature) (gnus-treat-strip-trailing-blank-lines diff --git a/lisp/gnus-gravatar.el b/lisp/gnus-gravatar.el new file mode 100644 index 000000000..6b97a5484 --- /dev/null +++ b/lisp/gnus-gravatar.el @@ -0,0 +1,112 @@ +;;; gnus-gravatar.el --- Gnus Gravatar support + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Julien Danjou +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'gravatar) + +(defgroup gnus-gravatar nil + "Gnus Gravatar." + :group 'gnus-visual) + +(defcustom gnus-gravatar-size 32 + "How big should gravatars be displayed." + :type 'integer + :group 'gnus-gravatar) + +(defcustom gnus-gravatar-relief 1 + "If non-nil, adds a shadow rectangle around the image. The +value, relief, specifies the width of the shadow lines, in +pixels. If relief is negative, shadows are drawn so that the +image appears as a pressed button; otherwise, it appears as an +unpressed button." + :group 'gnus-gravatar) + +(defun gnus-gravatar-transform-address (header category) + (gnus-with-article-headers + (let ((addresses + (mail-header-parse-addresses + ;; mail-header-parse-addresses does not work (reliably) on + ;; decoded headers. + (or + (ignore-errors + (mail-encode-encoded-word-string + (or (mail-fetch-field header) ""))) + (mail-fetch-field header))))) + (dolist (address addresses) + (gravatar-retrieve + (car address) + 'gnus-gravatar-insert + (list header (car address) category)))))) + +(defun gnus-gravatar-insert (gravatar header address category) + "Insert GRAVATAR for ADDRESS in HEADER in current article buffer. +Set image category to CATEGORY." + (unless (eq gravatar 'error) + (gnus-with-article-headers + (gnus-article-goto-header header) + (mail-header-narrow-to-field) + (when (and (search-forward address nil t) + (or (search-backward ", " nil t) + (search-backward ": " nil t))) + (goto-char (1+ (point))) + ;; Do not do anything if there's already a gravatar. This can + ;; happens if the buffer has been regenerated in the mean time, for + ;; example we were fetching someaddress, and then we change to + ;; another mail with the same someaddress. + (unless (memq 'gnus-gravatar (text-properties-at (point))) + (let ((inhibit-read-only t) + (point (point)) + (gravatar (append + gravatar + `(:ascent center :relief ,gnus-gravatar-relief)))) + (gnus-put-image gravatar nil category) + (put-text-property point (point) 'gnus-gravatar address) + (gnus-add-wash-type category) + (gnus-add-image category gravatar))))))) + +;;;###autoload +(defun gnus-treat-from-gravatar () + "Display gravatar in the From header. +If gravatar is already displayed, remove it." + (interactive) + (gnus-with-article-buffer + (if (memq 'from-gravatar gnus-article-wash-types) + (gnus-delete-images 'from-gravatar) + (gnus-gravatar-transform-address "from" 'from-gravatar)))) + +;;;###autoload +(defun gnus-treat-mail-gravatar () + "Display gravatars in the Cc and To headers. +If gravatars are already displayed, remove them." + (interactive) + (gnus-with-article-buffer + (if (memq 'mail-gravatar gnus-article-wash-types) + (gnus-delete-images 'mail-gravatar) + (gnus-gravatar-transform-address "cc" 'mail-gravatar) + (gnus-gravatar-transform-address "to" 'mail-gravatar)))) + +(provide 'gnus-gravatar) + +;;; gnus-gravatar.el ends here diff --git a/lisp/gnus-sum.el b/lisp/gnus-sum.el index 796fca91c..f019731d8 100644 --- a/lisp/gnus-sum.el +++ b/lisp/gnus-sum.el @@ -2124,7 +2124,9 @@ increase the score of each group you read." "W" gnus-html-show-images "f" gnus-treat-from-picon "m" gnus-treat-mail-picon - "n" gnus-treat-newsgroups-picon) + "n" gnus-treat-newsgroups-picon + "g" gnus-treat-from-gravatar + "h" gnus-treat-mail-gravatar) (gnus-define-keys (gnus-summary-wash-mime-map "M" gnus-summary-wash-map) "w" gnus-article-decode-mime-words @@ -2372,6 +2374,8 @@ increase the score of each group you read." ["Show picons in From" gnus-treat-from-picon t] ["Show picons in mail headers" gnus-treat-mail-picon t] ["Show picons in news headers" gnus-treat-newsgroups-picon t] + ["Show Gravatars in From" gnus-treat-from-gravatar t] + ["Show Gravatars in mail headers" gnus-treat-mail-gravatar t] ("View as different encoding" ,@(gnus-summary-menu-split (mapcar diff --git a/lisp/gravatar.el b/lisp/gravatar.el new file mode 100644 index 000000000..ec03b1b8a --- /dev/null +++ b/lisp/gravatar.el @@ -0,0 +1,123 @@ +;;; gravatar.el --- Get Gravatars + +;; Copyright (C) 2010 Free Software Foundation, Inc. + +;; Author: Julien Danjou +;; Keywords: news + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'image) +(require 'url) +(require 'url-cache) + +(defgroup gravatar nil + "Gravatar." + :group 'comm) + +(defcustom gravatar-automatic-caching t + "Whether cache retrieved gravatar." + :group 'gravatar) + +(defcustom gravatar-cache-ttl (days-to-time 30) + "Time to live for gravatar cache entries." + :group 'gravatar) + +(defcustom gravatar-rating "g" + "Default rating for gravatar." + :group 'gravatar) + +(defcustom gravatar-size 32 + "Default size in pixels for gravatars." + :group 'gravatar) + +(defconst gravatar-base-url + "http://www.gravatar.com/avatar" + "Base URL for getting gravatars.") + +(defun gravatar-hash (mail-address) + "Create an hash from MAIL-ADDRESS." + (md5 (downcase mail-address))) + +(defun gravatar-build-url (mail-address) + "Return an URL to retrieve MAIL-ADDRESS gravatar." + (format "%s/%s?d=404&r=%s&s=%d" + gravatar-base-url + (gravatar-hash mail-address) + gravatar-rating + gravatar-size)) + +(defun gravatar-cache-expired (url) + "Check if URL is cached for more than `gravatar-cache-ttl'." + (cond (url-standalone-mode + (not (file-exists-p (url-cache-create-filename url)))) + (t (let ((cache-time (url-is-cached url))) + (if cache-time + (time-less-p + (time-add + cache-time + gravatar-cache-ttl) + (current-time)) + t))))) + +(defun gravatar-get-data () + "Get data from current buffer." + (when (string-match "^HTTP/.+ 200 OK$" + (buffer-substring (point-min) (line-end-position))) + (when (search-forward "\n\n" nil t) + (buffer-substring (point) (point-max))))) + +(defun gravatar-data->image () + "Get data of current buffer and return an image. +If no image available, return 'error." + (let ((data (gravatar-get-data))) + (if data + (create-image data nil t) + 'error))) + +;;;###autoload +(defun gravatar-retrieve (mail-address cb &optional cbargs) + "Retrieve MAIL-ADDRESS gravatar and call CB on retrieval. +You can provide a list of argument to pass to CB in CBARGS." + (let ((url (gravatar-build-url mail-address))) + (if (gravatar-cache-expired url) + (url-retrieve url + 'gravatar-retrieved + (list cb (when cbargs cbargs))) + (apply cb + (with-temp-buffer + (mm-disable-multibyte) + (url-cache-extract (url-cache-create-filename url)) + (gravatar-data->image)) + cbargs)))) + +(defun gravatar-retrieved (status cb &optional cbargs) + "Callback function used by `gravatar-retrieve'." + ;; Store gravatar? + (when gravatar-automatic-caching + (url-store-in-cache (current-buffer))) + (if (plist-get status :error) + ;; Error happened. + (apply cb 'error cbargs) + (apply cb (gravatar-data->image) cbargs))) + +(provide 'gravatar) + +;;; gravatar.el ends here diff --git a/texi/ChangeLog b/texi/ChangeLog index 17022ddcb..5cedf171d 100644 --- a/texi/ChangeLog +++ b/texi/ChangeLog @@ -1,3 +1,7 @@ +2010-09-24 Julien Danjou + + * gnus.texi: Add Gravatars. + 2010-09-23 Lars Magne Ingebrigtsen * gnus.texi (Startup Variables): Mention gnus-use-backend-marks. diff --git a/texi/gnus.texi b/texi/gnus.texi index 24b9cba30..169e1d1d2 100644 --- a/texi/gnus.texi +++ b/texi/gnus.texi @@ -589,7 +589,7 @@ Article Treatment * Article Buttons:: Click on URLs, Message-IDs, addresses and the like. * Article Button Levels:: Controlling appearance of buttons. * Article Date:: Grumble, UT! -* Article Display:: Display various stuff---X-Face, Picons, Smileys +* Article Display:: Display various stuff---X-Face, Picons, Smileys, Gravatars * Article Signature:: What is a signature? * Article Miscellanea:: Various other stuff. @@ -9230,7 +9230,8 @@ these articles easier. * Article Buttons:: Click on URLs, Message-IDs, addresses and the like. * Article Button Levels:: Controlling appearance of buttons. * Article Date:: Grumble, UT! -* Article Display:: Display various stuff---X-Face, Picons, Smileys +* Article Display:: Display various stuff: + X-Face, Picons, Gravatars, Smileys. * Article Signature:: What is a signature? * Article Miscellanea:: Various other stuff. @end menu @@ -10274,6 +10275,7 @@ preferred format automatically. @cindex picons @cindex x-face @cindex smileys +@cindex gravatars These commands add various frivolous display gimmicks to the article buffer in Emacs versions that support them. @@ -10290,6 +10292,9 @@ their messages with (@pxref{Smileys}). Picons, on the other hand, reside on your own system, and Gnus will try to match the headers to what you have (@pxref{Picons}). +Gravatars reside on-line and are fetched from +@uref{http://www.gravatar.com/} (@pxref{Gravatars}). + All these functions are toggles---if the elements already exist, they'll be removed. @@ -10328,6 +10333,17 @@ Piconify all mail headers (i. e., @code{Cc}, @code{To}) Piconify all news headers (i. e., @code{Newsgroups} and @code{Followup-To}) (@code{gnus-treat-newsgroups-picon}). +@item W D g +@kindex W D g (Summary) +@findex gnus-treat-from-gravatar +Gravatarify the @code{From} header (@code{gnus-treat-from-gravatar}). + +@item W D h +@kindex W D h (Summary) +@findex gnus-treat-mail-gravatar +Gravatarify all mail headers (i. e., @code{Cc}, @code{To}) +(@code{gnus-treat-from-gravatar}). + @item W D D @kindex W D D (Summary) @findex gnus-article-remove-images @@ -12594,6 +12610,8 @@ controlling variable is a predicate list, as described above. @vindex gnus-treat-from-picon @vindex gnus-treat-mail-picon @vindex gnus-treat-newsgroups-picon +@vindex gnus-treat-from-gravatar +@vindex gnus-treat-mail-gravatar @vindex gnus-treat-display-smileys @vindex gnus-treat-body-boundary @vindex gnus-treat-display-x-face @@ -12660,6 +12678,11 @@ possible but those listed are probably sufficient for most people. @xref{Picons}. +@item gnus-treat-from-gravatar (head) +@item gnus-treat-mail-gravatar (head) + +@xref{Gravatars}. + @item gnus-treat-display-smileys (t, integer) @item gnus-treat-body-boundary (head) @@ -23672,6 +23695,7 @@ stuff, so Gnus has taken advantage of that. * Face:: Display a funkier, teensier colored image. * Smileys:: Show all those happy faces the way they were meant to be shown. * Picons:: How to display pictures of what you're reading. +* Gravatars:: Display the avatar of people you read. * XVarious:: Other XEmacsy Gnusey variables. @end menu @@ -24000,6 +24024,48 @@ Ordered list of suffixes on picon file names to try. Defaults to @end table +@node Gravatars +@subsection Gravatars + +@iftex +@iflatex +\include{gravatars} +@end iflatex +@end iftex + +A gravatar is an image registered to an e-mail address. + +You can submit yours on-line at @uref{http://www.gravatar.com}. + +The following variables offer control over how things are displayed. + +@table @code + +@item gnus-gravatar-size +@vindex gnus-gravatar-size +The size in pixels of gravatars. Gravatars are always square, so one +number for the size is enough. + +@item gnus-gravatar-relief +@vindex gnus-gravatar-relief +If non-nil, adds a shadow rectangle around the image. The value, +relief, specifies the width of the shadow lines, in pixels. If relief +is negative, shadows are drawn so that the image appears as a pressed +button; otherwise, it appears as an unpressed button. + +@end table + +If you want to see them in the From field, set: +@lisp +(setq gnus-treat-from-gravatar 'head) +@end lisp + +If you want to see them in the Cc and To fields, set: + +@lisp +(setq gnus-treat-mail-gravatar 'head) +@end lisp + @node XVarious @subsection Various XEmacs Variables