#!/usr/bin/guile \
-e "(scripts run-all-tests)" -s
!#
;;; run-all-tests --- Run tests in a test suite

;;	Copyright (C) 2002,2003,2004 Free Software Foundation, Inc.
;;
;; This file is part of GUILE
;;
;; GUILE 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 2, or (at your option)
;; any later version.
;;
;; GUILE 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 this software; see the file COPYING.  If not, write to
;; the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
;; Boston, MA 02110-1301, USA.
;;
;; As a special exception, the Free Software Foundation gives permission
;; for additional uses of the text contained in its release of GUILE.
;;
;; The exception is that, if you link the GUILE library with other files
;; to produce an executable, this does not by itself cause the
;; resulting executable to be covered by the GNU General Public License.
;; Your use of that executable is in no way restricted on account of
;; linking the GUILE library code into it.
;;
;; This exception does not however invalidate any other reasons why
;; the executable file might be covered by the GNU General Public License.
;;
;; This exception applies only to the code released by the
;; Free Software Foundation under the name GUILE.  If you copy
;; code from other Free Software Foundation releases into a copy of
;; GUILE, as the General Public License permits, the exception does
;; not apply to the code that you add in this way.  To avoid misleading
;; anyone as to the status of such modified files, you must delete
;; this exception notice from them.
;;
;; If you write modifications of your own for GUILE, it is your choice
;; whether to permit this exception to apply to your modifications.
;; If you do not wish that, delete this exception notice.

;;; Author: Jim Blandy <jimb@red-bean.com> --- May 1999
;;;     Thien-Thi Nguyen <ttn@gnu.org>

;;; Commentary:

;; Usage: run-all-tests [OPTIONS ...] [TEST ...]
;;
;; where options are one of: -p, --preload FILE
;;                           -d, --tests-dir DIR
;;                           -t, --tmp-dir DIR
;;                           -u, --flag-unresolved
;;                           -l, --log FILE
;;                           -D, --debug
;;
;; Run tests from the current working directory.  Report failures and
;; unexpected passes to the standard output, along with a summary of
;; all the results.  Record each reported test outcome in the log
;; file, "run-all-tests.log".  The exit status is non-zero if any of
;; the tests fail or pass unexpectedly.  You can use "--log LOG" to
;; specify an alternate filename for the log output.
;;
;; If no test filenames are specified, run-all-tests scans for files
;; whose names end in ".test".  Use "--tests-dir DIR" to specify another
;; directory to use.  Use "--debug" to enable a debugging mode.
;;
;; Normally, UNRESOLVED results are noted but do not affect the exit
;; status.  Use "--flag-unresolved" to cause run-all-tests to exit with
;; non-zero status on any UNRESOLVED results.
;;
;; During the test run, variable `tmp-dir' and convenience proc
;; `data-file-name' are available for temporary file usage.  You can
;; choose another directory with "--tmp-dir DIR".
;;
;; Lastly, you can specify a file to be `load'ed before executing any
;; of the tests using the "--preload FILE" option.

;;; Code:

(define-module (scripts run-all-tests)
  #:autoload (scripts PROGRAM) (HVQC-MAIN)
  #:use-module (ice-9 testing-lib)
  ;; not yet
  ;; #:export (run-all-tests)
  )

;;; General utilities, that probably should be in a library somewhere.

;; Traverse the directory tree at ROOT, applying F to the name of
;; each file in the tree, including ROOT itself.  For a subdirectory
;; SUB, if (F SUB) is true, we recurse into SUB.  Do not follow
;; symlinks.

(define (for-each-file f root)

  ;; A "hard directory" is a path that denotes a directory and is not a
  ;; symlink.
  (define (file-is-hard-directory? filename)
    (eq? (stat:type (lstat filename)) 'directory))

  (let visit ((root root))
    (let ((should-recur (f root)))
      (if (and should-recur (file-is-hard-directory? root))
	  (let ((dir (opendir root)))
	    (let loop ()
	      (let ((entry (readdir dir)))
		(cond
		 ((eof-object? entry) #f)
		 ((or (string=? entry ".")
		      (string=? entry "..")
                      (string=? entry "CVS")
                      (string=? entry "RCS"))
		  (loop))
		 (else
		  (visit (string-append root "/" entry))
		  (loop))))))))))

;; Return a list of all the test files in the test tree.

(define (enumerate-tests test-dir)
  (let ((root-len (+ 1 (string-length test-dir)))
	(tests '()))
    (for-each-file (lambda (file)
		     (if (has-suffix? file ".test")
			 (let ((short-name
				(substring file root-len)))
			   (set! tests (cons short-name tests))))
		     #t)
		   test-dir)

    ;; for-each-file presents the files in whatever order it finds
    ;; them in the directory.  We sort them here, so they'll always
    ;; appear in the same order.  This makes it easier to compare test
    ;; log files mechanically.
    (sort tests string<?)))

(define (run-all-tests/qop qop)
  (cond ((qop 'debug)
         (simple-format #t "load-path: ~A\nLTDL_LIBRARY_PATH: ~A\n"
                        %load-path (getenv "LTDL_LIBRARY_PATH"))
         (set! %load-verbosely #t)
         (debug-enable 'backtrace 'debug)))
  (qop 'preload load)
  (let* ((tests-dir (or (qop 'tests-dir) "."))
         (tmp-dir (or (qop 'tmp-dir) (getcwd)))
         (tests (let ((foo (qop '())))
                  (if (null? foo)
                      (enumerate-tests tests-dir)
                      foo)))
         (log-port (open-output-file (or (qop 'log)
                                         "run-all-tests.log")))
         (global-pass #t)
         (counter (make-count-reporter)))

    ;; Set the globals (ugh).
    (set! test-file-name (lambda (file) (in-vicinity tests-dir file)))
    (set! data-file-name (lambda (file) (in-vicinity tmp-dir file)))

    ;; Set up the reporters.
    (register-reporter (car counter))
    (register-reporter (make-log-reporter log-port))
    (register-reporter user-reporter)
    (register-reporter (lambda results
                         (case (car results)
                           ((unresolved)
                            (and (qop 'flag-unresolved)
                                 (set! global-pass #f)))
                           ((fail upass error)
                            (set! global-pass #f)))))

    ;; Run the tests.
    (for-each (lambda (test)
                (with-test-prefix test
                  (catch 'skip-file
                         (lambda ()
                           (load (test-file-name test)))
                         (lambda (key . why)
                           (simple-format #t "SKIP: ~A ~A\n" test why)
                           #t))))
              tests)

    ;; Display the final counts, both to stdout and in the log file.
    (let ((counts ((cadr counter))))
      (print-counts counts)
      (print-counts counts log-port))

    (close-port log-port)
    (quit global-pass)))

(define (main args)
  (HVQC-MAIN args run-all-tests/qop
             '(usage . commentary)
             '(package . "Guile")
             '(option-spec (preload         (single-char #\p)
                                            (value #t))
                           (tests-dir       (single-char #\d)
                                            (value #t))
                           (tmp-dir         (single-char #\t)
                                            (value #t))
                           (flag-unresolved (single-char #\u))
                           (log             (single-char #\l)
                                            (value #t))
                           (debug           (single-char #\D)))))

;;; run-all-tests ends here
