>From bb9850eee9e44555a67f8e838b12e315c0085f38 Mon Sep 17 00:00:00 2001 From: "F. Jason Park" Date: Tue, 16 Nov 2021 06:28:25 -0800 Subject: [PATCH 1/1] Add command to refill ERC buffers * lisp/erc/erc-fill.el (erc-fill-buffer, erc-fill--refill, erc-fill--refill-thread, erc-fill--remove-stamp-{left,right}, erc-fill--hack-csf): Add new command and helpers to refill ERC buffers. * lisp/erc/erc-fill-tests.el: Add new file containing tests for `erc-fill-buffer'. Add some support files to test against in lisp/erc/erc-fill-resources. --- lisp/erc/erc-fill.el | 115 ++++++++++ .../erc/erc-fill-resources/static-60.buffer | 21 ++ .../erc/erc-fill-resources/static-72.buffer | 17 ++ .../erc/erc-fill-resources/variable-60.buffer | 16 ++ .../erc/erc-fill-resources/variable-72.buffer | 16 ++ test/lisp/erc/erc-fill-tests.el | 206 ++++++++++++++++++ 6 files changed, 391 insertions(+) create mode 100644 test/lisp/erc/erc-fill-resources/static-60.buffer create mode 100644 test/lisp/erc/erc-fill-resources/static-72.buffer create mode 100644 test/lisp/erc/erc-fill-resources/variable-60.buffer create mode 100644 test/lisp/erc/erc-fill-resources/variable-72.buffer create mode 100644 test/lisp/erc/erc-fill-tests.el diff --git a/lisp/erc/erc-fill.el b/lisp/erc/erc-fill.el index 9f29b9dad9..3bf335d098 100644 --- a/lisp/erc/erc-fill.el +++ b/lisp/erc/erc-fill.el @@ -112,6 +112,121 @@ erc-fill-column "The column at which a filled paragraph is broken." :type 'integer) +(defun erc-fill--remove-stamp-right () + (goto-char (point-min)) + (let (changed) + (while + (when-let* ((nextf (next-single-property-change (point) 'field))) + (goto-char (field-end nextf t)) + ;; Sweep up residual phantom field remants + (delete-region nextf (field-end nextf t)) + (setq changed t))) + changed)) + +(defun erc-fill--remove-stamp-left () + "Remove at most one LEFT or one right timestamp, if any." + (goto-char (point-min)) + ;; FIXME actually, it may be a mistake to blow past white space + ;; without checking for intervening intervals that need cleaning up. + (when-let* ((beg (save-excursion (skip-syntax-forward ">-") (point))) + (nextf (when (eq 'erc-timestamp (field-at-pos beg)) + (field-beginning beg t))) + ((eq 'erc-timestamp (get-text-property nextf 'field)))) + (goto-char (field-end nextf t)) + (skip-syntax-forward "-") + (delete-region nextf (point)) + t)) + +(defun erc-fill--hack-csf (f) + ;; HACK until necessary additions to erc-stamp.el arrive (possibly + ;; with erc-v3 in #49860), there's no civilized way of detecting the + ;; bounds of a displayed message after initial insertion. + ;; + ;; These callback closures are used for that purpose, but they also + ;; contain the timestamp we need. An unforeseen benefit of this + ;; awkwardness is that it plays well with `text-property-not-all', + ;; which needs unique values to match against. That wouldn't be the + ;; case were we to use lisp time objects instead because successive + ;; messages might contain the exact same one. + (if (byte-code-function-p f) (aref (aref f 2) 0) (alist-get 'ct (cadr f)))) + +;; Enabling `erc-fill-mode' is ultimately destructive to preformatted +;; text (like ASCII art and figlets), which degenerate immediately +;; upon display. This is permanent because we don't store original +;; messages (though with IRCv3, it may be possible to request a +;; replacement from the server). +(defun erc-fill--refill () + (let ((m (make-marker)) + (reporter (unless noninteractive + (make-progress-reporter "filling" 0 (point-max)))) + (inhibit-read-only t) + (inhibit-point-motion-hooks t) + ;; + left-changed right-changed ct) ; cached current time + (cl-letf (((symbol-function #'erc-restore-text-properties) #'ignore) + ((symbol-function #'current-time) (lambda () ct))) + (while + (save-excursion + (goto-char (or (marker-position m) (set-marker m (point-min)))) + (when-let* + ((beg (if (get-text-property (point) 'cursor-sensor-functions) + (point) + (when-let* + ((max (min (point-max) (+ 512 (point)))) + (res (next-single-property-change + (point) 'cursor-sensor-functions nil max)) + ((/= res max))) ; otherwise, we're done. + res))) + (val (get-text-property beg 'cursor-sensor-functions)) + (beg (progn ; remove left padding, if any. + (goto-char beg) + (skip-syntax-forward "-") + (delete-region (min (line-beginning-position) beg) + (point)) + (point))) + ;; Don't expect output limited to IRC message length. + (end (text-property-not-all beg (point-max) + 'cursor-sensor-functions val))) + (save-restriction + (narrow-to-region beg end) + (setq left-changed (erc-fill--remove-stamp-left)) + ;; If NOSQUEEZE seems warranted, see note above. + (let ((fill-column (- (point-max) (point-min)))) + (fill-region (point-min) (point-max))) + (setq right-changed (erc-fill--remove-stamp-right)) + (erc-fill) + (when (setq ct (when (or left-changed right-changed) + (erc-fill--hack-csf (car val)))) + (when left-changed + (setq erc-timestamp-last-inserted-left nil)) + (when right-changed + (setq erc-timestamp-last-inserted-right nil)) + (erc-add-timestamp)) + (when reporter + (cl-incf (aref (cdr reporter) 2) ; max += d_new - d_old + (- (point-max) (point-min) end (- beg)))) + (set-marker m (goto-char (point-max)))))) + (when reporter + (progress-reporter-update reporter (point))) + (thread-yield))))) + +(defvar-local erc-fill--refill-thread nil + "A thread running a buffer-refill job.") + +(define-error 'erc-fill-canceled "ERC refill canceled" 'error) + +(defun erc-fill-buffer (force) + "Refill an ERC buffer. +With FORCE, cancel an active refill job if one exists." + (interactive "P") + (when (and erc-fill--refill-thread + (thread-live-p erc-fill--refill-thread)) + (if force + (thread-signal erc-fill--refill-thread + 'erc-fill-canceled (list (buffer-name))) + (user-error "Already refilling."))) + (setq erc-fill--refill-thread (make-thread #'erc-fill--refill "erc-fill"))) + ;;;###autoload (defun erc-fill () "Fill a region using the function referenced in `erc-fill-function'. diff --git a/test/lisp/erc/erc-fill-resources/static-60.buffer b/test/lisp/erc/erc-fill-resources/static-60.buffer new file mode 100644 index 0000000000..b33f11ae96 --- /dev/null +++ b/test/lisp/erc/erc-fill-resources/static-60.buffer @@ -0,0 +1,21 @@ + + + +[Tue Jan 1 1980] + *** #chan modes: +nt [00:00] + *** #chan was created on 2021-05-04 + 05:06:19 + lorem ipsum This buffer is for + text that is not saved, and for + Lisp evaluation. [00:01] + tester, welcome! Your name may or + may not be highlighted depending + on whether button's been loaded + by an earlier test. ERC needs + help! [00:03] + +[Wed Jan 2 1980] + tester, welcome! To create a + file, visit it with ? and enter + text in its buffer. +ERC> \ No newline at end of file diff --git a/test/lisp/erc/erc-fill-resources/static-72.buffer b/test/lisp/erc/erc-fill-resources/static-72.buffer new file mode 100644 index 0000000000..79ed88d112 --- /dev/null +++ b/test/lisp/erc/erc-fill-resources/static-72.buffer @@ -0,0 +1,17 @@ + + + +[Tue Jan 1 1980] + *** #chan modes: +nt [00:00] + *** #chan was created on 2021-05-04 05:06:19 + lorem ipsum This buffer is for text that is + not saved, and for Lisp evaluation. [00:01] + tester, welcome! Your name may or may not be + highlighted depending on whether button's + been loaded by an earlier test. ERC needs + help! [00:03] + +[Wed Jan 2 1980] + tester, welcome! To create a file, visit it + with ? and enter text in its buffer. +ERC> \ No newline at end of file diff --git a/test/lisp/erc/erc-fill-resources/variable-60.buffer b/test/lisp/erc/erc-fill-resources/variable-60.buffer new file mode 100644 index 0000000000..4bf2741af0 --- /dev/null +++ b/test/lisp/erc/erc-fill-resources/variable-60.buffer @@ -0,0 +1,16 @@ + + + +[Tue Jan 1 1980] +*** #chan modes: +nt [00:00] +*** #chan was created on 2021-05-04 05:06:19 + lorem ipsum This buffer is for text that is not saved, + and for Lisp evaluation. [00:01] + tester, welcome! Your name may or may not be + highlighted depending on whether button's been + loaded by an earlier test. ERC needs help! [00:03] + +[Wed Jan 2 1980] + tester, welcome! To create a file, visit it with ? and + enter text in its buffer. +ERC> \ No newline at end of file diff --git a/test/lisp/erc/erc-fill-resources/variable-72.buffer b/test/lisp/erc/erc-fill-resources/variable-72.buffer new file mode 100644 index 0000000000..de376cc15d --- /dev/null +++ b/test/lisp/erc/erc-fill-resources/variable-72.buffer @@ -0,0 +1,16 @@ + + + +[Tue Jan 1 1980] +*** #chan modes: +nt [00:00] +*** #chan was created on 2021-05-04 05:06:19 + lorem ipsum This buffer is for text that is not saved, and for + Lisp evaluation. [00:01] + tester, welcome! Your name may or may not be highlighted + depending on whether button's been loaded by an earlier + test. ERC needs help! [00:03] + +[Wed Jan 2 1980] + tester, welcome! To create a file, visit it with ? and enter text + in its buffer. +ERC> \ No newline at end of file diff --git a/test/lisp/erc/erc-fill-tests.el b/test/lisp/erc/erc-fill-tests.el new file mode 100644 index 0000000000..a7e3d78d74 --- /dev/null +++ b/test/lisp/erc/erc-fill-tests.el @@ -0,0 +1,206 @@ +;;; erc-fill-tests.el --- ERC message filling -*- lexical-binding: t -*- + +;; Copyright (C) 2020-2021 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-x) +(require 'erc-fill) + +(defun erc-fill-tests--insert (&rest strings) + (let ((inhibit-read-only t)) + (erc-parse-server-response erc-server-process (apply #'concat strings)))) + +(defun erc-fill-tests--setup-server-buffer () + (with-current-buffer (get-buffer-create "foonet") + (erc-mode) + (setq erc-server-process (start-process "true" (current-buffer) "true") + erc-server-current-nick "tester" + erc-server-users (make-hash-table :test #'equal)) + (set-process-query-on-exit-flag erc-server-process nil))) + +(defun erc-fill-tests--setup-channel-buffer () + (with-current-buffer (get-buffer-create "#chan") + (erc-mode) + (insert "\n\n") + (setq erc-input-marker (make-marker) + ;; Kludge to get around saving display prop + erc-timestamp-use-align-to nil + ;; Kludge to make whitespace compare equal without expanding + indent-tabs-mode nil + erc-insert-marker (make-marker) + erc-default-recipients '("#chan") + erc-channel-users (make-hash-table :test #'equal) + erc-server-process (with-current-buffer "foonet" + erc-server-process)) + (set-marker erc-insert-marker (point-max)) + (erc-display-prompt))) + +(defun erc-fill-tests--setup () + (advice-add 'format-time-string :filter-args + (lambda (args) (list (car args) (cadr args) 0)) '((name . ts))) + + (erc-stamp-mode +1) + + (erc-fill-tests--setup-server-buffer) + (erc-fill-tests--setup-channel-buffer) + (erc-fill-tests--populate)) + +(defun erc-fill-tests--populate () + (let* ((ts (+ (* 2 60 60 24) (* 60 60 24 365 10))) ; Jan 1 1980 + (ct (time-convert ts))) + + (cl-letf (((symbol-function 'current-time) (lambda () ct))) + (with-current-buffer "foonet" + (erc-fill-tests--insert ":irc.foonet.org 324 tester #chan +nt") + (erc-fill-tests--insert ":irc.foonet.org 329 tester #chan 1620104779") + + (setq ct (time-convert (cl-incf ts 60))) + (erc-fill-tests--insert + ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :lorem ipsum" + " This buffer is for text that is not saved, and for Lisp evaluation.") + + (setq ct (time-convert (cl-incf ts 120))) + (erc-fill-tests--insert + ":alice!~u@rz2v467q4rwhy.irc PRIVMSG #chan :tester, welcome!" + " Your name may or may not be highlighted depending on whether" + " button's been loaded by an earlier test. ERC needs help!") + + (setq ct (time-convert (cl-incf ts (* 60 60 24)))) + (erc-fill-tests--insert + ":bob!~u@rz2v467q4rwhy.irc PRIVMSG #chan :tester, welcome!" + " To create a file, visit it with ? and enter text in its buffer."))))) + +(defun erc-fill-tests--teardown () + ;; XXX when inspecting manually, must reactivate fill and stamp modes. + ;; Otherwise `erc-fill-buffer' won't work. + (dolist (buf '("variable-60.buffer" + "variable-72.buffer" + "static-60.buffer" + "static-72.buffer")) + (when (buffer-live-p buf) + (kill-buffer buf))) + (advice-remove 'format-time-string 'ts) + (let (erc-kill-server-hook + erc-kill-channel-hook) + (kill-buffer "#chan") + (kill-buffer "foonet")) + (should (= erc-fill-column 78))) + +(defun erc-fill-tests--compare (name) + ;; Git didn't allow committing with a trailing space after the + ;; prompt, hence this: + (equal (substring-no-properties (buffer-string) 0 -1) + (with-current-buffer (find-file-literally (ert-resource-file name)) + (buffer-string)))) + +(defun erc-fill-tests--await-fill () + (call-interactively #'erc-fill-buffer) + ;; This timeout silliness seemed a little more realistic than just: + ;; + ;; (thread-join erc-fill--refill-thread) + ;; + ;; Probably dumb, right?. + (with-timeout (3 (error "Failed")) + (while (thread-live-p erc-fill--refill-thread) + (sleep-for 0.01)))) + +(ert-deftest erc-fill-buffer () + (let* (erc-insert-pre-hook + erc-insert-modify-hook + erc-send-modify-hook + erc-mode-hook + erc-stamp-mode + erc-fill--refill-thread) + + (erc-fill-tests--setup) + + (with-current-buffer "#chan" + ;; These would get clobbered by the new thread if we let-bound + ;; them, and we can't set them globally, so best just fake it: + (setq-local erc-fill-mode t + erc-stamp-mode t + erc-fill-column 60) + (erc-fill-tests--await-fill) + (ert-info ("Baseline") + (should (erc-fill-tests--compare "variable-60.buffer"))) + + (ert-info ("Wider") + (setq erc-fill-column 72) + (erc-fill-tests--await-fill) + (should (erc-fill-tests--compare "variable-72.buffer"))) + + (ert-info ("Fancy") + (setq erc-fill-function #'erc-fill-static) + (erc-fill-tests--await-fill) + (should (erc-fill-tests--compare "static-72.buffer"))) + + (ert-info ("Fancy normal") + (setq erc-fill-column 60) + (erc-fill-tests--await-fill) + (should (erc-fill-tests--compare "static-60.buffer"))) + + (ert-info ("Again!") + (erc-fill-tests--await-fill) + (should (erc-fill-tests--compare "static-60.buffer"))) + + (ert-info ("Back home") + (setq erc-fill-function #'erc-fill-variable) + (erc-fill-tests--await-fill) + (should (erc-fill-tests--compare "variable-60.buffer"))))) + + (when noninteractive + (erc-fill-tests--teardown))) + +(ert-deftest erc-fill-buffer--interrupted () + (let* (erc-insert-pre-hook + erc-insert-modify-hook + erc-send-modify-hook + erc-mode-hook + erc-stamp-mode + erc-fill--refill-thread) + + (erc-fill-tests--setup) + + (with-current-buffer "#chan" + (setq-local erc-fill-mode t ; see note re these in prev test + erc-stamp-mode t + erc-fill-column 60) + (erc-fill-tests--await-fill) + (ert-info ("Baseline") + (should (erc-fill-tests--compare "variable-60.buffer"))) + + (ert-info ("Denied") + (setq erc-fill-column 72) + (call-interactively #'erc-fill-buffer) + (should-error (erc-fill-buffer nil)) + (thread-join erc-fill--refill-thread) + (should (erc-fill-tests--compare "variable-72.buffer"))) + + (ert-info ("Canceled") + (setq erc-fill-column 60) + (call-interactively #'erc-fill-buffer) + (sleep-for (cl-random 0.1)) + (erc-fill-buffer t) + (thread-join erc-fill--refill-thread) + (should (erc-fill-tests--compare "variable-60.buffer"))))) + + (when noninteractive + (erc-fill-tests--teardown))) + +;;; erc-fill-tests.el ends here -- 2.31.1