X-Git-Url: https://cgit.sxemacs.org/?a=blobdiff_plain;f=lisp%2Fgnus-gravatar.el;h=b6e760b1d0be749b7a38df11791346643baf010e;hb=cfc30889cae978ef0626d7fd965eb28847188ad8;hp=8ccf84eb9af3ebe16c82bfdf0e1d32ac44eaeb83;hpb=ca992f6866e38a95e184eba09801df9e68c15387;p=gnus diff --git a/lisp/gnus-gravatar.el b/lisp/gnus-gravatar.el index 8ccf84eb9..b6e760b1d 100644 --- a/lisp/gnus-gravatar.el +++ b/lisp/gnus-gravatar.el @@ -1,6 +1,6 @@ ;;; gnus-gravatar.el --- Gnus Gravatar support -;; Copyright (C) 2010 Free Software Foundation, Inc. +;; Copyright (C) 2010-2012 Free Software Foundation, Inc. ;; Author: Julien Danjou ;; Keywords: news @@ -26,13 +26,15 @@ (require 'gravatar) (require 'gnus-art) +(require 'mail-extr) ;; Because of binding `mail-extr-disable-voodoo'. (defgroup gnus-gravatar nil "Gnus Gravatar." :group 'gnus-visual) -(defcustom gnus-gravatar-size 32 - "How big should gravatars be displayed." +(defcustom gnus-gravatar-size nil + "How big should gravatars be displayed. +If nil, default to `gravatar-size'." :type 'integer :version "24.1" :group 'gnus-gravatar) @@ -43,98 +45,99 @@ :version "24.1" :group 'gnus-gravatar) -(defcustom gnus-gravatar-too-ugly (if (boundp 'gnus-article-x-face-too-ugly) - gnus-article-x-face-too-ugly) +(defcustom gnus-gravatar-too-ugly gnus-article-x-face-too-ugly "Regexp matching posters whose avatar shouldn't be shown automatically." :type '(choice regexp (const nil)) :version "24.1" :group 'gnus-gravatar) -(defun gnus-gravatar-transform-address (header category) +(defun gnus-gravatar-transform-address (header category &optional force) (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))))) - (let ((gravatar-size gnus-gravatar-size)) - (dolist (address addresses) - (unless (and gnus-gravatar-too-ugly - (or (string-match gnus-gravatar-too-ugly - (car address)) - (and (cdr address) - (string-match gnus-gravatar-too-ugly - (cdr address))))) - (ignore-errors - (gravatar-retrieve - (car address) - 'gnus-gravatar-insert - (list header address category))))))))) + (let* ((mail-extr-disable-voodoo t) + (mail-extr-ignore-realname-equals-mailbox-name nil) + (addresses (mail-extract-address-components + (or (mail-fetch-field header) "") t)) + (gravatar-size (or gnus-gravatar-size gravatar-size)) + name) + (dolist (address addresses) + (when (and (setq name (car address)) + (string-match "\\` +" name)) + (setcar address (setq name (substring name (match-end 0))))) + (when (or force + (not (and gnus-gravatar-too-ugly + (or (string-match gnus-gravatar-too-ugly + (or (cadr address) "")) + (and name + (string-match gnus-gravatar-too-ugly + name)))))) + (ignore-errors + (gravatar-retrieve + (cadr address) + 'gnus-gravatar-insert + (list header 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 - ;; The buffer can be gone at this time - (when (buffer-live-p (current-buffer)) - (gnus-article-goto-header header) - (mail-header-narrow-to-field) - (let ((real-name (cdr address)) - (mail-address (car address))) - (when (if real-name ; have a realname, go for it! - (and (search-forward real-name nil t) - (search-backward real-name nil t)) - (and (search-forward mail-address nil t) - (search-backward mail-address nil t))) - (goto-char (1- (point))) - ;; If we're on the " quoting the name, go backward - (when (looking-at "[\"<]") - (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))) - (unless (featurep 'xemacs) - (setq gravatar (append gravatar gnus-gravatar-properties))) - (gnus-put-image gravatar nil category) - (put-text-property point (point) 'gnus-gravatar address) - (gnus-add-wash-type category) - (gnus-add-image category gravatar))))))))) + (gnus-with-article-buffer + (let ((mark (point-marker)) + (inhibit-point-motion-hooks t) + (case-fold-search t)) + (save-restriction + (article-narrow-to-head) + ;; The buffer can be gone at this time + (when (buffer-live-p (current-buffer)) + (gnus-article-goto-header header) + (mail-header-narrow-to-field) + (let ((real-name (car address)) + (mail-address (cadr address))) + (when (if real-name + (re-search-forward + (concat (gnus-replace-in-string + (regexp-quote real-name) "[\t ]+" "[\t\n ]+") + "\\|" + (regexp-quote mail-address)) + nil t) + (search-forward mail-address nil t)) + (goto-char (1- (match-beginning 0))) + ;; If we're on the " quoting the name, go backward + (when (looking-at "[\"<]") + (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 ((point (point))) + (unless (featurep 'xemacs) + (setq gravatar (append gravatar gnus-gravatar-properties))) + (gnus-put-image gravatar (buffer-substring (point) (1+ point)) category) + (put-text-property point (point) 'gnus-gravatar address) + (gnus-add-wash-type category) + (gnus-add-image category gravatar))))))) + (goto-char (marker-position mark)))))) ;;;###autoload -(defun gnus-treat-from-gravatar () +(defun gnus-treat-from-gravatar (&optional force) "Display gravatar in the From header. If gravatar is already displayed, remove it." - (interactive) + (interactive (list t)) ;; When type `W D g' (gnus-with-article-buffer (if (memq 'from-gravatar gnus-article-wash-types) - (gnus-delete-images 'from-gravatar) - (let ((gnus-gravatar-too-ugly - (unless buffer-read-only ;; When type `W D g' - gnus-gravatar-too-ugly))) - (gnus-gravatar-transform-address "from" 'from-gravatar))))) + (gnus-delete-images 'from-gravatar) + (gnus-gravatar-transform-address "from" 'from-gravatar force)))) ;;;###autoload -(defun gnus-treat-mail-gravatar () +(defun gnus-treat-mail-gravatar (&optional force) "Display gravatars in the Cc and To headers. If gravatars are already displayed, remove them." - (interactive) + (interactive (list t)) ;; When type `W D h' (gnus-with-article-buffer (if (memq 'mail-gravatar gnus-article-wash-types) (gnus-delete-images 'mail-gravatar) - (let ((gnus-gravatar-too-ugly - (unless buffer-read-only ;; When type `W D h' - gnus-gravatar-too-ugly))) - (gnus-gravatar-transform-address "cc" 'mail-gravatar) - (gnus-gravatar-transform-address "to" 'mail-gravatar))))) + (gnus-gravatar-transform-address "cc" 'mail-gravatar force) + (gnus-gravatar-transform-address "to" 'mail-gravatar force)))) (provide 'gnus-gravatar)