From d5c6faf921772e523fc224333d8af142c830a7e6 Mon Sep 17 00:00:00 2001 From: Stefan Monnier Date: Wed, 27 Jun 2012 11:11:28 -0400 Subject: [PATCH] * lisp/emacs-lisp/cl.el (flet): Mark obsolete. * lisp/emacs-lisp/cl-macs.el (cl-flet*): New macro. * lisp/vc/vc-rcs.el (vc-rcs-annotate-command, vc-rcs-parse): * lisp/progmodes/js.el (js-c-fill-paragraph): * lisp/progmodes/ebrowse.el (ebrowse-switch-member-buffer-to-sibling-class) (ebrowse-switch-member-buffer-to-derived-class): * test/automated/ert-x-tests.el (ert-test-run-tests-interactively-2): * lisp/play/5x5.el (5x5-solver): Use cl-flet. Fixes: debbugs:11780 --- lisp/ChangeLog | 8 ++ lisp/emacs-lisp/cl-loaddefs.el | 12 ++- lisp/emacs-lisp/cl-macs.el | 14 +++- lisp/emacs-lisp/cl.el | 13 +-- lisp/play/5x5.el | 20 ++--- lisp/progmodes/ebrowse.el | 18 ++-- lisp/progmodes/js.el | 18 ++-- lisp/ses.el | 24 +++--- lisp/vc/vc-rcs.el | 134 +++++++++++++++--------------- test/ChangeLog | 15 ++-- test/automated/ert-x-tests.el | 146 ++++++++++++++++----------------- 11 files changed, 231 insertions(+), 191 deletions(-) diff --git a/lisp/ChangeLog b/lisp/ChangeLog index 180f87e46b..cb70d88b84 100644 --- a/lisp/ChangeLog +++ b/lisp/ChangeLog @@ -1,5 +1,13 @@ 2012-06-27 Stefan Monnier + * emacs-lisp/cl.el (flet): Mark obsolete. + * emacs-lisp/cl-macs.el (cl-flet*): New macro. + * vc/vc-rcs.el (vc-rcs-annotate-command, vc-rcs-parse): + * progmodes/js.el (js-c-fill-paragraph): + * progmodes/ebrowse.el (ebrowse-switch-member-buffer-to-sibling-class) + (ebrowse-switch-member-buffer-to-derived-class): + * play/5x5.el (5x5-solver): Use cl-flet. + * emacs-lisp/cl.el: Use lexical-binding. Fix flet (bug#11780). (cl--symbol-function): New macro. (cl--letf, cl--letf*): Use it. diff --git a/lisp/emacs-lisp/cl-loaddefs.el b/lisp/emacs-lisp/cl-loaddefs.el index f7eaa3b9f9..4d7e1ecc8b 100644 --- a/lisp/emacs-lisp/cl-loaddefs.el +++ b/lisp/emacs-lisp/cl-loaddefs.el @@ -260,12 +260,12 @@ Remove from SYMBOL's plist the property PROPNAME and its value. ;;;;;; cl-deftype cl-defstruct cl-callf2 cl-callf cl-rotatef cl-shiftf ;;;;;; cl-remf cl-psetf cl-declare cl-the cl-locally cl-multiple-value-setq ;;;;;; cl-multiple-value-bind cl-symbol-macrolet cl-macrolet cl-labels -;;;;;; cl-flet cl-progv cl-psetq cl-do-all-symbols cl-do-symbols +;;;;;; cl-flet* cl-flet cl-progv cl-psetq cl-do-all-symbols cl-do-symbols ;;;;;; cl-dotimes cl-dolist cl-do* cl-do cl-loop cl-return-from ;;;;;; cl-return cl-block cl-etypecase cl-typecase cl-ecase cl-case ;;;;;; cl-load-time-value cl-eval-when cl-destructuring-bind cl-function ;;;;;; cl-defmacro cl-defun cl-gentemp cl-gensym) "cl-macs" "cl-macs.el" -;;;;;; "41a15289eda7e6ae03ac9edd86bbb1a6") +;;;;;; "e7bb76130254614df1603a1c1e89cb49") ;;; Generated autoloads from cl-macs.el (autoload 'cl-gensym "cl-macs" "\ @@ -492,6 +492,14 @@ Like `cl-labels' but the definitions are not recursive. (put 'cl-flet 'lisp-indent-function '1) +(autoload 'cl-flet* "cl-macs" "\ +Make temporary function definitions. +Like `cl-flet' but the definitions can refer to previous ones. + +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" nil t) + +(put 'cl-flet* 'lisp-indent-function '1) + (autoload 'cl-labels "cl-macs" "\ Make temporary function bindings. The bindings can be recursive. Assumes the use of `lexical-binding'. diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index eaa988bfb5..39e230cb32 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -1570,7 +1570,6 @@ a `let' form, except that the list of symbols can be computed at run-time." (setq cl--labels-convert-cache (cons f res)) res)))))) -;;; This should really have some way to shadow 'byte-compile properties, etc. ;;;###autoload (defmacro cl-flet (bindings &rest body) "Make temporary function definitions. @@ -1595,6 +1594,18 @@ Like `cl-labels' but the definitions are not recursive. (if (assq 'function newenv) newenv (cons (cons 'function #'cl--labels-convert) newenv))))))) +;;;###autoload +(defmacro cl-flet* (bindings &rest body) + "Make temporary function definitions. +Like `cl-flet' but the definitions can refer to previous ones. + +\(fn ((FUNC ARGLIST BODY...) ...) FORM...)" + (declare (indent 1) (debug ((&rest (cl-defun)) cl-declarations body))) + (cond + ((null bindings) (macroexp-progn body)) + ((null (cdr bindings)) `(cl-flet ,bindings ,@body)) + (t `(cl-flet (,(pop bindings)) (cl-flet* ,bindings ,@body))))) + ;;;###autoload (defmacro cl-labels (bindings &rest body) "Make temporary function bindings. @@ -2257,6 +2268,7 @@ STRING is an optional description of the desired type." ;;;###autoload (defmacro cl-assert (form &optional show-args string &rest args) + ;; FIXME: This is actually not compatible with Common-Lisp's `assert'. "Verify that FORM returns non-nil; signal an error if not. Second arg SHOW-ARGS means to include arguments of FORM in message. Other args STRING and ARGS... are arguments to be passed to `error'. diff --git a/lisp/emacs-lisp/cl.el b/lisp/emacs-lisp/cl.el index 7996af4e02..0b6d9cd222 100644 --- a/lisp/emacs-lisp/cl.el +++ b/lisp/emacs-lisp/cl.el @@ -461,11 +461,13 @@ Common Lisp. ;; This should really have some way to shadow 'byte-compile properties, etc. (defmacro flet (bindings &rest body) - "Make temporary function definitions. -This is an analogue of `let' that operates on the function cell of FUNC -rather than its value cell. The FORMs are evaluated with the specified -function definitions in place, then the definitions are undone (the FUNCs -go back to their previous definitions, or lack thereof). + "Make temporary overriding function definitions. +This is an analogue of a dynamically scoped `let' that operates on the function +cell of FUNCs rather than their value cell. +If you want the Common-Lisp style of `flet', you should use `cl-flet'. +The FORMs are evaluated with the specified function definitions in place, +then the definitions are undone (the FUNCs go back to their previous +definitions, or lack thereof). \(fn ((FUNC ARGLIST BODY...) ...) FORM...)" (declare (indent 1) (debug cl-flet)) @@ -491,6 +493,7 @@ will not work - use `labels' instead" (symbol-name (car x)))) (list `(symbol-function ',(car x)) func))) bindings) ,@body)) +(make-obsolete 'flet "Use either `cl-flet' or `letf'." "24.2") (defmacro labels (bindings &rest body) "Make temporary function bindings. diff --git a/lisp/play/5x5.el b/lisp/play/5x5.el index b2fffb4984..c0a642941f 100644 --- a/lisp/play/5x5.el +++ b/lisp/play/5x5.el @@ -568,14 +568,14 @@ to complete the 5x5. Solutions are sorted from least to greatest Hamming weight." (require 'calc-ext) - (flet ((5x5-mat-mode-2 - (a) - (math-map-vec - (lambda (y) - (math-map-vec - (lambda (x) `(mod ,x 2)) - y)) - a))) + (cl-flet ((5x5-mat-mode-2 + (a) + (math-map-vec + (lambda (y) + (math-map-vec + (lambda (x) `(mod ,x 2)) + y)) + a))) (let* (calc-command-flags (grid-size-squared (* 5x5-grid-size 5x5-grid-size)) @@ -658,8 +658,8 @@ Solutions are sorted from least to greatest Hamming weight." (cdr (5x5-mat-mode-2 '(vec (vec 0 1 1 1 0 1 0 1 0 1 1 1 0 1 1 1 0 1 0 1 0 1 1 1 0) - (vec 1 1 0 1 1 0 0 0 0 0 1 1 0 1 - 1 0 0 0 0 0 1 1 0 1 1))))) + (vec 1 1 0 1 1 0 0 0 0 0 1 1 0 1 + 1 0 0 0 0 0 1 1 0 1 1))))) (calcFunc-trn id)))) (inv-base-change diff --git a/lisp/progmodes/ebrowse.el b/lisp/progmodes/ebrowse.el index 5c2ba080d3..ce190d2515 100644 --- a/lisp/progmodes/ebrowse.el +++ b/lisp/progmodes/ebrowse.el @@ -2957,10 +2957,10 @@ Prefix arg INC specifies which one." (let ((containing-list ebrowse--tree) index cls (supers (ebrowse-direct-base-classes ebrowse--displayed-class))) - (flet ((trees-alist (trees) - (loop for tr in trees - collect (cons (ebrowse-cs-name - (ebrowse-ts-class tr)) tr)))) + (cl-flet ((trees-alist (trees) + (loop for tr in trees + collect (cons (ebrowse-cs-name + (ebrowse-ts-class tr)) tr)))) (when supers (let ((tree (if (second supers) (ebrowse-completing-read-value @@ -2985,11 +2985,11 @@ Prefix arg INC specifies which one." Prefix arg ARG says which class should be displayed. Default is the first derived class." (interactive "P") - (flet ((ebrowse-tree-obarray-as-alist () - (loop for s in (ebrowse-ts-subclasses - ebrowse--displayed-class) - collect (cons (ebrowse-cs-name - (ebrowse-ts-class s)) s)))) + (cl-flet ((ebrowse-tree-obarray-as-alist () + (loop for s in (ebrowse-ts-subclasses + ebrowse--displayed-class) + collect (cons (ebrowse-cs-name + (ebrowse-ts-class s)) s)))) (let ((subs (or (ebrowse-ts-subclasses ebrowse--displayed-class) (error "No derived classes")))) (if (and arg (second subs)) diff --git a/lisp/progmodes/js.el b/lisp/progmodes/js.el index cdc3ef1c2e..2e943be412 100644 --- a/lisp/progmodes/js.el +++ b/lisp/progmodes/js.el @@ -1821,15 +1821,15 @@ nil." (defun js-c-fill-paragraph (&optional justify) "Fill the paragraph with `c-fill-paragraph'." (interactive "*P") - (flet ((c-forward-sws - (&optional limit) - (js--forward-syntactic-ws limit)) - (c-backward-sws - (&optional limit) - (js--backward-syntactic-ws limit)) - (c-beginning-of-macro - (&optional limit) - (js--beginning-of-macro limit))) + (letf (((symbol-function 'c-forward-sws) + (lambda (&optional limit) + (js--forward-syntactic-ws limit))) + ((symbol-function 'c-backward-sws) + (lambda (&optional limit) + (js--backward-syntactic-ws limit))) + ((symbol-function 'c-beginning-of-macro) + (lambda (&optional limit) + (js--beginning-of-macro limit)))) (let ((fill-paragraph-function 'c-fill-paragraph)) (c-fill-paragraph justify)))) diff --git a/lisp/ses.el b/lisp/ses.el index a6a6aa91b5..7429653c7d 100644 --- a/lisp/ses.el +++ b/lisp/ses.el @@ -3380,21 +3380,23 @@ Use `math-format-value' as a printer for Calc objects." (setq iter (cdr iter)))) (setq result ret))) - (flet ((vectorize-*1 - (clean result) - (cons clean (cons (quote 'vec) (apply 'append result)))) - (vectorize-*2 - (clean result) - (cons clean (cons (quote 'vec) (mapcar (lambda (x) - (cons clean (cons (quote 'vec) x))) - result))))) + (cl-flet ((vectorize-*1 + (clean result) + (cons clean (cons (quote 'vec) (apply 'append result)))) + (vectorize-*2 + (clean result) + (cons clean (cons (quote 'vec) + (mapcar (lambda (x) + (cons clean (cons (quote 'vec) x))) + result))))) (case vectorize ((nil) (cons clean (apply 'append result))) ((*1) (vectorize-*1 clean result)) ((*2) (vectorize-*2 clean result)) - ((*) (if (cdr result) - (vectorize-*2 clean result) - (vectorize-*1 clean result))))))) + ((*) (funcall (if (cdr result) + #'vectorize-*2 + #'vectorize-*1) + clean result)))))) (defun ses-delete-blanks (&rest args) "Return ARGS reversed, with the blank elements (nil and *skip*) removed." diff --git a/lisp/vc/vc-rcs.el b/lisp/vc/vc-rcs.el index 104e6fd59e..4f50e1c869 100644 --- a/lisp/vc/vc-rcs.el +++ b/lisp/vc/vc-rcs.el @@ -679,9 +679,9 @@ Optional arg REVISION is a revision to annotate from." ;; Apply reverse-chronological edits on the trunk, computing and ;; accumulating forward-chronological edits after some point, for ;; later. - (flet ((r/d/a () (vector pre - (cdr (assq 'date meta)) - (cdr (assq 'author meta))))) + (cl-flet ((r/d/a () (vector pre + (cdr (assq 'date meta)) + (cdr (assq 'author meta))))) (while (when (setq pre cur cur (cdr (assq 'next meta))) (not (string= "" cur))) (setq @@ -769,16 +769,16 @@ Optional arg REVISION is a revision to annotate from." ht) (setq maxw (max w maxw)))) (let ((padding (make-string maxw 32))) - (flet ((pad (w) (substring-no-properties padding w)) - (render (rda &rest ls) - (propertize - (apply 'concat - (format-time-string "%Y-%m-%d" (aref rda 1)) - " " - (aref rda 0) - ls) - :vc-annotate-prefix t - :vc-rcs-r/d/a rda))) + (cl-flet ((pad (w) (substring-no-properties padding w)) + (render (rda &rest ls) + (propertize + (apply 'concat + (format-time-string "%Y-%m-%d" (aref rda 1)) + " " + (aref rda 0) + ls) + :vc-annotate-prefix t + :vc-rcs-r/d/a rda))) (maphash (if all-me (lambda (rda w) @@ -1306,50 +1306,51 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." ;; to "de-@@-format" the printed representation as the first step ;; to translating it into some value. See internal func `gather'. @-holes) - (flet ((sw () (skip-chars-forward " \t\n")) ; i.e., `[:space:]' - (at (tag) (save-excursion (eq tag (read buffer)))) - (to-eol () (buffer-substring-no-properties - (point) (progn (forward-line 1) - (1- (point))))) - (to-semi () (setq b (point) - e (progn (search-forward ";") - (1- (point))))) - (to-one@ () (setq @-holes nil - b (progn (search-forward "@") (point)) - e (progn (while (and (search-forward "@") - (= ?@ (char-after)) - (progn - (push (point) @-holes) - (forward-char 1) - (push (point) @-holes)))) - (1- (point))))) - (tok+val (set-b+e name &optional proc) - (unless (eq name (setq tok (read buffer))) - (error "Missing `%s' while parsing %s" name context)) - (sw) - (funcall set-b+e) - (cons tok (if proc - (funcall proc) - (buffer-substring-no-properties b e)))) - (k-semi (name &optional proc) (tok+val 'to-semi name proc)) - (gather () (let ((pairs `(,e ,@@-holes ,b)) - acc) - (while pairs - (push (buffer-substring-no-properties - (cadr pairs) (car pairs)) - acc) - (setq pairs (cddr pairs))) - (apply 'concat acc))) - (k-one@ (name &optional later) (tok+val 'to-one@ name - (if later - (lambda () t) - 'gather)))) + (cl-flet* + ((sw () (skip-chars-forward " \t\n")) ; i.e., `[:space:]' + (at (tag) (save-excursion (eq tag (read buffer)))) + (to-eol () (buffer-substring-no-properties + (point) (progn (forward-line 1) + (1- (point))))) + (to-semi () (setq b (point) + e (progn (search-forward ";") + (1- (point))))) + (to-one@ () (setq @-holes nil + b (progn (search-forward "@") (point)) + e (progn (while (and (search-forward "@") + (= ?@ (char-after)) + (progn + (push (point) @-holes) + (forward-char 1) + (push (point) @-holes)))) + (1- (point))))) + (tok+val (set-b+e name &optional proc) + (unless (eq name (setq tok (read buffer))) + (error "Missing `%s' while parsing %s" name context)) + (sw) + (funcall set-b+e) + (cons tok (if proc + (funcall proc) + (buffer-substring-no-properties b e)))) + (k-semi (name &optional proc) (tok+val #'to-semi name proc)) + (gather () (let ((pairs `(,e ,@@-holes ,b)) + acc) + (while pairs + (push (buffer-substring-no-properties + (cadr pairs) (car pairs)) + acc) + (setq pairs (cddr pairs))) + (apply 'concat acc))) + (k-one@ (name &optional later) (tok+val #'to-one@ name + (if later + (lambda () t) + #'gather)))) (save-excursion (goto-char (point-min)) ;; headers (setq context 'headers) - (flet ((hpush (name &optional proc) - (push (k-semi name proc) headers))) + (cl-flet ((hpush (name &optional proc) + (push (k-semi name proc) headers))) (hpush 'head) (when (at 'branch) (hpush 'branch)) @@ -1391,7 +1392,7 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." (when (< (car ls) 100) (setcar ls (+ 1900 (car ls)))) (apply 'encode-time (nreverse ls))))) - ,@(mapcar 'k-semi '(author state)) + ,@(mapcar #'k-semi '(author state)) ,(k-semi 'branches (lambda () (split-string @@ -1421,16 +1422,17 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." ;; only the former since it behaves identically to the ;; latter in the absence of "@@".) sub) - (flet ((incg (beg end) (let ((b beg) (e end) @-holes) - (while (and asc (< (car asc) e)) - (push (pop asc) @-holes)) - ;; Self-deprecate when work is done. - ;; Folding many dimensions into one. - ;; Thanks B.Mandelbrot, for complex sum. - ;; O beauteous math! --the Unvexed Bum - (unless asc - (setq sub 'buffer-substring-no-properties)) - (gather)))) + (cl-flet ((incg (beg end) + (let ((b beg) (e end) @-holes) + (while (and asc (< (car asc) e)) + (push (pop asc) @-holes)) + ;; Self-deprecate when work is done. + ;; Folding many dimensions into one. + ;; Thanks B.Mandelbrot, for complex sum. + ;; O beauteous math! --the Unvexed Bum + (unless asc + (setq sub #'buffer-substring-no-properties)) + (gather)))) (while (and (sw) (not (eobp)) (setq context (to-eol) @@ -1449,8 +1451,8 @@ The `:insn' key is a keyword to distinguish it as a vc-rcs.el extension." (setcdr (cadr rev) (gather)) (if @-holes (setq asc (nreverse @-holes) - sub 'incg) - (setq sub 'buffer-substring-no-properties)) + sub #'incg) + (setq sub #'buffer-substring-no-properties)) (goto-char b) (setq acc nil) (while (< (point) e) diff --git a/test/ChangeLog b/test/ChangeLog index ddd26bf492..45fc70e044 100644 --- a/test/ChangeLog +++ b/test/ChangeLog @@ -1,7 +1,12 @@ +2012-06-27 Stefan Monnier + + * automated/ert-x-tests.el (ert-test-run-tests-interactively-2): + Use cl-flet. + 2012-06-08 Ulf Jasper - * automated/icalendar-tests.el (icalendar--parse-vtimezone): Test - escaped commas in TZID (Bug#11473). + * automated/icalendar-tests.el (icalendar--parse-vtimezone): + Test escaped commas in TZID (Bug#11473). (icalendar-import-with-timezone): New. (icalendar-real-world): Add new testcase as given in the bugreport of Bug#11473. @@ -332,8 +337,8 @@ 2009-12-18 Ulf Jasper * icalendar-testsuite.el - (icalendar-testsuite--run-function-tests): Add - icalendar-testsuite--test-parse-vtimezone. + (icalendar-testsuite--run-function-tests): + Add icalendar-testsuite--test-parse-vtimezone. (icalendar-testsuite--test-parse-vtimezone): New. (icalendar-testsuite--do-test-cycle): Doc changes. (icalendar-testsuite--run-real-world-tests): Remove trailing @@ -375,7 +380,7 @@ 2008-10-31 Ulf Jasper * icalendar-testsuite.el (icalendar-testsuite--run-function-tests): - Added `icalendar-testsuite--test-create-uid'. + Add `icalendar-testsuite--test-create-uid'. (icalendar-testsuite--test-create-uid): New. 2008-06-14 Ulf Jasper diff --git a/test/automated/ert-x-tests.el b/test/automated/ert-x-tests.el index bb05608e41..520502bb30 100644 --- a/test/automated/ert-x-tests.el +++ b/test/automated/ert-x-tests.el @@ -103,79 +103,79 @@ (ert-deftest ert-test-run-tests-interactively-2 () :tags '(:causes-redisplay) - (let ((passing-test (make-ert-test :name 'passing-test - :body (lambda () (ert-pass)))) - (failing-test (make-ert-test :name 'failing-test - :body (lambda () - (ert-info ((propertize "foo\nbar" - 'a 'b)) - (ert-fail - "failure message")))))) - (let ((ert-debug-on-error nil)) - (let* ((buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) - (messages nil) - (mock-message-fn - (lambda (format-string &rest args) - (push (apply #'format format-string args) messages)))) - (flet ((expected-string (with-font-lock-p) - (ert-propertized-string - "Selector: (member )\n" - "Passed: 1\n" - "Failed: 1 (1 unexpected)\n" - "Total: 2/2\n\n" - "Started at:\n" - "Finished.\n" - "Finished at:\n\n" - `(category ,(button-category-symbol - 'ert--results-progress-bar-button) - button (t) - face ,(if with-font-lock-p - 'ert-test-result-unexpected - 'button)) - ".F" nil "\n\n" - `(category ,(button-category-symbol - 'ert--results-expand-collapse-button) - button (t) - face ,(if with-font-lock-p - 'ert-test-result-unexpected - 'button)) - "F" nil " " - `(category ,(button-category-symbol - 'ert--test-name-button) - button (t) - ert-test-name failing-test) - "failing-test" - nil "\n Info: " '(a b) "foo\n" - nil " " '(a b) "bar" - nil "\n (ert-test-failed \"failure message\")\n\n\n" - ))) - (save-window-excursion - (unwind-protect - (let ((case-fold-search nil)) - (ert-run-tests-interactively - `(member ,passing-test ,failing-test) buffer-name - mock-message-fn) - (should (equal messages `(,(concat - "Ran 2 tests, 1 results were " - "as expected, 1 unexpected")))) - (with-current-buffer buffer-name - (font-lock-mode 0) - (should (ert-equal-including-properties - (ert-filter-string (buffer-string) - '("Started at:\\(.*\\)$" 1) - '("Finished at:\\(.*\\)$" 1)) - (expected-string nil))) - ;; `font-lock-mode' only works if interactive, so - ;; pretend we are. - (let ((noninteractive nil)) - (font-lock-mode 1)) - (should (ert-equal-including-properties - (ert-filter-string (buffer-string) - '("Started at:\\(.*\\)$" 1) - '("Finished at:\\(.*\\)$" 1)) - (expected-string t))))) - (when (get-buffer buffer-name) - (kill-buffer buffer-name))))))))) + (let* ((passing-test (make-ert-test :name 'passing-test + :body (lambda () (ert-pass)))) + (failing-test (make-ert-test :name 'failing-test + :body (lambda () + (ert-info ((propertize "foo\nbar" + 'a 'b)) + (ert-fail + "failure message"))))) + (ert-debug-on-error nil) + (buffer-name (generate-new-buffer-name "*ert-test-run-tests*")) + (messages nil) + (mock-message-fn + (lambda (format-string &rest args) + (push (apply #'format format-string args) messages)))) + (cl-flet ((expected-string (with-font-lock-p) + (ert-propertized-string + "Selector: (member )\n" + "Passed: 1\n" + "Failed: 1 (1 unexpected)\n" + "Total: 2/2\n\n" + "Started at:\n" + "Finished.\n" + "Finished at:\n\n" + `(category ,(button-category-symbol + 'ert--results-progress-bar-button) + button (t) + face ,(if with-font-lock-p + 'ert-test-result-unexpected + 'button)) + ".F" nil "\n\n" + `(category ,(button-category-symbol + 'ert--results-expand-collapse-button) + button (t) + face ,(if with-font-lock-p + 'ert-test-result-unexpected + 'button)) + "F" nil " " + `(category ,(button-category-symbol + 'ert--test-name-button) + button (t) + ert-test-name failing-test) + "failing-test" + nil "\n Info: " '(a b) "foo\n" + nil " " '(a b) "bar" + nil "\n (ert-test-failed \"failure message\")\n\n\n" + ))) + (save-window-excursion + (unwind-protect + (let ((case-fold-search nil)) + (ert-run-tests-interactively + `(member ,passing-test ,failing-test) buffer-name + mock-message-fn) + (should (equal messages `(,(concat + "Ran 2 tests, 1 results were " + "as expected, 1 unexpected")))) + (with-current-buffer buffer-name + (font-lock-mode 0) + (should (ert-equal-including-properties + (ert-filter-string (buffer-string) + '("Started at:\\(.*\\)$" 1) + '("Finished at:\\(.*\\)$" 1)) + (expected-string nil))) + ;; `font-lock-mode' only works if interactive, so + ;; pretend we are. + (let ((noninteractive nil)) + (font-lock-mode 1)) + (should (ert-equal-including-properties + (ert-filter-string (buffer-string) + '("Started at:\\(.*\\)$" 1) + '("Finished at:\\(.*\\)$" 1)) + (expected-string t))))) + (when (get-buffer buffer-name) + (kill-buffer buffer-name))))))) (ert-deftest ert-test-describe-test () "Tests `ert-describe-test'." -- 2.20.1