Package: emacs;
Reported by: Pip Cet <pipcet <at> protonmail.com>
Date: Sat, 18 Jan 2025 12:20:02 UTC
Severity: normal
Message #8 received at submit <at> debbugs.gnu.org (full text, mbox):
From: Pip Cet <pipcet <at> protonmail.com> To: bug-gnu-emacs <at> gnu.org, 75648 <at> debbugs.gnu.org Subject: Re: bug#75648: Minor safety improvements to fns.c/eval.c Date: Sat, 18 Jan 2025 14:20:39 +0000
"Pip Cet via \"Bug reports for GNU Emacs, the Swiss army knife of text editors\"" <bug-gnu-emacs <at> gnu.org> writes:
> 1. Give such tests a :crash tag
> 2. Introduce a should-not-crash macro which succeeds if the form it
> evaluates returns in any way, whether by error or not.
> 3. Modify ert.el to print when a :crash test is about to start running.
> This allows us to identify the crashing test.
> 4. Deviate from the current logical test order and put crash tests last.
> It's conceivable that if a once-fixed crash reoccurs, the reason is a
> simple bug that may show up in regular tests, too. If two tests fail
> and one of them crashes the test run, it's better for the first failure
> to have been reported first.
>
> I'll send a patch once this has a bug number.
Patch 1 adds :crash tests to ert.el.
Patch 2 adds new tests which crash if the bug is present.
Patch 3 fixes the actual bug.
Remarks:
* should-not-crash needs to be written carefully to avoid byte compiler
warnings and, in the general case, ignore errors.
* printing the test name before the crash makes a lot of sense to me,
and it's easier to do in ert-run-tests-batch rather than in
should-not-crash itself.
* plist_put wasn't buggy, but I applied analogous changes to keep it
synchronized with Fplist_put.
commit a4bf048d1f36680d37ffbd4c54c67ea13840117c
Author: Pip Cet <pipcet <at> protonmail.com>
Date: Sat Jan 18 12:26:36 2025 +0000
Handle tests known to cause crashes
* lisp/emacs-lisp/ert.el (should-not-crash): New macro.
(ert-run-tests-batch): When running a test with a :crash tag, print
a message first.
diff --git a/lisp/emacs-lisp/ert.el b/lisp/emacs-lisp/ert.el
index f25ba8a529c..cd25fe6a108 100644
--- a/lisp/emacs-lisp/ert.el
+++ b/lisp/emacs-lisp/ert.el
@@ -457,6 +457,14 @@ should-error
(list
:fail-reason "did not signal an error")))))))))
+(cl-defmacro should-not-crash (form)
+ "Evaluate FORM and ignore its value.
+
+If Emacs doesn't crash, count it as a success.
+
+Returns nil."
+ `(should-not (and (ignore-errors ,form) nil)))
+
(cl-defmacro ert--skip-when (form)
"Evaluate FORM. If it returns t, skip the current test.
Errors during evaluation are caught and handled like t."
@@ -1439,7 +1447,20 @@ ert-run-tests-batch
(message "%s" ""))
(when (getenv "EMACS_TEST_JUNIT_REPORT")
(ert-write-junit-test-report stats)))))
- (test-started)
+ (test-started
+ ;; for tests which might crash, the last line of output should
+ ;; indicate which test we attempted to run.
+ (cl-destructuring-bind (stats test ) event-args
+ (and (not ert-quiet)
+ (memq :crash (ert-test-tags test))
+ (let* ((max (prin1-to-string (length (ert--stats-tests stats))))
+ (format-string (concat "%9s %"
+ (prin1-to-string (length max))
+ "s/" max " %S")))
+ (message format-string
+ "started"
+ (1+ (ert--stats-test-pos stats test))
+ (ert-test-name test))))))
(test-ended
(cl-destructuring-bind (stats test result) event-args
(unless (ert-test-result-expected-p test result)
commit f891757a7b71980fc81afff0e818911ad6e1f344
Author: Pip Cet <pipcet <at> protonmail.com>
Date: Sat Jan 18 12:27:58 2025 +0000
Add :crash tests for bug#75648
* test/src/fns-tests.el (test-self-modifying-plist-get):
(test-self-modifying-plist-put): New tests.
diff --git a/test/src/fns-tests.el b/test/src/fns-tests.el
index eebc92bfd41..edb919badcd 100644
--- a/test/src/fns-tests.el
+++ b/test/src/fns-tests.el
@@ -1817,4 +1817,16 @@ fns-value<-bool-vector
;; Undo the flip.
(aset b i val)))))))))))
+(ert-deftest test-self-modifying-plist-get ()
+ :tags '(:crash)
+ (let ((l (list :key 'value)))
+ (should-not-crash (plist-get l :otherkey
+ #'(lambda (&rest _) (setcdr l nil))))))
+
+(ert-deftest test-self-modifying-plist-put ()
+ :tags '(:crash)
+ (let ((l (list :key 'value)))
+ (should-not-crash (plist-put l :otherkey 'dummy
+ #'(lambda (&rest _) (setcdr l nil))))))
+
;;; fns-tests.el ends here
commit d70c8d145a79f91b4cdd5f050a7b0f6cca425596
Author: Pip Cet <pipcet <at> protonmail.com>
Date: Sat Jan 18 13:41:31 2025 +0000
Fix unlikely crashes for self-modifying plists (bug#75684)
* src/fns.c (Fplist_get): Verify 'tail' is always a cons cell.
(Fplist_put): Verify 'tail' is always a cons cell. Use 'prev_cdr' to
refer to the cons cell which has the value to be modified as its car.
(plist_put): Analogous changes, to improve readability.
diff --git a/src/fns.c b/src/fns.c
index 07df2a5e90e..c07891771bb 100644
--- a/src/fns.c
+++ b/src/fns.c
@@ -2602,11 +2602,12 @@ DEFUN ("plist-get", Fplist_get, Splist_get, 2, 3, 0,
Lisp_Object tail = plist;
FOR_EACH_TAIL_SAFE (tail)
{
- if (! CONSP (XCDR (tail)))
+ Lisp_Object tail_cdr = XCDR (tail);
+ if (! CONSP (tail_cdr))
break;
if (!NILP (call2 (predicate, XCAR (tail), prop)))
- return XCAR (XCDR (tail));
- tail = XCDR (tail);
+ return XCAR (tail_cdr);
+ tail = tail_cdr;
}
return Qnil;
@@ -2657,27 +2658,27 @@ DEFUN ("plist-put", Fplist_put, Splist_put, 3, 4, 0,
{
if (NILP (predicate))
return plist_put (plist, prop, val);
- Lisp_Object prev = Qnil, tail = plist;
+ Lisp_Object prev_cdr = Qnil;
+ Lisp_Object tail = plist;
FOR_EACH_TAIL (tail)
{
- if (! CONSP (XCDR (tail)))
+ Lisp_Object tail_cdr = XCDR (tail);
+ if (! CONSP (tail_cdr))
break;
-
if (!NILP (call2 (predicate, XCAR (tail), prop)))
{
- Fsetcar (XCDR (tail), val);
+ Fsetcar (tail_cdr, val);
return plist;
}
- prev = tail;
- tail = XCDR (tail);
+ prev_cdr = tail = tail_cdr;
}
CHECK_TYPE (NILP (tail), Qplistp, plist);
Lisp_Object newcell
- = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
- if (NILP (prev))
+ = Fcons (prop, Fcons (val, NILP (prev_cdr) ? plist : XCDR (prev_cdr)));
+ if (NILP (prev_cdr))
return newcell;
- Fsetcdr (XCDR (prev), newcell);
+ Fsetcdr (prev_cdr, newcell);
return plist;
}
@@ -2685,10 +2686,12 @@ DEFUN ("plist-put", Fplist_put, Splist_put, 3, 4, 0,
Lisp_Object
plist_put (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
{
- Lisp_Object prev = Qnil, tail = plist;
+ Lisp_Object prev_cdr = Qnil;
+ Lisp_Object tail = plist;
FOR_EACH_TAIL (tail)
{
- if (! CONSP (XCDR (tail)))
+ Lisp_Object tail_cdr = XCDR (tail);
+ if (! CONSP (tail_cdr))
break;
if (EQ (XCAR (tail), prop))
@@ -2697,15 +2700,14 @@ plist_put (Lisp_Object plist, Lisp_Object prop, Lisp_Object val)
return plist;
}
- prev = tail;
- tail = XCDR (tail);
+ prev_cdr = tail = tail_cdr;;
}
CHECK_TYPE (NILP (tail), Qplistp, plist);
Lisp_Object newcell
- = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev))));
- if (NILP (prev))
+ = Fcons (prop, Fcons (val, NILP (prev_cdr) ? plist : XCDR (prev_cdr)));
+ if (NILP (prev_cdr))
return newcell;
- Fsetcdr (XCDR (prev), newcell);
+ Fsetcdr (prev_cdr, newcell);
return plist;
}
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.