public
Last active — forked from znz/gnus-gravatar.el

Improved gravatar handling for wanderlust (maybe should push some of it up to gravatar.el?)

  • Download Gist
gravatar.el
Emacs Lisp
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133
;;; gravatar.el --- Get Gravatars
 
;; Copyright (C) 2010 Free Software Foundation, Inc.
 
;; Author: Julien Danjou <julien@danjou.info>
;; 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 <http://www.gnu.org/licenses/>.
 
;;; Commentary:
 
;;; Code:
 
(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)))))
 
(eval-and-compile
(cond ((featurep 'xemacs)
(require 'gnus-xmas)
(defalias 'gravatar-create-image 'gnus-xmas-create-image))
((featurep 'gnus-ems)
(defalias 'gravatar-create-image 'gnus-create-image))
(t
(require 'image)
(defalias 'gravatar-create-image 'create-image))))
 
(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
(gravatar-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))
(kill-buffer (current-buffer)))
 
(provide 'gravatar)
 
;;; gravatar.el ends here
wl-gravatar.el
Emacs Lisp
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61
;;; wl-gravatar.el --- gravatar fetch/store functions
 
;; Copyright (C) 2010 Kazuhiro NISHIYAMA
 
;; Author: Kazuhiro NISHIYAMA <zn@mbf.nifty.com>
;; Keywords: faces, tools, extensions, mail
 
;; This file 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, or (at your option)
;; any later version.
 
;; This file 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; see the file COPYING. If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
 
;;; Commentary:
 
;; Usage:
;; (require 'wl-gravatar)
;; (setq wl-highlight-x-face-function 'wl-gravatar-insert)
;; (setq gnus-gravatar-directory "~/.emacs-gravatar/")
;; (setq gravatar-unregistered-icon 'identicon)
;; (setq wl-gravatar-retrieve-once t)
 
;;; Code:
 
(require 'gravatar)
 
(defvar wl-gravatar-retrieve-once nil)
 
(defun wl-gravatar-insert (&rest dummy)
"Display Gravatar images."
(let ((field (std11-fetch-field "From"))
image)
(message "wl-gravatar-insert: field=%s, address=%s" field (when field (wl-address-header-extract-address field)))
(when field
(gravatar-retrieve
 
(wl-address-header-extract-address field)
 
(lambda (image buffer)
(unless (eq image 'error)
(with-current-buffer buffer
(save-excursion
(goto-char (point-min))
(when (re-search-forward "^From: " nil t)
(let ((inhibit-read-only t))
; (message "inserting gravatar in buffer %s" (buffer-name))
(insert-image image)))))))
 
`(,(current-buffer))))))
 
(provide 'wl-gravatar)
;;; wl-gravatar.el ends here

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.