1 files changed, 75 insertions, 14 deletions
diff --git a/lisp/emacs-lisp/subr-x.el b/lisp/emacs-lisp/subr-x.el
index 2fa0652bc5c..4ce7bd00f31 100644
--- a/lisp/emacs-lisp/subr-x.el
+++ b/lisp/emacs-lisp/subr-x.el
@@ -336,10 +336,61 @@ This construct can only be used with lexical binding."
       (cl-labels ((,name ,fargs . ,body)) #',name)
       . ,aargs)))
 
+(defvar work-buffer--list nil)
+(defvar work-buffer-limit 10
+  "Maximum number of reusable work buffers.
+When this limit is exceeded, newly allocated work buffers are
+automatically killed, which means that in a such case
+`with-work-buffer' becomes equivalent to `with-temp-buffer'.")
+
+(defsubst work-buffer--get ()
+  "Get a work buffer."
+  (let ((buffer (pop work-buffer--list)))
+    (if (buffer-live-p buffer)
+        buffer
+      (generate-new-buffer " *work*" t))))
+
+(defun work-buffer--release (buffer)
+  "Release work BUFFER."
+  (if (buffer-live-p buffer)
+      (with-current-buffer buffer
+        ;; Flush BUFFER before making it available again, i.e. clear
+        ;; its contents, remove all overlays and buffer-local
+        ;; variables.  Is it enough to safely reuse the buffer?
+        (let ((inhibit-read-only t)
+              ;; Avoid deactivating the region as side effect.
+              deactivate-mark)
+          (erase-buffer))
+        (delete-all-overlays)
+        (let (change-major-mode-hook)
+          (kill-all-local-variables t))
+        ;; Make the buffer available again.
+        (push buffer work-buffer--list)))
+  ;; If the maximum number of reusable work buffers is exceeded, kill
+  ;; work buffer in excess, taking into account that the limit could
+  ;; have been let-bound to temporarily increase its value.
+  (when (> (length work-buffer--list) work-buffer-limit)
+    (mapc #'kill-buffer (nthcdr work-buffer-limit work-buffer--list))
+    (setq work-buffer--list (ntake work-buffer-limit work-buffer--list))))
+
 ;;;###autoload
-(defun string-pixel-width (string)
-  "Return the width of STRING in pixels.
+(defmacro with-work-buffer (&rest body)
+  "Create a work buffer, and evaluate BODY there like `progn'.
+Like `with-temp-buffer', but reuse an already created temporary
+buffer when possible, instead of creating a new one on each call."
+  (declare (indent 0) (debug t))
+  (let ((work-buffer (make-symbol "work-buffer")))
+    `(let ((,work-buffer (work-buffer--get)))
+       (with-current-buffer ,work-buffer
+         (unwind-protect
+             (progn ,@body)
+           (work-buffer--release ,work-buffer))))))
 
+;;;###autoload
+(defun string-pixel-width (string &optional buffer)
+  "Return the width of STRING in pixels.
+If BUFFER is non-nil, use the face remappings from that buffer when
+determining the width.
 If you call this function to measure pixel width of a string
 with embedded newlines, it returns the width of the widest
 substring that does not include newlines."
@@ -348,15 +399,26 @@ substring that does not include newlines."
       0
     ;; Keeping a work buffer around is more efficient than creating a
     ;; new temporary buffer.
-    (with-current-buffer (get-buffer-create " *string-pixel-width*")
-      ;; If `display-line-numbers' is enabled in internal buffers
-      ;; (e.g. globally), it breaks width calculation (bug#59311)
-      (setq-local display-line-numbers nil)
-      (delete-region (point-min) (point-max))
-      ;; Disable line-prefix and wrap-prefix, for the same reason.
-      (setq line-prefix nil
-	    wrap-prefix nil)
-      (insert (propertize string 'line-prefix nil 'wrap-prefix nil))
+    (with-work-buffer
+      (if buffer
+          (setq-local face-remapping-alist
+                      (with-current-buffer buffer
+                        face-remapping-alist))
+        (kill-local-variable 'face-remapping-alist))
+      ;; Avoid deactivating the region as side effect.
+      (let (deactivate-mark)
+        (insert string))
+      ;; If `display-line-numbers' is enabled in internal
+      ;; buffers (e.g. globally), it breaks width calculation
+      ;; (bug#59311).  Disable `line-prefix' and `wrap-prefix',
+      ;; for the same reason.
+      (add-text-properties
+       (point-min) (point-max) '(display-line-numbers-disable t))
+      ;; Prefer `remove-text-properties' to `propertize' to avoid
+      ;; creating a new string on each call.
+      (remove-text-properties
+       (point-min) (point-max) '(line-prefix nil wrap-prefix nil))
+      (setq line-prefix nil wrap-prefix nil)
       (car (buffer-text-pixel-size nil nil t)))))
 
 ;;;###autoload
@@ -418,7 +480,7 @@ this defaults to the current buffer."
                  (t
                   disp)))
           ;; Remove any old instances.
-          (when-let ((old (assoc prop disp)))
+          (when-let* ((old (assoc prop disp)))
             (setq disp (delete old disp)))
           (setq disp (cons (list prop value) disp))
           (when vector
@@ -489,8 +551,7 @@ as changes in text properties, `buffer-file-coding-system', buffer
 multibyteness, etc. -- will not be noticed, and the buffer will still
 be marked unmodified, effectively ignoring those changes."
   (declare (debug t) (indent 0))
-  (let ((hash (gensym))
-        (buffer (gensym)))
+  (cl-with-gensyms (hash buffer)
     `(let ((,hash (and (not (buffer-modified-p))
                        (buffer-hash)))
            (,buffer (current-buffer)))