Skip to content

@dabrahams /gravatar.el forked from znz/gnus-gravatar.el
Created

Embed URL

HTTPS clone URL

Subversion checkout URL

You can clone with
or
.
Download ZIP
Improved gravatar handling for wanderlust (maybe should push some of it up to gravatar.el?)
;;; 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 --- 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment
Something went wrong with that request. Please try again.