PageRenderTime 12ms CodeModel.GetById 4ms app.highlight 41ms RepoModel.GetById 1ms app.codeStats 1ms

/lisp/test-harness.el

https://bitbucket.org/jsparkes/xemacs-gtk
Lisp | 772 lines | 623 code | 73 blank | 76 comment | 20 complexity | bb92db5699063dced4a8ee0ff05ab6f5 MD5 | raw file
  1;; test-harness.el --- Run Emacs Lisp test suites.
  2
  3;;; Copyright (C) 1998, 2002, 2003 Free Software Foundation, Inc.
  4;;; Copyright (C) 2002, 2010 Ben Wing.
  5
  6;; Author: Martin Buchholz
  7;; Maintainer: Stephen J. Turnbull <stephen@xemacs.org>
  8;; Keywords: testing
  9
 10;; This file is part of XEmacs.
 11
 12;; XEmacs is free software: you can redistribute it and/or modify it
 13;; under the terms of the GNU General Public License as published by the
 14;; Free Software Foundation, either version 3 of the License, or (at your
 15;; option) any later version.
 16
 17;; XEmacs is distributed in the hope that it will be useful, but WITHOUT
 18;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 19;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU General Public License
 20;; for more details.
 21
 22;; You should have received a copy of the GNU General Public License
 23;; along with XEmacs.  If not, see <http://www.gnu.org/licenses/>.
 24
 25;;; Synched up with: Not in FSF.
 26
 27;;; Commentary:
 28
 29;;; A test suite harness for testing XEmacs.
 30;;; The actual tests are in other files in this directory.
 31;;; Basically you just create files of emacs-lisp, and use the
 32;;; Assert, Check-Error, Check-Message, and Check-Error-Message functions
 33;;; to create tests.  See `test-harness-from-buffer' below.
 34;;; Don't suppress tests just because they're due to known bugs not yet
 35;;; fixed -- use the Known-Bug-Expect-Failure and
 36;;; Implementation-Incomplete-Expect-Failure wrapper macros to mark them.
 37;;; A lot of the tests we run push limits; suppress Ebola message with the
 38;;; Ignore-Ebola wrapper macro.
 39;;; Some noisy code will call `message'.  Output from `message' can be
 40;;; suppressed with the Silence-Message macro.  Functions that are known to
 41;;; issue messages include `write-region', `find-tag', `tag-loop-continue',
 42;;; `insert', and `mark-whole-buffer'.  N.B. The Silence-Message macro
 43;;; currently does not suppress the newlines printed by `message'.
 44;;; Definitely do not use Silence-Message with Check-Message.
 45;;; In general it should probably only be used on code that prepares for a
 46;;; test, not on tests.
 47;;; 
 48;;; You run the tests using M-x test-emacs-test-file,
 49;;; or $(EMACS) -batch -l test-harness -f batch-test-emacs file ...
 50;;; which is run for you by the `make check' target in the top-level Makefile.
 51
 52(require 'bytecomp)
 53
 54(defvar unexpected-test-suite-failures 0
 55  "Cumulative number of unexpected failures since test-harness was loaded.
 56
 57\"Unexpected failures\" are those caught by a generic handler established
 58outside of the test context.  As such they involve an abort of the test
 59suite for the file being tested.
 60
 61They often occur during preparation of a test or recording of the results.
 62For example, an executable used to generate test data might not be present
 63on the system, or a system error might occur while reading a data file.")
 64
 65(defvar unexpected-test-suite-failure-files nil
 66  "List of test files causing unexpected failures.")
 67
 68;; Declared for dynamic scope; _do not_ initialize here.
 69(defvar unexpected-test-file-failures)
 70
 71(defvar test-harness-bug-expected nil
 72  "Non-nil means a bug is expected; backtracing/debugging should not happen.
 73However, the individual test summary should be printed.")
 74
 75(defvar test-harness-test-compiled nil
 76  "Non-nil means the test code was compiled before execution.
 77
 78You probably should not make tests depend on compilation.
 79However, it can be useful to conditionally change messages based on whether
 80the code was compiled or not.  For example, the case that motivated the
 81implementation of this variable:
 82
 83\(when test-harness-test-compiled
 84  ;; this ha-a-ack depends on the failing compiled test coming last
 85  \(setq test-harness-failure-tag
 86	\"KNOWN BUG - fix reverted; after 2003-10-31 notify stephen\n\"))")
 87
 88(defvar test-harness-verbose
 89  (and (not noninteractive) (> (device-baud-rate) search-slow-speed))
 90  "*Non-nil means print messages describing progress of emacs-tester.")
 91
 92(defvar test-harness-unexpected-error-enter-debugger debug-on-error
 93  "*Non-nil means enter debugger when an unexpected error occurs.
 94Only applies interactively.  Normally true if `debug-on-error' has been set.
 95See also `test-harness-assertion-failure-enter-debugger' and
 96`test-harness-unexpected-error-show-backtrace'.")
 97
 98(defvar test-harness-assertion-failure-enter-debugger debug-on-error
 99  "*Non-nil means enter debugger when an assertion failure occurs.
100Only applies interactively.  Normally true if `debug-on-error' has been set.
101See also `test-harness-unexpected-error-enter-debugger' and
102`test-harness-assertion-failure-show-backtrace'.")
103
104(defvar test-harness-unexpected-error-show-backtrace t
105  "*Non-nil means show backtrace upon unexpected error.
106Only applies when debugger is not entered.  Normally true by default.  See also
107`test-harness-unexpected-error-enter-debugger' and
108`test-harness-assertion-failure-show-backtrace'.")
109
110(defvar test-harness-assertion-failure-show-backtrace stack-trace-on-error
111  "*Non-nil means show backtrace upon assertion failure.
112Only applies when debugger is not entered.  Normally true if
113`stack-trace-on-error' has been set.  See also
114`test-harness-assertion-failure-enter-debugger' and
115`test-harness-unexpected-error-show-backtrace'.")
116
117(defvar test-harness-file-results-alist nil
118  "Each element is a list (FILE SUCCESSES TESTS).
119The order is the reverse of the order in which tests are run.
120
121FILE is a string naming the test file.
122SUCCESSES is a non-negative integer, the number of successes.
123TESTS is a non-negative integer, the number of tests run.")
124
125(defvar test-harness-risk-infloops nil
126  "*Non-nil to run tests that may loop infinitely in buggy implementations.")
127
128(defvar test-harness-current-file nil)
129
130(defvar emacs-lisp-file-regexp "\\.el\\'"
131  "*Regexp which matches Emacs Lisp source files.")
132
133(defconst test-harness-file-summary-template
134  (format "%%-%ds %%%dd of %%%dd tests successful (%%3d%%%%)."
135	  (length "byte-compiler-tests.el:") ; use the longest file name
136	  5
137	  5)
138  "Format for summary lines printed after each file is run.")
139
140(defconst test-harness-null-summary-template
141  (format "%%-%ds             No tests run."
142	  (length "byte-compiler-tests.el:")) ; use the longest file name
143  "Format for \"No tests\" lines printed after a file is run.")
144
145(defconst test-harness-aborted-summary-template
146  (format "%%-%ds          %%%dd tests completed (aborted)."
147	  (length "byte-compiler-tests.el:") ; use the longest file name
148	  5)
149  "Format for summary lines printed after a test run on a file was aborted.")
150
151;;;###autoload
152(defun test-emacs-test-file (filename)
153  "Test a file of Lisp code named FILENAME.
154The output file's name is made by appending `c' to the end of FILENAME."
155  (interactive
156   (let ((file buffer-file-name)
157	 (file-name nil)
158	 (file-dir nil))
159     (and file
160	  (eq (cdr (assq 'major-mode (buffer-local-variables)))
161	      'emacs-lisp-mode)
162	  (setq file-name (file-name-nondirectory file)
163		file-dir (file-name-directory file)))
164     (list (read-file-name "Test file: " file-dir nil nil file-name))))
165  ;; Expand now so we get the current buffer's defaults
166  (setq filename (expand-file-name filename))
167
168  ;; If we're testing a file that's in a buffer and is modified, offer
169  ;; to save it first.
170  (or noninteractive
171      (let ((b (get-file-buffer (expand-file-name filename))))
172	(if (and b (buffer-modified-p b)
173		 (y-or-n-p (format "save buffer %s first? " (buffer-name b))))
174	    (save-excursion (set-buffer b) (save-buffer)))))
175
176  (if (or noninteractive test-harness-verbose)
177      (message "Testing %s..." filename))
178  (let ((test-harness-current-file filename)
179	input-buffer)
180    (save-excursion
181      (setq input-buffer (get-buffer-create " *Test Input*"))
182      (set-buffer input-buffer)
183      (erase-buffer)
184      (insert-file-contents filename)
185      ;; Run hooks including the uncompression hook.
186      ;; If they change the file name, then change it for the output also.
187      (let ((buffer-file-name filename)
188	    (default-major-mode 'emacs-lisp-mode)
189	    (enable-local-eval nil))
190        (normal-mode)
191        (setq filename buffer-file-name)))
192    (test-harness-from-buffer input-buffer filename)
193    (kill-buffer input-buffer)
194    ))
195
196(defsubst test-harness-backtrace ()
197  "Display a reasonable-size backtrace."
198  (let ((print-escape-newlines t)
199	(print-length 50))
200    (backtrace nil t)))
201
202(defsubst test-harness-assertion-failure-do-debug (error-info)
203  "Maybe enter debugger or display a backtrace on assertion failure.
204ERROR-INFO is a cons of the args (SIG . DATA) that were passed to `signal'.
205The debugger will be entered if noninteractive and
206`test-harness-unexpected-error-enter-debugger' is non-nil; else, a
207backtrace will be displayed if `test-harness-unexpected-error-show-backtrace'
208is non-nil."
209  (when (not test-harness-bug-expected)
210    (cond ((and (not noninteractive)
211		test-harness-assertion-failure-enter-debugger)
212	   (funcall debugger 'error error-info))
213	  (test-harness-assertion-failure-show-backtrace
214	   (test-harness-backtrace)))))
215
216(defsubst test-harness-unexpected-error-do-debug (error-info)
217  "Maybe enter debugger or display a backtrace on unexpected error.
218ERROR-INFO is a cons of the args (SIG . DATA) that were passed to `signal'.
219The debugger will be entered if noninteractive and
220`test-harness-unexpected-error-enter-debugger' is non-nil; else, a
221backtrace will be displayed if `test-harness-unexpected-error-show-backtrace'
222is non-nil."
223  (when (not test-harness-bug-expected)
224    (cond ((and (not noninteractive)
225		test-harness-unexpected-error-enter-debugger)
226	   (funcall debugger 'error error-info))
227	  (test-harness-unexpected-error-show-backtrace
228	   (test-harness-backtrace)))))
229
230(defsubst test-harness-unexpected-error-condition-handler (error-info context-msg)
231  "Condition handler for when unexpected errors occur.
232Useful in conjunction with `call-with-condition-handler'.  ERROR-INFO is the
233value passed to the condition handler.  CONTEXT-MSG is a string indicating
234the context in which the unexpected error occurred.  A message is outputted
235including CONTEXT-MSG in it, `unexpected-test-file-failures' is incremented,
236and `test-harness-unexpected-error-do-debug' is called, which may enter the
237debugger or output a backtrace, depending on the settings of
238`test-harness-unexpected-error-enter-debugger' and
239`test-harness-unexpected-error-show-backtrace'.
240
241The function returns normally, which causes error-handling processing to
242continue; if you want to catch the error, you also need to wrap everything
243in `condition-case'.  See also `test-harness-error-wrap', which does this
244wrapping."
245  (incf unexpected-test-file-failures)
246  (princ (format "Unexpected error %S while %s\n"
247		 error-info context-msg))
248  (message "Unexpected error %S while %s." error-info context-msg)
249  (test-harness-unexpected-error-do-debug error-info))
250
251(defmacro test-harness-error-wrap (context-msg abort-msg &rest body)
252  "Wrap BODY so that unexpected errors are caught.
253The debugger will be entered if noninteractive and
254`test-harness-unexpected-error-enter-debugger' is non-nil; else, a backtrace
255will be displayed if `test-harness-unexpected-error-show-backtrace' is
256non-nil.  CONTEXT-MSG is displayed as part of a message shown before entering
257the debugger or showing a backtrace, and ABORT-MSG, if non-nil, is displayed
258afterwards.  See "
259  `(condition-case nil
260    (call-with-condition-handler
261	#'(lambda (error-info)
262	    (test-harness-unexpected-error-condition-handler
263	     error-info ,context-msg))
264	#'(lambda ()
265	    ,@body))
266    (error ,(if abort-msg `(message ,abort-msg) nil))))
267
268(defun test-harness-read-from-buffer (buffer)
269  "Read forms from BUFFER, and turn it into a lambda test form."
270  (let ((body nil))
271    (goto-char (point-min) buffer)
272    (condition-case nil
273	(call-with-condition-handler
274	    #'(lambda (error-info)
275		;; end-of-file is expected, so don't output error or backtrace
276		;; or enter debugger in this case.
277		(unless (eq 'end-of-file (car error-info))
278		  (test-harness-unexpected-error-condition-handler
279		   error-info "reading forms from buffer")))
280	    #'(lambda ()
281		(while t
282		  (setq body (cons (read buffer) body)))))
283      (error nil))
284    `(lambda ()
285       (defvar passes)
286       (defvar assertion-failures)
287       (defvar no-error-failures)
288       (defvar wrong-error-failures)
289       (defvar missing-message-failures)
290       (defvar other-failures)
291
292       (defvar trick-optimizer)
293
294       ,@(nreverse body))))
295
296(defun test-harness-from-buffer (inbuffer filename)
297  "Run tests in buffer INBUFFER, visiting FILENAME."
298  (defvar trick-optimizer)
299  (let ((passes 0)
300	(assertion-failures 0)
301	(no-error-failures 0)
302	(wrong-error-failures 0)
303	(missing-message-failures 0)
304	(other-failures 0)
305	(unexpected-test-file-failures 0)
306
307	;; #### perhaps this should be a defvar, and output at the very end
308	;; OTOH, this way AC types can use a null EMACSPACKAGEPATH to find
309	;; what stuff is needed, and ways to avoid using them
310	(skipped-test-reasons (make-hash-table :test 'equal))
311
312	(trick-optimizer nil)
313	(debug-on-error t)
314	)
315    (with-output-to-temp-buffer "*Test-Log*"
316      (princ (format "Testing %s...\n\n" filename))
317
318      (defconst test-harness-failure-tag "FAIL")
319      (defconst test-harness-success-tag "PASS")
320
321;;;;; BEGIN DEFINITION OF MACROS USEFUL IN TEST CODE
322
323      (defmacro Known-Bug-Expect-Failure (&rest body)
324	"Wrap a BODY that consists of tests that are known to fail.
325This causes messages to be printed on failure indicating that this is expected,
326and on success indicating that this is unexpected."
327	`(let ((test-harness-bug-expected t)
328	       (test-harness-failure-tag "KNOWN BUG")
329	       (test-harness-success-tag "PASS (FAIL EXPECTED: was bug fixed?)"))
330	  ,@body))
331
332      (defmacro Known-Bug-Expect-Error (expected-error &rest body)
333	"Wrap a BODY containing a test known to trigger an error it shouldn't.
334This causes messages to be printed on failure indicating that this is expected
335of the bug, and on success indicating that this is unexpected."
336	`(let ((test-harness-bug-expected t)
337	       (test-harness-failure-tag "KNOWN BUG")
338	       (test-harness-success-tag
339		(format "PASS (EXPECTED ERROR %S due to bug: fixed?)"
340			(quote ,expected-error))))
341	  (condition-case err
342	      (progn ,@body)
343	    (,expected-error)
344	    (error
345	     (let ((m (format "  Expected %S due to bug, got %S: mutated?\n"
346			      (quote ,expected-error) err)))
347	       (if (noninteractive) (message m))
348	       (princ m))))))
349
350      (defmacro Implementation-Incomplete-Expect-Failure (&rest body)
351	"Wrap a BODY containing tests that are known to fail due to incomplete code.
352This causes messages to be printed on failure indicating that the
353implementation is incomplete (and hence the failure is expected); and on
354success indicating that this is unexpected."
355	`(let ((test-harness-bug-expected t)
356	       (test-harness-failure-tag "IMPLEMENTATION INCOMPLETE")
357	       (test-harness-success-tag
358		"PASS (FAILURE EXPECTED: feature implemented?)"))
359	  ,@body))
360    
361      (defun Print-Failure (fmt &rest args)
362	(setq fmt (format "%s: %s" test-harness-failure-tag fmt))
363	(if (noninteractive) (apply #'message fmt args))
364	(princ (concat (apply #'format fmt args) "\n")))
365
366      (defun Print-Pass (fmt &rest args)
367	(setq fmt (format "%s: %s" test-harness-success-tag fmt))
368	(and (or test-harness-verbose test-harness-bug-expected)
369	     (if (and noninteractive test-harness-bug-expected)
370		 (apply #'message fmt args))
371	     (princ (concat (apply #'format fmt args) "\n"))))
372
373      (defun Print-Skip (test reason &optional fmt &rest args)
374	(setq fmt (concat "SKIP: %S BECAUSE %S" fmt))
375	(princ (concat (apply #'format fmt test reason args) "\n")))
376
377      (defmacro Skip-Test-Unless (condition reason description &rest body)
378	"Unless CONDITION is satisfied, skip test BODY.
379REASON is a description of the condition failure, and must be unique (it
380is used as a hash key).  DESCRIPTION describes the tests that were skipped.
381BODY is a sequence of expressions and may contain several tests."
382	`(if (not ,condition)
383	     (let ((count (gethash ,reason skipped-test-reasons)))
384	       (puthash ,reason (if (null count) 1 (1+ count))
385			skipped-test-reasons)
386	       (Print-Skip ,description ,reason))
387	   ,@body))
388
389      (defmacro Assert (assertion &optional failing-case description)
390	"Test passes if ASSERTION is true.
391Optional FAILING-CASE describes the particular failure.  Optional
392DESCRIPTION describes the assertion; by default, the unevalated assertion
393expression is given.  FAILING-CASE and DESCRIPTION are useful when Assert
394is used in a loop."
395	(let ((test-assertion assertion)
396	      (negated nil))
397	  (when (and (listp test-assertion)
398		     (eql 2 (length test-assertion))
399		     (memq (car test-assertion) '(not null)))
400	    (setq test-assertion (cadr test-assertion))
401	    (setq negated t))
402	  (when (and (listp test-assertion)
403		     (eql 3 (length test-assertion))
404		     (member (car test-assertion)
405			     '(eq eql equal equalp = string= < <= > >=)))
406	    (let* ((test (car test-assertion))
407		   (testval (second test-assertion))
408		   (expected (third test-assertion))
409		   (failmsg `(format ,(if negated
410					  "%S shouldn't be `%s' to %S but is"
411					"%S should be `%s' to %S but isn't")
412			      ,testval ',test ,expected)))
413	      (setq failing-case (if failing-case
414				     `(concat 
415				       (format "%S, " ,failing-case)
416				       ,failmsg)
417				   failmsg)))))
418	(let ((description
419	       (or description `(quote ,assertion))))
420	  `(condition-case nil
421	    (call-with-condition-handler
422		#'(lambda (error-info)
423		    (if (eq 'cl-assertion-failed (car error-info))
424			(progn
425			  (Print-Failure
426			   (if ,failing-case
427			       "Assertion failed: %S; failing case = %S"
428			     "Assertion failed: %S")
429			   ,description ,failing-case)
430			  (incf assertion-failures)
431			  (test-harness-assertion-failure-do-debug error-info)
432			  nil)
433		      (Print-Failure
434		       (if ,failing-case
435			   "%S ==> error: %S; failing case =  %S"
436			 "%S ==> error: %S")
437		       ,description error-info ,failing-case)
438		      (incf other-failures)
439		      (test-harness-unexpected-error-do-debug error-info)
440		      nil))
441		#'(lambda ()
442		    (assert ,assertion)
443		    (Print-Pass "%S" ,description)
444		    (incf passes)
445		    t))
446	    (cl-assertion-failed nil))))
447
448      (defmacro Check-Error (expected-error &rest body)
449	(let ((quoted-body (if (eql 1 (length body))
450			       `(quote ,(car body)) `(quote (progn ,@body)))))
451	  `(condition-case error-info
452	       (progn
453		 (setq trick-optimizer (progn ,@body))
454		 (Print-Failure "%S executed successfully, but expected error %S"
455				,quoted-body
456				',expected-error)
457		 (incf no-error-failures))
458	     (,expected-error
459	      (Print-Pass "%S ==> error %S, as expected"
460			  ,quoted-body ',expected-error)
461	      (incf passes))
462	     (error
463	      (Print-Failure "%S ==> expected error %S, got error %S instead"
464			     ,quoted-body ',expected-error error-info)
465	      (incf wrong-error-failures)))))
466
467      (defmacro Check-Error-Message (expected-error expected-error-regexp
468						    &rest body)
469	(let ((quoted-body (if (eql 1 (length body))
470			       `(quote ,(car body)) `(quote (progn ,@body)))))
471	  `(condition-case error-info
472	       (progn
473		 (setq trick-optimizer (progn ,@body))
474		 (Print-Failure "%S executed successfully, but expected error %S"
475				,quoted-body ',expected-error)
476		 (incf no-error-failures))
477	     (,expected-error
478	      ;; #### Damn, this binding doesn't capture frobs, eg, for
479	      ;; invalid_argument() ... you only get the REASON.  And for
480	      ;; wrong_type_argument(), there's no reason only FROBs.
481	      ;; If this gets fixed, fix tests in regexp-tests.el.
482	      (let ((error-message (second error-info)))
483		(if (string-match ,expected-error-regexp error-message)
484		    (progn
485		      (Print-Pass "%S ==> error %S %S, as expected"
486				  ,quoted-body error-message ',expected-error)
487		      (incf passes))
488		  (Print-Failure "%S ==> got error %S as expected, but error message %S did not match regexp %S"
489				 ,quoted-body ',expected-error error-message ,expected-error-regexp)
490		  (incf wrong-error-failures))))
491	     (error
492	      (Print-Failure "%S ==> expected error %S, got error %S instead"
493			     ,quoted-body ',expected-error error-info)
494	      (incf wrong-error-failures)))))
495
496      ;; Do not use this with Silence-Message.
497      (defmacro Check-Message (expected-message-regexp &rest body)
498	(let ((quoted-body (if (eql 1 (length body))
499			       `(quote ,(car body))
500			     `(quote (progn ,@body)))))
501	  `(Skip-Test-Unless (fboundp 'defadvice) "can't defadvice"
502	    ,expected-message-regexp
503	    (let ((messages ""))
504	      (defadvice message (around collect activate)
505		(defvar messages)
506		(let ((msg-string (apply 'format (ad-get-args 0))))
507		  (setq messages (concat messages msg-string))
508		  msg-string))
509	      (ignore-errors
510		(call-with-condition-handler
511		    #'(lambda (error-info)
512			(Print-Failure "%S ==> unexpected error %S"
513				       ,quoted-body error-info)
514			(incf other-failures)
515			(test-harness-unexpected-error-do-debug error-info))
516		    #'(lambda ()
517			(setq trick-optimizer (progn ,@body))
518			(if (string-match ,expected-message-regexp messages)
519			    (progn
520			      (Print-Pass
521			       "%S ==> value %S, message %S, matching %S, as expected"
522			       ,quoted-body trick-optimizer messages
523			       ',expected-message-regexp)
524			      (incf passes))
525			  (Print-Failure
526			   "%S ==> value %S, message %S, NOT matching expected %S"
527			   ,quoted-body  trick-optimizer messages
528			   ',expected-message-regexp)
529			  (incf missing-message-failures)))))
530	      (ad-unadvise 'message)))))
531
532      ;; #### Perhaps this should override `message' itself, too?
533      (defmacro Silence-Message (&rest body)
534	`(flet ((append-message (&rest args) ())
535                (clear-message (&rest args) ()))
536          ,@body))
537
538      (defmacro Ignore-Ebola (&rest body)
539	`(let ((debug-issue-ebola-notices -42)) ,@body))
540
541      (defun Int-to-Marker (pos)
542	(save-excursion
543	  (set-buffer standard-output)
544	  (save-excursion
545	    (goto-char pos)
546	    (point-marker))))
547
548      (princ "Testing Interpreted Lisp\n\n")
549
550      (test-harness-error-wrap
551       "executing interpreted code"
552       "Test suite execution aborted."
553       (funcall (test-harness-read-from-buffer inbuffer)))
554
555      (princ "\nTesting Compiled Lisp\n\n")
556
557      (let (code
558	    (test-harness-test-compiled t))
559	(test-harness-error-wrap
560	 "byte-compiling code" nil
561	 (setq code
562	       ;; our lisp code is often intentionally dubious,
563	       ;; so throw away _all_ the byte compiler warnings.
564	       (letf (((symbol-function 'byte-compile-warn)
565		       'ignore))
566		 (byte-compile (test-harness-read-from-buffer
567				inbuffer))))
568	 )
569
570	(test-harness-error-wrap "executing byte-compiled code"
571				 "Test suite execution aborted."
572				 (if code (funcall code)))
573	)
574      (princ (format "\nSUMMARY for %s:\n" filename))
575      (princ (format "\t%5d passes\n" passes))
576      (princ (format "\t%5d assertion failures\n" assertion-failures))
577      (princ (format "\t%5d errors that should have been generated, but weren't\n" no-error-failures))
578      (princ (format "\t%5d wrong-error failures\n" wrong-error-failures))
579      (princ (format "\t%5d missing-message failures\n" missing-message-failures))
580      (princ (format "\t%5d other failures\n" other-failures))
581      (let* ((total (+ passes
582		       assertion-failures
583		       no-error-failures
584		       wrong-error-failures
585		       missing-message-failures
586		       other-failures))
587	     (basename (file-name-nondirectory filename))
588	     (summary-msg
589	      (cond ((> unexpected-test-file-failures 0)
590		     (format test-harness-aborted-summary-template
591			     (concat basename ":") total))
592		    ((> total 0)
593		     (format test-harness-file-summary-template
594			     (concat basename ":")
595			     passes total (/ (* 100 passes) total)))
596		    (t
597		     (format test-harness-null-summary-template
598			     (concat basename ":")))))
599	     (reasons ""))
600	(maphash (lambda (key value)
601		   (setq reasons
602			 (concat reasons
603				 (format "\n    %d tests skipped because %s."
604					 value key))))
605		 skipped-test-reasons)
606	(when (> (length reasons) 1)
607	  (setq summary-msg (concat summary-msg reasons "
608    It may be that XEmacs cannot find your installed packages.  Set
609    EMACSPACKAGEPATH to the package hierarchy root or configure with
610    --package-path to enable the skipped tests.")))
611	(setq test-harness-file-results-alist
612	      (cons (list filename passes total)
613		    test-harness-file-results-alist))
614	(message "%s" summary-msg))
615      (when (> unexpected-test-file-failures 0)
616	(setq unexpected-test-suite-failure-files
617	      (cons filename unexpected-test-suite-failure-files))
618	(setq unexpected-test-suite-failures
619	      (+ unexpected-test-suite-failures unexpected-test-file-failures))
620	(message "Test suite execution failed unexpectedly."))
621      (fmakunbound 'Assert)
622      (fmakunbound 'Check-Error)
623      (fmakunbound 'Check-Message)
624      (fmakunbound 'Check-Error-Message)
625      (fmakunbound 'Ignore-Ebola)
626      (fmakunbound 'Int-to-Marker)
627      (and noninteractive
628	   (message "%s" (buffer-substring-no-properties
629			  nil nil "*Test-Log*")))
630      )))
631
632(defvar test-harness-results-point-max nil)
633(defmacro displaying-emacs-test-results (&rest body)
634  `(let ((test-harness-results-point-max test-harness-results-point-max))
635     ;; Log the file name.
636     (test-harness-log-file)
637     ;; Record how much is logged now.
638     ;; We will display the log buffer if anything more is logged
639     ;; before the end of BODY.
640     (or test-harness-results-point-max
641	 (save-excursion
642	   (set-buffer (get-buffer-create "*Test-Log*"))
643	   (setq test-harness-results-point-max (point-max))))
644     (unwind-protect
645	 (condition-case error-info
646	     (progn ,@body)
647	   (error
648	    (test-harness-report-error error-info)))
649       (save-excursion
650	 ;; If there were compilation warnings, display them.
651	 (set-buffer "*Test-Log*")
652	 (if (= test-harness-results-point-max (point-max))
653	     nil
654	   (if temp-buffer-show-function
655	       (let ((show-buffer (get-buffer-create "*Test-Log-Show*")))
656		 (save-excursion
657		   (set-buffer show-buffer)
658		   (setq buffer-read-only nil)
659		   (erase-buffer))
660		 (copy-to-buffer show-buffer
661				 (save-excursion
662				   (goto-char test-harness-results-point-max)
663				   (forward-line -1)
664				   (point))
665				 (point-max))
666		 (funcall temp-buffer-show-function show-buffer))
667              (select-window
668               (prog1 (selected-window)
669                 (select-window (display-buffer (current-buffer)))
670                 (goto-char test-harness-results-point-max)
671                 (recenter 1)))))))))
672
673(defun batch-test-emacs-1 (file)
674  (condition-case error-info
675      (progn (test-emacs-test-file file) t)
676    (error
677     (princ ">>Error occurred processing ")
678     (princ file)
679     (princ ": ")
680     (display-error error-info nil)
681     (terpri)
682     nil)))
683
684(defun batch-test-emacs ()
685  "Run `test-harness' on the files remaining on the command line.
686Use this from the command line, with `-batch';
687it won't work in an interactive Emacs.
688Each file is processed even if an error occurred previously.
689A directory can be given as well, and all files will be processed.
690For example, invoke \"xemacs -batch -f batch-test-emacs tests\""
691  ;; command-line-args-left is what is left of the command line (from
692  ;; startup.el)
693  (defvar command-line-args-left)	;Avoid 'free variable' warning
694  (defvar debug-issue-ebola-notices)
695  (if (not noninteractive)
696      (error "`batch-test-emacs' is to be used only with -batch"))
697  (let ((error nil))
698    (dolist (file command-line-args-left)
699      (if (file-directory-p file)
700	  (dolist (file-in-dir (directory-files file t))
701	    (when (and (string-match emacs-lisp-file-regexp file-in-dir)
702		       (not (or (auto-save-file-name-p file-in-dir)
703				(backup-file-name-p file-in-dir))))
704	      (or (batch-test-emacs-1 file-in-dir)
705		  (setq error t))))
706	(or (batch-test-emacs-1 file)
707	    (setq error t))))
708    (let ((namelen 0)
709	  (succlen 0)
710	  (testlen 0)
711	  (results test-harness-file-results-alist))
712      ;; compute maximum lengths of variable components of report
713      ;; probably should just use (length "byte-compiler-tests.el")
714      ;; and 5-place sizes -- this will also work for the file-by-file
715      ;; printing when Adrian's kludge gets reverted
716      (labels ((print-width (i)
717                 (let ((x 10) (y 1))
718                   (while (>= i x)
719                     (setq x (* 10 x) y (1+ y)))
720                   y)))
721	(while results
722	  (let* ((head (car results))
723		 (nn (length (file-name-nondirectory (first head))))
724		 (ss (print-width (second head)))
725		 (tt (print-width (third head))))
726	    (when (> nn namelen) (setq namelen nn))
727	    (when (> ss succlen) (setq succlen ss))
728	    (when (> tt testlen) (setq testlen tt)))
729	  (setq results (cdr results))))
730      ;; create format and print
731      (let ((results (reverse test-harness-file-results-alist)))
732	(while results
733	  (let* ((head (car results))
734		 (basename (file-name-nondirectory (first head)))
735		 (nsucc (second head))
736		 (ntest (third head)))
737	    (cond ((member (first head) unexpected-test-suite-failure-files)
738		   (message test-harness-aborted-summary-template
739			    (concat basename ":")
740			    ntest))
741		  ((> ntest 0)
742		   (message test-harness-file-summary-template
743			    (concat basename ":")
744			    nsucc
745			    ntest
746			    (/ (* 100 nsucc) ntest)))
747		  (t
748		   (message test-harness-null-summary-template
749			    (concat basename ":"))))
750	    (setq results (cdr results)))))
751      (when (> unexpected-test-suite-failures 0)
752	(message "\n***** There %s %d unexpected test suite %s in %s:"
753		 (if (= unexpected-test-suite-failures 1) "was" "were")
754		 unexpected-test-suite-failures
755		 (if (= unexpected-test-suite-failures 1) "failure" "failures")
756		 (if (eql (length unexpected-test-suite-failure-files) 1)
757		     "file"
758		   "files"))
759	(while unexpected-test-suite-failure-files
760	  (let ((line (pop unexpected-test-suite-failure-files)))
761	    (while (and (< (length line) 61)
762			unexpected-test-suite-failure-files)
763	      (setq line
764		    (concat line " "
765			    (pop unexpected-test-suite-failure-files))))
766	    (message line)))))
767    (message "\nDone")
768    (kill-emacs (if error 1 0))))
769
770(provide 'test-harness)
771
772;;; test-harness.el ends here