>From 2fc7925abe4cfdf6db32439f066b8b3f3fa33e2c Mon Sep 17 00:00:00 2001 From: "Basil L. Contovounesios" Date: Mon, 22 Jul 2019 22:06:22 +0100 Subject: [PATCH 2/5] Use lexical-binding for Gravatar support For discussion, see the following thread: https://lists.gnu.org/archive/html/emacs-devel/2019-07/msg00528.html * lisp/gnus/gnus-gravatar.el: Use lexical-binding. Link custom group 'gnus-gravatar' to 'gravatar'. (gnus-gravatar-size, gnus-gravatar-too-ugly): Doc fix. (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-expired): Remove. Change all callers to use url-cache-expired instead. (gravatar-get-data, gravatar-retrieve) (gravatar-retrieve-synchronously): Simplify. --- lisp/gnus/gnus-gravatar.el | 101 +++++++++++++++++++------------------ lisp/image/gravatar.el | 60 +++++++--------------- 2 files changed, 71 insertions(+), 90 deletions(-) diff --git a/lisp/gnus/gnus-gravatar.el b/lisp/gnus/gnus-gravatar.el index 19cbf529c6..ec3f909161 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 :tag "Default" nil) + (integer :tag "Pixels")) :version "24.1" :group 'gnus-gravatar) @@ -48,7 +50,7 @@ gnus-gravatar-properties (defcustom gnus-gravatar-too-ugly gnus-article-x-face-too-ugly "Regexp matching posters whose avatar shouldn't be shown automatically. If nil, show all avatars." - :type '(choice regexp (const nil)) + :type '(choice regexp (const :tag "Allow all" nil)) :version "24.1" :group 'gnus-gravatar) @@ -74,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-live-p (current-buffer)) + (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") (gnus-with-article-buffer (if (memq 'from-gravatar gnus-article-wash-types) (gnus-delete-images 'from-gravatar) @@ -133,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") + (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 9a1ec3b556..ea746b71d7 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,9 @@ (require 'url) (require 'url-cache) -(require 'image) (defgroup gravatar nil - "Gravatar." + "Gravatars." :version "24.1" :group 'comm) @@ -88,22 +87,13 @@ gravatar-build-url 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))))) - (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)))))) + (and (re-search-forward "^HTTP/.+ 200 OK$" nil (line-end-position)) + (search-forward "\n\n" nil t) + (buffer-substring (point) (point-max))))) (defun gravatar-data->image () "Get data of current buffer and return an image. @@ -113,29 +103,20 @@ gravatar-data->image (create-image data nil t) 'error))) -(autoload 'help-function-arglist "help-fns") - ;;;###autoload -(defun gravatar-retrieve (mail-address cb &optional cbargs) +(defun gravatar-retrieve (mail-address callback &optional cbargs) "Asynchronously retrieve a gravatar for MAIL-ADDRESS. -When finished, call CB as (apply CB GRAVATAR CBARGS), +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) + (apply callback + (with-temp-buffer + (url-cache-extract (url-cache-create-filename url)) + (gravatar-data->image)) + cbargs)))) ;;;###autoload (defun gravatar-retrieve-synchronously (mail-address) @@ -143,19 +124,16 @@ gravatar-retrieve-synchronously 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) + (if (url-cache-expired url gravatar-cache-ttl) (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)) + (prog1 (gravatar-data->image) + (kill-buffer (current-buffer)))) (with-temp-buffer - (set-buffer-multibyte nil) (url-cache-extract (url-cache-create-filename url)) (gravatar-data->image))))) - (defun gravatar-retrieved (status cb &optional cbargs) "Callback function used by `gravatar-retrieve'." ;; Store gravatar? -- 2.20.1