bug#45907: [PATCH] Shr memory singularity gif89a

[dick]

Disclaimer: Avoid running this if you need your machine to be up.
emacs -Q --eval "(eww 
\"https://github.com/enphysoft/search-gmail-using-message-id\";)"

>From 7d43e6ed260c7e920b656a21a4876b87b277d81d Mon Sep 17 00:00:00 2001
From: dickmao <none>
Date: Fri, 15 Jan 2021 18:02:44 -0500
Subject: [PATCH] Avoid gif89a explosions

With the increased use of gif89a, my gnus is achieving memory
consumption singularity more frequently.

* lisp/net/shr.el (shr-put-image): When content-type is
application/octet-stream, do not attempt insert-image.
* test/src/xdisp-tests.el (xdisp-tests--window-text-pixel-size,
xdisp-tests--window-text-pixel-size-leading-space,
xdisp-tests--window-text-pixel-size-trailing-space):
`make check` currently fails without conditioning these tests for
graphics display.
---
 lisp/net/shr.el         | 53 ++++++++++++++++++++------------------
 test/src/xdisp-tests.el | 57 ++++++++++++++++++++++-------------------
 2 files changed, 58 insertions(+), 52 deletions(-)

diff --git a/lisp/net/shr.el b/lisp/net/shr.el
index 9c3740fccc..eb69668f32 100644
--- a/lisp/net/shr.el
+++ b/lisp/net/shr.el
@@ -1109,46 +1109,49 @@ shr-put-image
   "Insert image SPEC with a string ALT.  Return image.
 SPEC is either an image data blob, or a list where the first
 element is the data blob and the second element is the content-type."
