gravatar for wanderlust and gnus

gnus-gravatar.el

;;; gravatar.el --- gravatar fetch/store functions

;; Copyright (C) 2008  Iwata

;; Author: Iwata <[email protected]>
;; 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.

;;
;; Usage:
;; (require 'gnus-gravatar)
;;

;;
;; detail of gravatar API is following,
;;  http://en.gravatar.com/site/implement/url
;;

(require 'gnus-art)
(require 'gnus-picon)
(require 'gravatar)

(defalias 'gnus-gravatar-insert-glyph 'gnus-picon-insert-glyph)
(defalias 'gnus-gravatar-create-glyph 'gnus-picon-create-glyph)

(defvar gnus-treat-gravatar-icon
  (if (and (gnus-image-type-available-p 'png)
	   (gnus-image-type-available-p 'jpeg)
	   (gnus-image-type-available-p 'gif))
      'head nil))

(add-to-list 'gnus-treatment-function-alist
              '(gnus-treat-gravatar-icon gnus-treat-gravatar-icon))

(defcustom gnus-gravatar-style
  (if (boundp 'gnus-picon-style) gnus-picon-style 'inline)
  "*How should gravatar icons be displayed.
If `inline', the textual representation is replaced.  If `right', picons are
added right to the textual representation."
  :type '(choice (const inline)
                 (const right))
  :group 'gnus-gravatar)

(defun gnus-gravatar-transform-field (header category)
  (gnus-with-article-headers
    (let ((field (mail-fetch-field header))
          file image len)
      (when (and field
		 (setq field (gravatar-split-address (downcase field)))
		 (setq file
		       (let* ((size (gravatar-make-query-size gravatar-icon-size))
			      (fn (gravatar-make-store-filename field size)))
			 (if (file-exists-p fn)
			     ;; use cache
			     fn
			   (progn
			     (gravatar-retrieve
			      fn
			      (gravatar-make-url field size))
			     (if (file-exists-p fn)
				 fn
			       (format "%s/%s"
				       gnus-gravatar-directory
				       gravatar-unknown-icon))))))
		 (setq image (cons (gnus-gravatar-create-glyph file) header))
		 (gnus-article-goto-header header))
	(case gnus-gravatar-style
          (right
           (setq len (car (image-size (car image))))
           (when (and len (> len 0))
             (goto-char (point-at-eol))
             (insert (propertize
                      " " 'display
                      (cons 'space
                            (list :align-to (- (window-width) 1 len))))))
           (goto-char (point-at-eol)))
          (inline nil))
	(gnus-gravatar-insert-glyph image category)))))

(defun gnus-treat-gravatar-icon ()
  "Display gravatar icons in the from header.
If icons are already displayed, remove them."
  (interactive)
  (let ((wash-gravatar-p buffer-read-only))
    (gnus-with-article-headers
      (if (and wash-gravatar-p (memq 'gravatar-icon gnus-article-wash-types))
          (gnus-delete-images 'gravatar-icon)
        (gnus-gravatar-transform-field "from" 'gravatar-icon)))))

(provide 'gnus-gravatar)

;;; gnus-gravatar.el ends here

gravatar.el

;;; gravatar.el --- gravatar fetch/store functions

;; Copyright (C) 2008  Iwata

;; Author: Iwata <[email protected]>
;; 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.

;;
;; Usage:
;; (setq gravatar-directory "~/.emacs-gravatar/")
;;

;;
;; gravatar interface api.
;; detail of gravatar API is following,
;;  http://en.gravatar.com/site/implement/url
;;

(require 'md5)
(require 'image)
(require 'mail-parse)

(defvar gravatar-active-p t
  "Fetch gravatar icon from network")

(defvar gravatar-unregistered-icon-query-alist
  '((none      . "")
    (identicon . "&d=identicon")
    (monsterid . "&d=monsterid")
    (wavatar   . "&d=wavatar")))

(defcustom gravatar-unregistered-icon 'none
  "Icon type of unregistered user."
  :group 'gravatar)

(defcustom gravatar-base-url "http://www.gravatar.com/avatar/"
  "URL of gravatar's www site."
  :group 'gravatar)

(defcustom gravatar-directory "~/.emacs-gravatar/"
  "Placement of picture files."
  :group 'gravatar)

(defcustom gravatar-retrieval-program "wget -q -O '%s' '%s'"
  "URL retrieving program."
  :group 'gravatar)

(defcustom gravatar-icon-size 45
  "Display icon size"
  :group 'gravatar)

(defcustom gravatar-unknown-icon "unknown-45x45.jpg"
  "Display icon when pixmap is unrecognized"
  :group 'gravatar)

(defun gravatar-split-address (address)
  (car (mail-header-parse-address address)))

(defun gravatar-retrieve (path url)
  (if gravatar-active-p
      (let ((spath (expand-file-name gravatar-directory)))
	(if (not (file-exists-p spath))
	    (make-directory spath t))
	(shell-command-to-string
	 (format gravatar-retrieval-program
		 (expand-file-name path)
		 url)))))

(defun gravatar-make-query-size (size)
  (format "s=%s" (int-to-string size)))

(defun gravatar-make-query-rate (rate)
  ;; g, pg, r or x
  (format "r=%s" rate))

(defun gravatar-make-query (opts)
  (if (eq opts nil)
      ""
    (concat "?" (mapconcat (lambda (x) x) opts "&")
	    ;; unknown user
	    (cdr (assq gravatar-unregistered-icon
		       gravatar-unregistered-icon-query-alist)))))

(defun gravatar-make-store-filename-from-user (user)
  (let ((string user))
    (while (string-match "[^!#$%&()+,=@A-Z^_a-z0-9{}~-]" string)
      (setq string (replace-match "_" nil nil string)))
    string))

(defun gravatar-make-store-filename (user &rest opts)
  (concat
   gravatar-directory
   ;;(gravatar-make-id-from-name user)
   (gravatar-make-store-filename-from-user
    (gravatar-split-address user))
   (if (eq opts nil)
       ""
     (concat "_" (mapconcat (lambda (x) x) opts "_")))))

(defun gravatar-make-id-from-name (user)
  (md5
   (apply 'concat (split-string (downcase user) " "))))

(defun gravatar-make-url (user &rest opts)
  (concat
   gravatar-base-url
   (gravatar-make-id-from-name user)
   (gravatar-make-query opts)))


(defun gravator-toggle ()
  "Toggle `gravatar-retrieve'"
  (interactive)
  (setq gravatar-active-p (not gravatar-active-p))
  (if gravatar-active-p
      (message "gravatar-active-p on")
    (message "gravatar-active-p off")))


;; test
(defun gravatar-insert-image (user &rest opts)
  (let ((args (append (list user) opts)))
    (insert-image
     (create-image
      (apply
       'gravatar-make-store-filename args)))))

(if nil
    (let ((user "[email protected]")
	  (size (gravatar-make-query-size gravatar-icon-size)))
      (message
       (gravatar-retrieve
	(gravatar-make-store-filename user size)
	(gravatar-make-url user size)))
      (gravatar-insert-image user size)))

(provide 'gravatar)

;;; gravatar.el ends here

wl-gravatar.el

;;; wl-gravatar.el --- gravatar fetch/store functions

;; Copyright (C) 2010  Kazuhiro NISHIYAMA

;; Author: Kazuhiro NISHIYAMA <[email protected]>
;; 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 gravatar-directory "~/.cache/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"))
        (size (gravatar-make-query-size gravatar-icon-size))
        filename)
    (when field
      (setq field (wl-address-header-extract-address field))
      (setq filename (gravatar-make-store-filename field size))
      (if wl-gravatar-retrieve-once
          (when (not (file-exists-p filename))
            (gravatar-retrieve filename (gravatar-make-url field size)))
        (gravatar-retrieve filename (gravatar-make-url field size)))
      (save-excursion
        (goto-char (point-min))
        (when (re-search-forward "^From: " nil t)
          (insert-image (create-image filename))))
      )))

(provide 'wl-gravatar)
;;; wl-gravatar.el ends here