>From e3843695775f2f52cf9c6ca435949df67d83ed11 Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Sat, 20 Jul 2019 19:14:16 +0100 Subject: [PATCH] Improve Gravatar support * doc/misc/gnus.texi (X-Face): Fix cross-reference. (Gravatars): Clarify user option descriptions. * etc/NEWS: Announce changes in gravatar.el user options. * lisp/gnus/gnus-gravatar.el: Use lexical-binding. (gnus-gravatar-size, gnus-gravatar-too-ugly): Clarify docstring and custom :type. (gnus-gravatar-insert): Check liveness of article buffer sooner. (gnus-treat-from-gravatar, gnus-treat-mail-gravatar): Use interactive spec "p" instead of emulating it. * lisp/image/gravatar.el: Use lexical-binding. (gravatar-cache-ttl): Change :type to number of seconds without changing the default value and while still accepting other time value formats. (gravatar-rating): Restrict :type to ratings recognized by Gravatar and document them. (gravatar-size): Allow nil as a value, in which case Gravatar's default size is used. (gravatar-default-image, gravatar-force-default): New user options controlling the Gravatar query parameters 'default' and 'forcedefault', respectively. (gravatar-base-url): Use HTTPS. (gravatar-hash): Trim leading and trailing whitespace in given address, as per the Gravatar docs. (gravatar--query-string): New helper function to facilitate testing. (gravatar-build-url): Use it. (gravatar-cache-expired): Remove. Change all callers to use url-cache-expired instead. (gravatar-get-data): Simplify. (gravatar-data->image): Remove. (gravatar-retrieve, gravatar-retrieve-synchronously): Document return value. Reuse url-fetch-from-cache and gravatar-retrieved to reduce duplication. (gravatar-retrieved): Do not cache buffer on error or if url-current-object is nil. The latter condition affords reusing this function in cached URL buffers. * test/lisp/image/gravatar-tests.el: New file. --- doc/misc/gnus.texi | 26 ++-- etc/NEWS | 13 ++ lisp/gnus/gnus-gravatar.el | 104 +++++++-------- lisp/image/gravatar.el | 207 ++++++++++++++++++------------ test/lisp/image/gravatar-tests.el | 72 +++++++++++ 5 files changed, 279 insertions(+), 143 deletions(-) create mode 100644 test/lisp/image/gravatar-tests.el diff --git a/doc/misc/gnus.texi b/doc/misc/gnus.texi index f688e84e7e..07c81c49c4 100644 --- a/doc/misc/gnus.texi +++ b/doc/misc/gnus.texi @@ -23505,11 +23505,11 @@ X-Face (png . (:relief -2)))) @end lisp -@pxref{Image Descriptors, ,Image Descriptors, elisp, The Emacs Lisp -Reference Manual} for the valid properties for various image types. -Currently, @code{pbm} is used for X-Face images and @code{png} is used -for Face images in Emacs. Only the @code{:face} property is effective -on the @code{xface} image type in XEmacs if it is built with the +For the valid properties of various image types, @pxref{Image +Descriptors,,, elisp, The Emacs Lisp Reference Manual}. Currently, +@code{pbm} is used for X-Face images and @code{png} is used for Face +images in Emacs. Only the @code{:face} property is effective on the +@code{xface} image type in XEmacs if it is built with the @samp{libcompface} library. @end table @@ -23780,21 +23780,25 @@ Gravatars @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. +number for the size is enough. If @code{nil}, this defaults to the +value of @code{gravatar-size}. @item gnus-gravatar-properties @vindex gnus-gravatar-properties -List of image properties applied to Gravatar images. +List of image properties applied to Gravatar images (@pxref{Image +Descriptors,,, elisp, The Emacs Lisp Reference Manual}). @item gnus-gravatar-too-ugly @vindex gnus-gravatar-too-ugly -Regexp that matches mail addresses or names of people of which avatars -should not be displayed, or @code{nil}. It default to the value of -@code{gnus-article-x-face-too-ugly} (@pxref{X-Face}). +Regexp that matches mail addresses or names of people whose avatars +should not be displayed, or @code{nil} to display all avatars. It +defaults to the value of @code{gnus-article-x-face-too-ugly} +(@pxref{X-Face}). @end table -If you want to see them in the From field, set: +If you want to see gravatars in the From field, set: + @lisp (setq gnus-treat-from-gravatar 'head) @end lisp diff --git a/etc/NEWS b/etc/NEWS index 5378e56bca..9414b3b90d 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1714,6 +1714,19 @@ particular when the end of the buffer is visible in the window. Use 'mouse-wheel-mode' instead. Note that 'mouse-wheel-mode' is already enabled by default on most graphical displays. +** Gravatar + +*** 'gravatar-cache-ttl' is now a number of seconds. +The previously used timestamp format of a list of integers is still +supported, but is deprecated. The default value has not changed. + +*** 'gravatar-size' can now be nil. +This results in the use of Gravatar's default size of 80 pixels. + +*** The default fallback gravatar is now configurable. +This is possible using the new user options 'gravatar-default-image' +and 'gravatar-force-default'. + * New Modes and Packages in Emacs 27.1 diff --git a/lisp/gnus/gnus-gravatar.el b/lisp/gnus/gnus-gravatar.el index d271a52f90..8c9a0b27ba 100644 --- a/lisp/gnus/gnus-gravatar.el +++ b/lisp/gnus/gnus-gravatar.el @@ -1,9 +1,9 @@ -;;; gnus-gravatar.el --- Gnus Gravatar support +;;; gnus-gravatar.el --- Gnus Gravatar support -*- lexical-binding: t -*- ;; Copyright (C) 2010-2019 Free Software Foundation, Inc. ;; Author: Julien Danjou -;; Keywords: news +;; Keywords: multimedia, news ;; This file is part of GNU Emacs. @@ -29,13 +29,15 @@ (require 'mail-extr) ;; Because of binding `mail-extr-disable-voodoo'. (defgroup gnus-gravatar nil - "Gnus Gravatar." + "Gravatars in Gnus." + :link '(custom-group-link gravatar) :group 'gnus-visual) (defcustom gnus-gravatar-size nil - "How big should gravatars be displayed. + "Size in pixels at which gravatars should be displayed. If nil, default to `gravatar-size'." - :type '(choice (const nil) integer) + :type '(choice (const nil) + (integer :tag "Pixels")) :version "24.1" :group 'gnus-gravatar) @@ -46,8 +48,9 @@ gnus-gravatar-properties :group 'gnus-gravatar) (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)) + "Regexp matching posters whose avatar shouldn't be shown automatically. +Nil means show all avatars." + :type '(choice regexp (const :tag "Allow all" nil)) :version "24.1" :group 'gnus-gravatar) @@ -73,56 +76,57 @@ gnus-gravatar-transform-address (ignore-errors (gravatar-retrieve (cadr address) - 'gnus-gravatar-insert + #'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." +Set image category to CATEGORY. This function is intended as a +callback for `gravatar-retrieve'." (unless (eq gravatar 'error) (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)) + ;; The buffer can be gone at this time. + (when (buffer-name) + (let ((real-name (car address)) + (mail-address (cadr address)) + (mark (point-marker)) + (inhibit-point-motion-hooks t) + (case-fold-search t)) + (save-restriction + (article-narrow-to-head) (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 (replace-regexp-in-string - "[\t ]+" "[\t\n ]+" - (regexp-quote real-name)) - "\\|" - (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))) - (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)))))) + (when (if real-name + (re-search-forward + (concat (replace-regexp-in-string + "[\t ]+" "[\t\n ]+" + (regexp-quote real-name)) + "\\|" + (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-p "[\"<]") + (goto-char (1- (point)))) + ;; Do not do anything if there's already a gravatar. This can + ;; happen 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 (get-text-property (point) 'gnus-gravatar) + (let ((pos (point))) + (setq gravatar (append gravatar gnus-gravatar-properties)) + (gnus-put-image gravatar (buffer-substring pos (1+ pos)) category) + (put-text-property pos (point) 'gnus-gravatar address) + (gnus-add-wash-type category) + (gnus-add-image category gravatar))))) + (goto-char mark)))))) ;;;###autoload (defun gnus-treat-from-gravatar (&optional force) "Display gravatar in the From header. If gravatar is already displayed, remove it." - (interactive (list t)) ;; When type `W D g' + (interactive "p") ;; When type `W D g' (gnus-with-article-buffer (if (memq 'from-gravatar gnus-article-wash-types) (gnus-delete-images 'from-gravatar) @@ -132,12 +136,12 @@ gnus-treat-from-gravatar (defun gnus-treat-mail-gravatar (&optional force) "Display gravatars in the Cc and To headers. If gravatars are already displayed, remove them." - (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) - (gnus-gravatar-transform-address "cc" 'mail-gravatar force) - (gnus-gravatar-transform-address "to" 'mail-gravatar force)))) + (interactive "p") ;; When type `W D h' + (gnus-with-article-buffer + (if (memq 'mail-gravatar gnus-article-wash-types) + (gnus-delete-images 'mail-gravatar) + (gnus-gravatar-transform-address "cc" 'mail-gravatar force) + (gnus-gravatar-transform-address "to" 'mail-gravatar force)))) (provide 'gnus-gravatar) diff --git a/lisp/image/gravatar.el b/lisp/image/gravatar.el index 91da840e3a..c385a2cce7 100644 --- a/lisp/image/gravatar.el +++ b/lisp/image/gravatar.el @@ -1,9 +1,9 @@ -;;; gravatar.el --- Get Gravatars +;;; gravatar.el --- Get Gravatars -*- lexical-binding: t -*- ;; Copyright (C) 2010-2019 Free Software Foundation, Inc. ;; Author: Julien Danjou -;; Keywords: news +;; Keywords: comm, multimedia ;; This file is part of GNU Emacs. @@ -26,10 +26,11 @@ (require 'url) (require 'url-cache) -(require 'image) +(eval-when-compile + (require 'subr-x)) (defgroup gravatar nil - "Gravatar." + "Gravatars." :version "24.1" :group 'comm) @@ -38,113 +39,155 @@ gravatar-automatic-caching :type 'boolean :group 'gravatar) -;; FIXME a time value is not the nicest format for a custom variable. -(defcustom gravatar-cache-ttl (days-to-time 30) - "Time to live for gravatar cache entries." - :type '(repeat integer) +(defcustom gravatar-cache-ttl 2592000 + "Time to live in seconds for gravatar cache entries. +If a requested gravatar has been cached for longer than this, it +is retrieved anew. The default value is 30 days." + :type 'integer + ;; Restricted :type to number of seconds. + :version "27.1" :group 'gravatar) -;; FIXME Doc is tautological. What are the options? (defcustom gravatar-rating "g" - "Default rating for gravatar." - :type 'string + "Most explicit Gravatar rating level to allow. +Some gravatars are rated according to how suitable they are for +different audiences. The supported rating levels are, in order +of increasing explicitness, the following: + +\"g\" - Suitable for any audience. +\"pg\" - May contain rude gestures, provocatively dressed + individuals, mild profanity, or mild violence. +\"r\" - May contain harsh profanity, intense violence, nudity, + or hard drug use. +\"x\" - May contain hardcore sexual imagery or extremely + disturbing violence. + +Each level covers itself as well as all less explicit levels. +For example, setting this variable to \"pg\" will allow gravatars +rated either \"g\" or \"pg\"." + :type '(choice (const :tag "General Audience" "g") + (const :tag "Parental Guidance" "pg") + (const :tag "Restricted" "r") + (const :tag "Explicit" "x")) + ;; Restricted :type to ratings recognized by Gravatar. + :version "27.1" :group 'gravatar) (defcustom gravatar-size 32 - "Default size in pixels for gravatars." - :type 'integer + "Gravatar size in pixels to request. +Valid sizes range from 1 to 2048 inclusive. If nil, use the +Gravatar default (usually 80)." + :type '(choice (const :tag "Gravatar default" nil) + (integer :tag "Pixels")) + :version "27.1" + :group 'gravatar) + +(defcustom gravatar-default-image "404" + "Default gravatar to use when none match the request. +This happens when no gravatar satisfying `gravatar-rating' exists +for a given email address. The following options are supported: + +nil - Default placeholder. +\"404\" - No placeholder. +\"mp\" - Mystery Person: generic avatar outline. +\"identicon\" - Geometric pattern based on email address. +\"monsterid\" - Generated \"monster\" with different colors, faces, etc. +\"wavatar\" - Generated faces with different features and backgrounds. +\"retro\" - Generated 8-bit arcade-style pixelated faces. +\"robohash\" - Generated robot with different colors, faces, etc. +\"blank\" - Transparent PNG image. +URL - Custom image URL." + :type '(choice (const :tag "Default" nil) + (const :tag "None" "404") + (const :tag "Mystery person" "mp") + (const :tag "Geometric patterns" "identicon") + (const :tag "Monsters" "monsterid") + (const :tag "Faces" "wavatar") + (const :tag "Retro" "retro") + (const :tag "Robots" "robohash") + (const :tag "Blank" "blank") + (string :tag "Custom URL")) + :version "27.1" + :group 'gravatar) + +(defcustom gravatar-force-default nil + "Whether to force use of `gravatar-default-image'. +Non-nil means use `gravatar-default-image' even when there exists +a gravatar for a given email address." + :type 'boolean + :version "27.1" :group 'gravatar) (defconst gravatar-base-url - "http://www.gravatar.com/avatar" + "https://www.gravatar.com/avatar" "Base URL for getting gravatars.") (defun gravatar-hash (mail-address) - "Create a hash from MAIL-ADDRESS." - (md5 (downcase mail-address))) + "Return the Gravatar hash for MAIL-ADDRESS." + ;; https://gravatar.com/site/implement/hash/ + (md5 (downcase (string-trim mail-address)))) + +(defun gravatar--query-string () + "Return URI-encoded query string for Gravatar." + (url-build-query-string + `((r ,gravatar-rating) + ,@(and gravatar-default-image + `((d ,gravatar-default-image))) + ,@(and gravatar-force-default + '((f y))) + ,@(and gravatar-size + `((s ,gravatar-size)))))) (defun gravatar-build-url (mail-address) - "Return a URL to retrieve MAIL-ADDRESS gravatar." - (format "%s/%s?d=404&r=%s&s=%d" + "Return the URL of a gravatar for MAIL-ADDRESS." + ;; https://gravatar.com/site/implement/images/ + (format "%s/%s?%s" 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) nil) - t))))) + (gravatar--query-string))) (defun gravatar-get-data () - "Get data from current buffer." + "Return body of current URL buffer, or nil on failure." (save-excursion (goto-char (point-min)) - (when (re-search-forward "^HTTP/.+ 200 OK$" nil (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 'help-function-arglist "help-fns") + (and (re-search-forward "^HTTP/.+ 200 OK$" nil (line-end-position)) + (search-forward "\n\n" nil t) + (buffer-substring (point) (point-max))))) ;;;###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." +(defun gravatar-retrieve (mail-address callback &optional cbargs) + "Asynchronously retrieve a gravatar for MAIL-ADDRESS. +When finished, call CALLBACK as (apply CALLBACK GRAVATAR CBARGS), +where GRAVATAR is either an image descriptor, or the symbol +`error' if the retrieval failed." (let ((url (gravatar-build-url mail-address))) - (if (gravatar-cache-expired url) - (let ((args (list url - 'gravatar-retrieved - (list cb (when cbargs cbargs))))) - (when (> (length (help-function-arglist 'url-retrieve)) - 4) - (setq args (nconc args (list t)))) - (apply #'url-retrieve args)) - (apply cb - (with-temp-buffer - (set-buffer-multibyte nil) - (url-cache-extract (url-cache-create-filename url)) - (gravatar-data->image)) - cbargs)))) + (if (url-cache-expired url gravatar-cache-ttl) + (url-retrieve url #'gravatar-retrieved (list callback cbargs) t) + (with-current-buffer (url-fetch-from-cache url) + (gravatar-retrieved () callback cbargs))))) ;;;###autoload (defun gravatar-retrieve-synchronously (mail-address) - "Retrieve MAIL-ADDRESS gravatar and returns it." + "Synchronously retrieve a gravatar for MAIL-ADDRESS. +Value is either an image descriptor, or the symbol `error' if the +retrieval failed." (let ((url (gravatar-build-url mail-address))) - (if (gravatar-cache-expired url) - (with-current-buffer (url-retrieve-synchronously url) - (when gravatar-automatic-caching - (url-store-in-cache (current-buffer))) - (let ((data (gravatar-data->image))) - (kill-buffer (current-buffer)) - data)) - (with-temp-buffer - (set-buffer-multibyte nil) - (url-cache-extract (url-cache-create-filename url)) - (gravatar-data->image))))) - + (with-current-buffer (if (url-cache-expired url gravatar-cache-ttl) + (url-retrieve-synchronously url t) + (url-fetch-from-cache url)) + (gravatar-retrieved () #'identity)))) (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))) + "Handle Gravatar response data in current buffer. +Intended as a callback for `url-retrieve'." + (let ((data (unless (plist-get status :error) + (gravatar-get-data)))) + ;; Only cache on success and if `url-current-object' is non-nil, + ;; which indicates current buffer is not already cached. + (and data gravatar-automatic-caching url-current-object + (url-store-in-cache)) + (prog1 (apply cb (if data (create-image data nil t) 'error) cbargs) + (kill-buffer)))) (provide 'gravatar) diff --git a/test/lisp/image/gravatar-tests.el b/test/lisp/image/gravatar-tests.el new file mode 100644 index 0000000000..bd61663f0e --- /dev/null +++ b/test/lisp/image/gravatar-tests.el @@ -0,0 +1,72 @@ +;;; gravatar-tests.el --- tests for gravatar.el -*- lexical-binding: t -*- + +;; Copyright (C) 2019 Free Software Foundation, Inc. + +;; 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 . + +;;; Code: + +(require 'ert) +(require 'gravatar) + +(ert-deftest gravatar-hash () + "Test `gravatar-hash'." + (should (equal (gravatar-hash "") "d41d8cd98f00b204e9800998ecf8427e")) + (let ((hash "acbd18db4cc2f85cedef654fccc4a4d8")) + (should (equal (gravatar-hash "foo") hash)) + (should (equal (gravatar-hash "foo ") hash)) + (should (equal (gravatar-hash " foo") hash)) + (should (equal (gravatar-hash " foo ") hash)))) + +(ert-deftest gravatar-size () + "Test query strings for `gravatar-size'." + (let ((gravatar-default-image nil) + (gravatar-force-default nil)) + (let ((gravatar-size 2048)) + (should (equal (gravatar--query-string) "r=g&s=2048"))) + (let ((gravatar-size nil)) + (should (equal (gravatar--query-string) "r=g"))))) + +(ert-deftest gravatar-default-image () + "Test query strings for `gravatar-default-image'." + (let ((gravatar-force-default nil) + (gravatar-size nil)) + (let ((gravatar-default-image nil)) + (should (equal (gravatar--query-string) "r=g"))) + (let ((gravatar-default-image "404")) + (should (equal (gravatar--query-string) "r=g&d=404"))) + (let ((gravatar-default-image "https://foo/bar.png")) + (should (equal (gravatar--query-string) + "r=g&d=https%3A%2F%2Ffoo%2Fbar.png"))))) + +(ert-deftest gravatar-force-default () + "Test query strings for `gravatar-force-default'." + (let ((gravatar-default-image nil) + (gravatar-size nil)) + (let ((gravatar-force-default nil)) + (should (equal (gravatar--query-string) "r=g"))) + (let ((gravatar-force-default t)) + (should (equal (gravatar--query-string) "r=g&f=y"))))) + +(ert-deftest gravatar-build-url () + "Test `gravatar-build-url'." + (let ((gravatar-default-image nil) + (gravatar-force-default nil) + (gravatar-size nil)) + (should (equal (gravatar-build-url "foo") "\ +https://www.gravatar.com/avatar/acbd18db4cc2f85cedef654fccc4a4d8?r=g")))) + +;;; gravatar-tests.el ends here -- 2.20.1