-  (if (display-graphic-p)
+  (let (image)
+    (when (display-graphic-p)
       (let* ((size (cdr (assq 'size flags)))
             (data (if (consp spec)
                       (car spec)
                     spec))
             (content-type (and (consp spec)
                                (cadr spec)))
-            (start (point))
-            (image (cond
-                    ((eq size 'original)
-                     (create-image data nil t :ascent 100
-                                   :format content-type))
-                    ((eq content-type 'image/svg+xml)
-                      (when (image-type-available-p 'svg)
-                       (create-image data 'svg t :ascent 100)))
-                    ((eq size 'full)
-                     (ignore-errors
-                       (shr-rescale-image data content-type
-                                           (plist-get flags :width)
-                                           (plist-get flags :height))))
-                    (t
-                     (ignore-errors
-                       (shr-rescale-image data content-type
-                                           (plist-get flags :width)
-                                           (plist-get flags :height)))))))
+            (start (point)))
+        (setq image
+              (cond
+              ((eq size 'original)
+               (create-image data nil t :ascent 100
+                             :format content-type))
+              ((eq content-type 'image/svg+xml)
+                (when (image-type-available-p 'svg)
+                 (create-image data 'svg t :ascent 100)))
+               ((eq content-type 'application/octet-stream)
+                nil)
+              ((eq size 'full)
+               (ignore-errors
+                 (shr-rescale-image data content-type
+                                     (plist-get flags :width)
+                                     (plist-get flags :height))))
+              (t
+               (ignore-errors
+                 (shr-rescale-image data content-type
+                                     (plist-get flags :width)
+                                     (plist-get flags :height))))))
         (when image
          ;; When inserting big-ish pictures, put them at the
          ;; beginning of the line.
-         (when (and (> (current-column) 0)
+          (when (and (> (current-column) 0)
                     (> (car (image-size image t)) 400))
            (insert "\n"))
          (if (eq size 'original)
              (insert-sliced-image image (or alt "*") nil 20 1)
            (insert-image image (or alt "*")))
-         (put-text-property start (point) 'image-size size)
-         (when (and shr-image-animate
+          (put-text-property start (point) 'image-size size)
+          (when (and shr-image-animate
                      (cdr (image-multi-frame-p image)))
-            (image-animate image nil 60)))
-       image)
-    (insert (or alt ""))))
+            (image-animate image nil 60)))))
+    (or image (insert (or alt "")))))
 
 (defun shr--image-type ()
   "Emacs image type to use when displaying images.
diff --git a/test/src/xdisp-tests.el b/test/src/xdisp-tests.el
index ec96d777ff..de92d26ef8 100644
--- a/test/src/xdisp-tests.el
+++ b/test/src/xdisp-tests.el
@@ -72,34 +72,37 @@ xdisp-tests--minibuffer-scroll
     (should (equal (nth 0 posns) (nth 1 posns)))
     (should (equal (nth 1 posns) (nth 2 posns)))))
 
-(ert-deftest xdisp-tests--window-text-pixel-size () ;; bug#45748
-  (with-temp-buffer
-    (insert "xxx")
-    (let* ((window
-            (display-buffer (current-buffer) '(display-buffer-in-child-frame . 
nil)))
-          (char-width (frame-char-width))
-          (size (window-text-pixel-size nil t t)))
-      (delete-frame (window-frame window))
-      (should (equal (/ (car size) char-width) 3)))))
+(when (display-graphic-p)
+  (ert-deftest xdisp-tests--window-text-pixel-size () ;; bug#45748
+    (with-temp-buffer
+      (insert "xxx")
+      (let* ((window
+              (display-buffer (current-buffer) '(display-buffer-in-child-frame 
. nil)))
+             (char-width (frame-char-width))
+             (size (window-text-pixel-size nil t t)))
+        (delete-frame (window-frame window))
+        (should (equal (/ (car size) char-width) 3))))))
 
-(ert-deftest xdisp-tests--window-text-pixel-size-leading-space () ;; bug#45748
-  (with-temp-buffer
-    (insert " xx")
-    (let* ((window
-            (display-buffer (current-buffer) '(display-buffer-in-child-frame . 
nil)))
-          (char-width (frame-char-width))
-          (size (window-text-pixel-size nil t t)))
-      (delete-frame (window-frame window))
-      (should (equal (/ (car size) char-width) 3)))))
+(when (display-graphic-p)
+  (ert-deftest xdisp-tests--window-text-pixel-size-leading-space () ;; 
bug#45748
+    (with-temp-buffer
+      (insert " xx")
+      (let* ((window
+              (display-buffer (current-buffer) '(display-buffer-in-child-frame 
. nil)))
+             (char-width (frame-char-width))
+             (size (window-text-pixel-size nil t t)))
+        (delete-frame (window-frame window))
+        (should (equal (/ (car size) char-width) 3))))))
 
-(ert-deftest xdisp-tests--window-text-pixel-size-trailing-space () ;; bug#45748
-  (with-temp-buffer
-    (insert "xx ")
-    (let* ((window
-            (display-buffer (current-buffer) '(display-buffer-in-child-frame . 
nil)))
-          (char-width (frame-char-width))
-          (size (window-text-pixel-size nil t t)))
-      (delete-frame (window-frame window))
-      (should (equal (/ (car size) char-width) 3)))))
+(when (display-graphic-p)
+  (ert-deftest xdisp-tests--window-text-pixel-size-trailing-space () ;; 
bug#45748
+    (with-temp-buffer
+      (insert "xx ")
+      (let* ((window
+              (display-buffer (current-buffer) '(display-buffer-in-child-frame 
. nil)))
+             (char-width (frame-char-width))
+             (size (window-text-pixel-size nil t t)))
+        (delete-frame (window-frame window))
+        (should (equal (/ (car size) char-width) 3))))))
 
 ;;; xdisp-tests.el ends here
-- 
2.26.2



In GNU Emacs 27.1.50 (build 1, x86_64-pc-linux-gnu, GTK+ Version 3.22.30)
 of 2020-12-08 built on dick
Repository revision: 8e7325909363affe27c36d1181b60a625ea04d23
Repository branch: emacs-27
Windowing system distributor 'The X.Org Foundation', version 11.0.11906000
System Description: Ubuntu 18.04.4 LTS

Recent messages:
Auto-saving...done
Mark set
Auto-saving...done
Mark saved where search started [2 times]
No ChangeLog data at point
Auto-saving...done
Mark set [2 times]
Saving file /home/dick/emacs/.git/COMMIT_EDITMSG...
Wrote /home/dick/emacs/.git/COMMIT_EDITMSG
Git finished

Configured using:
 'configure --prefix=/home/dick/.local --with-rsvg=yes --with-xml2=yes'

Configured features:
XPM JPEG TIFF GIF PNG RSVG SOUND DBUS GSETTINGS GLIB NOTIFY INOTIFY LIBSELINUX
GNUTLS LIBXML2 FREETYPE HARFBUZZ XFT ZLIB TOOLKIT_SCROLL_BARS GTK3 X11 XDBE
XIM MODULES THREADS JSON PDUMPER GMP

Important settings:
  value of $LANG: en_US.UTF-8
  locale-coding-system: utf-8-unix

Major mode: Diff

Minor modes in effect:
  whitespace-mode: t
  jupyter-repl-persistent-mode: t
  show-paren-mode: t
  global-magit-file-mode: t
  magit-file-mode: t
  magit-auto-revert-mode: t
  global-git-commit-mode: t
  async-bytecomp-package-mode: t
  flx-ido-mode: t
  projectile-mode: t
  override-global-mode: t
  pyvenv-mode: t
  shell-dirtrack-mode: t
  ido-everywhere: t
  beacon-mode: t
  global-hl-line-mode: t
  winner-mode: t
  cl-old-struct-compat-mode: t
  tooltip-mode: t
  global-eldoc-mode: t
  mouse-wheel-mode: t
  file-name-shadow-mode: t
  global-font-lock-mode: t
  font-lock-mode: t
  blink-cursor-mode: t
  auto-composition-mode: t
  auto-encryption-mode: t
  auto-compression-mode: t
  column-number-mode: t
  line-number-mode: t
  transient-mark-mode: t

Load-path shadows:
/home/dick/ESS/lisp/obsolete/ess-swv hides /home/dick/ESS/lisp/ess-swv
/home/dick/ESS/lisp/obsolete/ess-rutils hides /home/dick/ESS/lisp/ess-rutils
/home/dick/ESS/lisp/obsolete/ess-noweb hides /home/dick/ESS/lisp/ess-noweb
/home/dick/ESS/lisp/obsolete/mouseme hides /home/dick/ESS/lisp/mouseme
/home/dick/ESS/lisp/obsolete/ess-mouse hides /home/dick/ESS/lisp/ess-mouse
/home/dick/ESS/lisp/obsolete/ess-noweb-mode hides 
/home/dick/ESS/lisp/ess-noweb-mode
/home/dick/ESS/lisp/obsolete/make-regexp hides /home/dick/ESS/lisp/make-regexp
/home/dick/ESS/lisp/obsolete/ess-r-a hides /home/dick/ESS/lisp/ess-r-a
/home/dick/ESS/lisp/obsolete/ess-noweb-font-lock-mode hides 
/home/dick/ESS/lisp/ess-noweb-font-lock-mode
/home/dick/gomacro-mode/gomacro-mode hides 
/home/dick/.emacs.d/elpa/gomacro-mode-20200326.1103/gomacro-mode
/home/dick/ESS/lisp/julia-mode-latexsubs hides 
/home/dick/.emacs.d/elpa/julia-mode-20200717.1915/julia-mode-latexsubs
/home/dick/ESS/lisp/julia-mode hides 
/home/dick/.emacs.d/elpa/julia-mode-20200717.1915/julia-mode
/home/dick/.emacs.d/elpa/hydra-20170924.2259/lv hides 
/home/dick/.emacs.d/elpa/lv-20191106.1238/lv
/home/dick/melpa-stats/melpa-stats hides 
/home/dick/.emacs.d/elpa/melpa-stats-20190720.1833/melpa-stats
/home/dick/.emacs.d/elpa/async-20200113.1745/async-autoloads hides 
/home/dick/.local/share/emacs/site-lisp/emacs-async/async-autoloads
/home/dick/.emacs.d/elpa/async-20200113.1745/async-bytecomp hides 
/home/dick/.local/share/emacs/site-lisp/emacs-async/async-bytecomp
/home/dick/.emacs.d/elpa/async-20200113.1745/smtpmail-async hides 
/home/dick/.local/share/emacs/site-lisp/emacs-async/smtpmail-async
/home/dick/.emacs.d/elpa/async-20200113.1745/dired-async hides 
/home/dick/.local/share/emacs/site-lisp/emacs-async/dired-async
/home/dick/.emacs.d/elpa/async-20200113.1745/async hides 
/home/dick/.local/share/emacs/site-lisp/emacs-async/async
/home/dick/.emacs.d/elpa/async-20200113.1745/async-pkg hides 
/home/dick/.local/share/emacs/site-lisp/emacs-async/async-pkg
/home/dick/.emacs.d/lisp/json hides 
/home/dick/.local/share/emacs/27.1.50/lisp/json
/home/dick/.emacs.d/elpa/map-2.1/map hides 
/home/dick/.local/share/emacs/27.1.50/lisp/emacs-lisp/map

Features:
(shadow sort flyspell ispell footnote mail-extr gnus-msg gnus-art mm-uu
mml2015 mm-view mml-smime smime dig emacsbug sendmail whitespace git-rebase
loadhist emms-source-file locate flycheck let-alist go-eldoc gomacro-mode
go-mode find-file magit-extras ert rect completion timezone ob-python
mule-util image-file cursor-sensor vc-bzr vc-src vc-sccs vc-cvs vc-rcs
sgml-mode sh-script executable markdown-mode edit-indirect jupyter-python
jupyter-zmq-channel-ioloop jupyter-channel-ioloop-comm jupyter-channel-ioloop
jupyter-ioloop-comm jupyter-ioloop jupyter-zmq-channel zmq zmq-core
jupyter-kernel-process-manager edebug dired-aux ein-ipynb-mode js ein-process
ein-jupyter exec-path-from-shell ein-dev ein-notebook ein-gat ein-python-send
ein-traceback ein-shared-output ein-pytools ein-pager view ein-completer
ein-notification ein-scratchsheet ein-worksheet poly-ein display-line-numbers
ein-kill-ring ein-kernelinfo ein-file ein-notebooklist ein-contents-api
goto-addr ag vc-svn find-dired poly-rst rst polymode poly-lock polymode-base
polymode-weave polymode-export polymode-compat polymode-methods polymode-core
polymode-classes eieio-custom vc vc-dispatcher face-remap ivy delsel colir
ivy-overlay ffap eieio-opt speedbar sb-image ezimage dframe make-mode
tramp-archive tramp-gvfs zeroconf dbus pulse dumb-jump f help-fns radix-tree
cl-print debug backtrace org-element avl-tree ol-eww ol-rmail ol-mhe ol-irc
ol-info ol-gnus nnir gnus-sum gnus-group gnus-undo gnus-start gnus-cloud
nnimap nnmail mail-source utf7 netrc nnoo gnus-spec gnus-int gnus-range
gnus-win ol-docview doc-view jka-compr image-mode exif ol-bibtex bibtex
ol-bbdb ol-w3m org-tempo tempo org org-macro org-footnote org-pcomplete
org-list org-faces org-entities org-version ob-R ob-jupyter
jupyter-org-extensions jupyter-org-client jupyter-repl jupyter-kernel-manager
jupyter-channel jupyter-widget-client simple-httpd jupyter-client
jupyter-comm-layer jupyter-messages hmac-def jupyter-mime jupyter-kernelspec
jupyter-env jupyter-base eieio-base ob-emacs-lisp ob-ein ein-cell
ein-output-area shr svg dom ein-kernel ein-ipdb ein-query ein-events
ein-websocket websocket bindat ein-node ewoc ein-log ein-classes ein-core
request ein-utils deferred ob ob-tangle org-src ob-ref ob-lob ob-table ob-exp
ob-comint ob-core ob-eval org-table ol org-keys org-compat org-macs
org-loaddefs find-func cal-menu calendar cal-loaddefs network-stream url-http
url-gw nsm url-cache url-auth misearch multi-isearch vc-git bug-reference
google-c-style cc-mode cc-fonts cc-guess cc-menus cc-cmds cc-styles cc-align
cc-engine cc-vars cc-defs paredit-ext paredit ein dired-x inf-ruby ruby-mode
smie melpa-stats ht dash-functional anaphora a pp sx key-combo company
haskell-interactive-mode haskell-presentation-mode haskell-process
haskell-session haskell-compile haskell-mode haskell-cabal haskell-utils
haskell-font-lock haskell-indentation haskell-string haskell-sort-imports
haskell-lexeme rx haskell-align-imports haskell-complete-module
haskell-ghc-support dabbrev haskell-customize hydra lv use-package-ensure
paren magit-patch-changelog magit-patch magit-submodule magit-obsolete
magit-popup magit-blame magit-stash magit-reflog magit-bisect magit-push
magit-pull magit-fetch magit-clone magit-remote magit-commit magit-sequence
magit-notes magit-worktree magit-tag magit-merge magit-branch magit-reset
magit-files magit-refs magit-status magit magit-repos magit-apply magit-wip
magit-log which-func imenu magit-diff smerge-mode diff magit-core
magit-autorevert autorevert filenotify magit-margin magit-transient
magit-process magit-mode git-commit transient magit-git magit-section
magit-utils crm log-edit message rmc dired dired-loaddefs rfc822 mml mml-sec
mm-decode mm-bodies mm-encode mail-parse rfc2231 mailabbrev gmm-utils
mailheader pcvs-util add-log with-editor async-bytecomp async pcase server
dash flx-ido flx solarized-theme solarized-definitions projectile ibuf-ext
ibuffer ibuffer-loaddefs gnus nnheader gnus-util rmail rmail-loaddefs rfc2047
rfc2045 ietf-drums text-property-search mail-utils mm-util mail-prsvr
google-translate-default-ui google-translate-core-ui color
google-translate-core google-translate-tk google-translate-backend
use-package-bind-key bind-key auto-complete popup ess-r-mode ess-r-flymake
flymake-proc flymake warnings thingatpt ess-r-xref ess-trns ess-r-package
ess-r-completion ess-roxy ess-r-syntax ess-rd noutline outline hideshow
ess-s-lang ess-help ess-mode ess-inf ess-tracebug ess ess-utils ess-custom
emms-player-mplayer emms-player-simple emms emms-compat twittering-mode epa
derived epg epg-config tls gnutls puny url url-proxy url-privacy url-expand
url-methods url-history url-cookie url-domsuf url-util mailcap xml cl fzf elpy
advice elpy-rpc pyvenv eshell esh-cmd esh-ext esh-opt esh-proc esh-io esh-arg
esh-module esh-groups esh-util elpy-shell elpy-profile elpy-django s
elpy-refactor diff-mode easy-mmode python tramp-sh tramp tramp-loaddefs
trampver tramp-integration tramp-compat shell pcomplete parse-time iso8601
time-date ls-lisp format-spec ido grep compile comint ansi-color files-x etags
fileloop generator xref project cus-edit cus-start cus-load wid-edit cl-extra
help-mode use-package-core beacon hl-line winner ring finder-inf
howdoyou-autoloads json-reformat-autoloads json-snatcher-autoloads edmacro
kmacro sml-mode-autoloads tornado-template-mode-autoloads info package
easymenu browse-url url-handlers url-parse auth-source cl-seq eieio eieio-core
cl-macs eieio-loaddefs password-cache json subr-x map url-vars seq byte-opt gv
bytecomp byte-compile cconv cl-loaddefs cl-lib tooltip eldoc electric uniquify
ediff-hook vc-hooks lisp-float-type mwheel term/x-win x-win term/common-win
x-dnd tool-bar dnd fontset image regexp-opt fringe tabulated-list replace
newcomment text-mode elisp-mode lisp-mode prog-mode register page tab-bar
menu-bar rfn-eshadow isearch timer select scroll-bar mouse jit-lock font-lock
syntax facemenu font-core term/tty-colors frame minibuffer cl-generic cham
georgian utf-8-lang misc-lang vietnamese tibetan thai tai-viet lao korean
japanese eucjp-ms cp51932 hebrew greek romanian slovak czech european ethiopic
indian cyrillic chinese composite charscript charprop case-table epa-hook
jka-cmpr-hook help simple abbrev obarray cl-preloaded nadvice loaddefs button
faces cus-face macroexp files text-properties overlay sha1 md5 base64 format
env code-pages mule custom widget hashtable-print-readable backquote threads
dbusbind inotify dynamic-setting system-font-setting font-render-setting
move-toolbar gtk x-toolkit x multi-tty make-network-process emacs)

Memory information:
((conses 16 1386698 198163)
 (symbols 48 64718 34)
 (strings 32 252337 33235)
 (string-bytes 1 8883059)
 (vectors 16 133645)
 (vector-slots 8 3381503 289432)
 (floats 8 770 3242)
 (intervals 56 71497 1958)
 (buffers 1000 129))