From mboxrd@z Thu Jan 1 00:00:00 1970 Path: news.gmane.io!.POSTED.blaine.gmane.org!not-for-mail From: "john muhl" Newsgroups: gmane.emacs.devel Subject: Re: master 5f9b5803bea: Fix zooming images in SHR Date: Sun, 23 Jun 2024 14:36:04 +0000 Message-ID: <5f6b8e84-cd41-4229-ab22-64c931ff7966@app.fastmail.com> References: <171912324641.7384.11296304660836747605@vcs2.savannah.gnu.org> <20240623061407.0C6DDC1FB5C@vcs2.savannah.gnu.org> Mime-Version: 1.0 Content-Type: text/plain Injection-Info: ciao.gmane.io; posting-host="blaine.gmane.org:116.202.254.214"; logging-data="17277"; mail-complaints-to="usenet@ciao.gmane.io" User-Agent: Cyrus-JMAP/3.11.0-alpha0-522-ga39cca1d5-fm-20240610.002-ga39cca1d To: "Jim Porter" , emacs-devel@gnu.org Original-X-From: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Sun Jun 23 16:46:54 2024 Return-path: Envelope-to: ged-emacs-devel@m.gmane-mx.org Original-Received: from lists.gnu.org ([209.51.188.17]) by ciao.gmane.io with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.92) (envelope-from ) id 1sLOUX-0004Ft-60 for ged-emacs-devel@m.gmane-mx.org; Sun, 23 Jun 2024 16:46:54 +0200 Original-Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1sLOTm-00025L-8O; Sun, 23 Jun 2024 10:46:06 -0400 Original-Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1sLOKU-0008En-8D for emacs-devel@gnu.org; Sun, 23 Jun 2024 10:36:31 -0400 Original-Received: from fhigh1-smtp.messagingengine.com ([103.168.172.152]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1sLOKR-0002YI-9a for emacs-devel@gnu.org; Sun, 23 Jun 2024 10:36:30 -0400 Original-Received: from compute6.internal (compute6.nyi.internal [10.202.2.47]) by mailfhigh.nyi.internal (Postfix) with ESMTP id 45CBD1140101; Sun, 23 Jun 2024 10:36:25 -0400 (EDT) Original-Received: from imap53 ([10.202.2.103]) by compute6.internal (MEProxy); Sun, 23 Jun 2024 10:36:25 -0400 DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d=pub.pink; h=cc :content-type:content-type:date:date:from:from:in-reply-to :in-reply-to:message-id:mime-version:references:reply-to:subject :subject:to:to; s=fm1; t=1719153385; x=1719239785; bh=sUvVgu9X// zFfBNcPAlzEu8KktOigWxp1bClpfv3DZQ=; b=ZG9NiOVNQ5wuoQJ53wyoW8aBWf xFsLZ+OVk+pkGIpOkVLwq8MbMAmBEEPhU/fvezAjLiZJJU5/dUU/hB0DiptYfLpV /7mtsx9Ddp7hbrqVloxTCD7mh5B9bQ5QiNKJmo4FEz81buyZrd7XDbUhb1/bvlnF din5snf6QbunPza4c9kzy07NgtM9TcT1G4rV3SDUFEo8osu0FkD+uOCylE++K4Vn VKhQVElGOIfNKKwNs+TM+7cQyx+PuFZBbyaCR4n/IbDaPMd1SWZiyp7B9vGgk8T8 Ktx6yRP70Jgb4D5ScMNaWLLjmgQBv20fGOb+HRh/9WWiD14F3tvJZ1CEpNIQ== DKIM-Signature: v=1; a=rsa-sha256; c=relaxed/relaxed; d= messagingengine.com; h=cc:content-type:content-type:date:date :feedback-id:feedback-id:from:from:in-reply-to:in-reply-to :message-id:mime-version:references:reply-to:subject:subject:to :to:x-me-proxy:x-me-proxy:x-me-sender:x-me-sender:x-sasl-enc; s= fm2; t=1719153385; x=1719239785; bh=sUvVgu9X//zFfBNcPAlzEu8KktOi gWxp1bClpfv3DZQ=; b=ZdxruGkqvRZDwLPJkZ+gMssVvKTZOPOhkgjbnbvPiJqH kQUDW0qQE4fOP81jWhV55gZcwUPgwRzXcJ6yuAZf1RQ+9NLsR7/gpvl87DL4P3hD 1krNGpz0fNEmRdexA4OoVWHDAdWlxLm37M3Lud1cPjIRHdfqDfCEfF9E41MkvSbg +gt6RTttg7z9Xm3htY7FC5BZtt5meZY5JF1cAqMJrnK8JNy3trk33qp4gH/rS3z5 fwrt3gfQ6OSuXKFop+wSTZmNrGlVVIyer+WeoVY/NtVJoS/0qAkUfyOanT6oCjHf dJKsV2np7Y9f5sKlstnsF2indc8F3fsdCLY+wKw38A== X-ME-Sender: X-ME-Proxy-Cause: gggruggvucftvghtrhhoucdtuddrgedvledrfeefledgkedtucetufdoteggodetrfdotf fvucfrrhhofhhilhgvmecuhfgrshhtofgrihhlpdfqfgfvpdfurfetoffkrfgpnffqhgen uceurghilhhouhhtmecufedttdenucenucfjughrpefofgggkfgjfhffhffvufgtsehttd ertderredtnecuhfhrohhmpedfjhhohhhnuchmuhhhlhdfuceojhhmsehpuhgsrdhpihhn kheqnecuggftrfgrthhtvghrnhepheetleefvdfggeefuefghefhkeffleejteeugfejff ejjeehteetheeugeffheeunecuffhomhgrihhnpegvgigrmhhplhgvrdhorhhgnecuvehl uhhsthgvrhfuihiivgeptdenucfrrghrrghmpehmrghilhhfrhhomhepjhhmsehpuhgsrd hpihhnkh X-ME-Proxy: Feedback-ID: i74194916:Fastmail Original-Received: by mailuser.nyi.internal (Postfix, from userid 501) id 143363640070; Sun, 23 Jun 2024 10:36:25 -0400 (EDT) X-Mailer: MessagingEngine.com Webmail Interface In-Reply-To: <20240623061407.0C6DDC1FB5C@vcs2.savannah.gnu.org> Received-SPF: pass client-ip=103.168.172.152; envelope-from=jm@pub.pink; helo=fhigh1-smtp.messagingengine.com X-Spam_score_int: -27 X-Spam_score: -2.8 X-Spam_bar: -- X-Spam_report: (-2.8 / 5.0 requ) BAYES_00=-1.9, DKIM_SIGNED=0.1, DKIM_VALID=-0.1, DKIM_VALID_AU=-0.1, DKIM_VALID_EF=-0.1, RCVD_IN_DNSWL_LOW=-0.7, SPF_HELO_PASS=-0.001, SPF_PASS=-0.001 autolearn=ham autolearn_force=no X-Spam_action: no action X-Mailman-Approved-At: Sun, 23 Jun 2024 10:46:05 -0400 X-BeenThere: emacs-devel@gnu.org X-Mailman-Version: 2.1.29 Precedence: list List-Id: "Emacs development discussions." List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Original-Sender: emacs-devel-bounces+ged-emacs-devel=m.gmane-mx.org@gnu.org Xref: news.gmane.io gmane.emacs.devel:320542 Archived-At: The zoom-image test added here fails on --without-x builds. Running 4 tests (2024-06-23 08:17:31+0200, selector `(not (or (tag :expensive-test) (tag :unstable) (tag :nativecomp)))') passed 1/4 rendering (0.009750 sec) passed 2/4 shr-srcset (0.000130 sec) Test shr-test/zoom-image backtrace: signal(error ("timed out waiting for condition")) error("timed out waiting for condition") shr-test-wait-for(#f(compiled-function () # #f(compiled-function () #)() #f(compiled-function () #)() handler-bind-1(#f(compiled-function () # branch: master > commit 5f9b5803bea0f360a91e00cd85d72ea7f56d6095 > Author: Jim Porter > Commit: Jim Porter > > Fix zooming images in SHR > > Previously, for images with no alt-text, the zoomed image wouldn't get > properly inserted. For images with alt-text, both the zoomed and > unzoomed image would be displayed at once (bug#71666). > > * lisp/net/shr.el (shr-sliced-image): New face. > (shr-zoom-image): Reimplement using > 'next/previous-single-property-change', and don't bother deleting any of > the text. > (shr-image-fetched): Clean up any overlays when deleting the old region. > (shr-put-image): Ensure we always have a non-empty string to put the > image on. For sliced images, just use "*", since we'll repeat it, so we > can't preserve the original buffer text exactly anyway. Apply an > overlay to sliced images to prevent unsightly text decorations. > (shr-tag-img): Move the placeholder space insertion where it should be > and explain what it's doing. > > * test/lisp/net/shr-tests.el (shr-test--max-wait-time) > (shr-test-wait-for): New helper functions. > (shr-test/zoom-image): New test. > --- > lisp/net/shr.el | 94 +++++++++++++++++++++++++--------------------- > test/lisp/net/shr-tests.el | 64 +++++++++++++++++++++++++++++++ > 2 files changed, 116 insertions(+), 42 deletions(-) > > diff --git a/lisp/net/shr.el b/lisp/net/shr.el > index 14b3f7aa163..3dadcb9a09b 100644 > --- a/lisp/net/shr.el > +++ b/lisp/net/shr.el > @@ -282,6 +282,14 @@ temporarily blinks with this face." > "Face used for elements." > :version "29.1") > > +(defface shr-sliced-image > + '((t :underline nil :overline nil)) > + "Face used for sliced images. > +This face should remove any unsightly decorations from sliced images. > +Otherwise, decorations like underlines from links would normally show on > +every slice." > + :version "30.1") > + > (defcustom shr-inhibit-images nil > "If non-nil, inhibit loading images." > :version "28.1" > @@ -600,38 +608,34 @@ the URL of the image to the kill buffer instead." > t)))) > > (defun shr-zoom-image () > - "Toggle the image size. > -The size will be rotated between the default size, the original > -size, and full-buffer size." > + "Cycle the image size. > +The size will cycle through the default size, the original size, and > +full-buffer size." > (interactive) > - (let ((url (get-text-property (point) 'image-url)) > - (size (get-text-property (point) 'image-size)) > - (buffer-read-only nil)) > + (let ((url (get-text-property (point) 'image-url))) > (if (not url) > (message "No image under point") > - ;; Delete the old picture. > - (while (get-text-property (point) 'image-url) > - (forward-char -1)) > - (forward-char 1) > - (let ((start (point))) > - (while (get-text-property (point) 'image-url) > - (forward-char 1)) > - (forward-char -1) > - (put-text-property start (point) 'display nil) > - (when (> (- (point) start) 2) > - (delete-region start (1- (point))))) > - (message "Inserting %s..." url) > - (url-retrieve url #'shr-image-fetched > - (list (current-buffer) (1- (point)) (point-marker) > - (list (cons 'size > - (cond ((or (eq size 'default) > - (null size)) > - 'original) > - ((eq size 'original) > - 'full) > - ((eq size 'full) > - 'default))))) > - t)))) > + (let* ((end (or (next-single-property-change (point) 'image-url) > + (point-max))) > + (start (or (previous-single-property-change end 'image-url) > + (point-min))) > + (size (get-text-property (point) 'image-size)) > + (next-size (cond ((or (eq size 'default) > + (null size)) > + 'original) > + ((eq size 'original) > + 'full) > + ((eq size 'full) > + 'default))) > + (buffer-read-only nil)) > + ;; Delete the old picture. > + (put-text-property start end 'display nil) > + (message "Inserting %s..." url) > + (url-retrieve url #'shr-image-fetched > + `(,(current-buffer) ,start > + ,(set-marker (make-marker) end) > + ((size . ,next-size))) > + t))))) > > ;;; Utility functions. > > @@ -1070,6 +1074,7 @@ the mouse click event." > ;; We don't want to record these changes. > (buffer-undo-list t) > (inhibit-read-only t)) > + (remove-overlays start end) > (delete-region start end) > (goto-char start) > (funcall shr-put-image-function data alt flags) > @@ -1144,7 +1149,8 @@ element is the data blob and the second element > is the content-type." > ;; putting any space after inline images. > ;; ALT may be nil when visiting image URLs in eww > ;; (bug#67764). > - (setq alt (if alt (string-trim alt) "*")) > + (setq alt (string-trim (or alt ""))) > + (when (length= alt 0) (setq alt "*")) > ;; When inserting big-ish pictures, put them at the > ;; beginning of the line. > (let ((inline (shr--inline-image-p image))) > @@ -1153,7 +1159,16 @@ element is the data blob and the second element > is the content-type." > (insert "\n")) > (let ((image-pos (point))) > (if (eq size 'original) > - (insert-sliced-image image alt nil 20 1) > + ;; Normally, we try to keep the buffer text the same > + ;; by preserving ALT. With a sliced image, we have > to > + ;; repeat the text for each line, so we can't do > that. > + ;; Just use "*" for the string to insert instead. > + (progn > + (insert-sliced-image image "*" nil 20 1) > + (let ((overlay (make-overlay start (point)))) > + ;; Avoid displaying unsightly decorations on the > + ;; image slices. > + (overlay-put overlay 'face 'shr-sliced-image))) > (insert-image image alt)) > (put-text-property start (point) 'image-size size) > (when (and (not inline) shr-max-inline-image-size) > @@ -1854,17 +1869,12 @@ The preference is a float determined from > `shr-prefer-media-type'." > (let ((file (url-cache-create-filename url))) > (when (file-exists-p file) > (delete-file file)))) > - (when (image-type-available-p 'svg) > - (insert-image > - (shr-make-placeholder-image dom) > - (or (string-trim alt) ""))) > - ;; Paradoxically this space causes shr not to insert spaces after > - ;; inline images. Since the image is temporary it seem like there > - ;; should be no downside to not inserting it but since I don't > - ;; understand the code well and for the sake of backward > compatibility > - ;; we preserve it unless user has set `shr-max-inline-image-size'. > - (unless shr-max-inline-image-size > - (insert " ")) > + (if (image-type-available-p 'svg) > + (insert-image > + (shr-make-placeholder-image dom) > + (or (string-trim alt) "")) > + ;; No SVG support. Just use a space as our placeholder. > + (insert " ")) > (url-queue-retrieve > url #'shr-image-fetched > (list (current-buffer) start (set-marker (make-marker) (point)) > diff --git a/test/lisp/net/shr-tests.el b/test/lisp/net/shr-tests.el > index 17138053450..b6552674b27 100644 > --- a/test/lisp/net/shr-tests.el > +++ b/test/lisp/net/shr-tests.el > @@ -29,6 +29,22 @@ > > (declare-function libxml-parse-html-region "xml.c") > > +(defvar shr-test--max-wait-time 5 > + "The maximum amount of time to wait for a condition to resolve, in seconds. > +See `shr-test-wait-for'.") > + > +(defun shr-test-wait-for (predicate &optional message) > + "Wait until PREDICATE returns non-nil. > +If this takes longer than `shr-test--max-wait-time', raise an error. > +MESSAGE is an optional message to use if this times out." > + (let ((start (current-time)) > + (message (or message "timed out waiting for condition"))) > + (while (not (funcall predicate)) > + (when (> (float-time (time-since start)) > + shr-test--max-wait-time) > + (error message)) > + (sit-for 0.1)))) > + > (defun shr-test--rendering-check (name &optional context) > "Render NAME.html and compare it to NAME.txt. > Raise a test failure if the rendered buffer does not match NAME.txt. > @@ -68,6 +84,8 @@ validate for the NAME testcase. > The `rendering' testcase will test NAME once without altering any > settings, then once more for each (OPTION . VALUE) pair.") > > +;;; Tests: > + > (ert-deftest rendering () > (skip-unless (fboundp 'libxml-parse-html-region)) > (dolist (file (directory-files (ert-resource-directory) nil > "\\.html\\'")) > @@ -114,6 +132,52 @@ settings, then once more for each (OPTION . VALUE) > pair.") > (should (equal (shr--parse-srcset "https://example.org/1,2\n\n 10w , > https://example.org/2 20w ") > '(("https://example.org/2" 20) ("https://example.org/1,2" > 10))))) > > +(ert-deftest shr-test/zoom-image () > + "Test that `shr-zoom-image' properly replaces the original image." > + (let ((image (expand-file-name "data/image/blank-100x200.png" > + (getenv "EMACS_TEST_DIRECTORY")))) > + (dolist (alt '(nil "" "nothing to see here")) > + (with-temp-buffer > + (ert-info ((format "image with alt=%S" alt)) > + (let ((attrs (if alt (format " alt=\"%s\"" alt) ""))) > + (insert (format " + (cl-letf* (;; Pretend we're a graphical display. > + ((symbol-function 'display-graphic-p) #'always) > + ((symbol-function 'url-queue-retrieve) > + (lambda (&rest args) > + (apply #'run-at-time 0 nil #'url-retrieve args))) > + (put-image-calls 0) > + (shr-put-image-function > + (lambda (&rest args) > + (cl-incf put-image-calls) > + (apply #'shr-put-image args))) > + (shr-width 80) > + (shr-use-fonts nil) > + (shr-image-animate nil) > + (inhibit-message t) > + (dom (libxml-parse-html-region (point-min) (point-max)))) > + ;; Render the document. > + (erase-buffer) > + (shr-insert-document dom) > + (shr-test-wait-for (lambda () (= put-image-calls 1))) > + ;; Now zoom the image. > + (goto-char (point-min)) > + (shr-zoom-image) > + (shr-test-wait-for (lambda () (= put-image-calls 2))) > + ;; Check that we got a sliced image. > + (let ((slice-count 0)) > + (goto-char (point-min)) > + (while (< (point) (point-max)) > + (when-let ((display (get-text-property (point) 'display))) > + ;; If this is nil, we found a non-sliced image, but we > + ;; should have replaced that! > + (should (assq 'slice display)) > + (cl-incf slice-count)) > + (goto-char (or (next-single-property-change (point) 'display) > + (point-max)))) > + ;; Make sure we actually saw a slice. > + (should (> slice-count 1))))))))) > + > (require 'shr) > > ;;; shr-tests.el ends here