mirror of
https://git.savannah.gnu.org/git/emacs.git
synced 2024-11-27 07:37:33 +00:00
* 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
This commit is contained in:
Stefan Monnier
parent
7b953864ba
commit
d5c6faf921
@ -1,5 +1,13 @@
|
||||
2012-06-27 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* 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.
|
||||
|
||||
@ -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'.
|
||||
|
||||
@ -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'.
|
||||
|
||||
@ -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.
|
||||
|
||||
@ -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
|
||||
|
||||
@ -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))
|
||||
|
||||
@ -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))))
|
||||
|
||||
|
||||
24
lisp/ses.el
24
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."
|
||||
|
||||
@ -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)
|
||||
|
||||
@ -1,7 +1,12 @@
|
||||
2012-06-27 Stefan Monnier <monnier@iro.umontreal.ca>
|
||||
|
||||
* automated/ert-x-tests.el (ert-test-run-tests-interactively-2):
|
||||
Use cl-flet.
|
||||
|
||||
2012-06-08 Ulf Jasper <ulf.jasper@web.de>
|
||||
|
||||
* 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 <ulf.jasper@web.de>
|
||||
|
||||
* 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 <ulf.jasper@web.de>
|
||||
|
||||
* 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 <ulf.jasper@web.de>
|
||||
|
||||
@ -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 <passing-test> <failing-test>)\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 <passing-test> <failing-test>)\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'."
|
||||
|
||||
Loading…
Reference in New Issue
Block a user