;;;; test-driver.scm - Guile test driver for Automake testsuite harness

(define script-version "2016-04-03.12") ;UTC

;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This program 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 3 of the License, or (at
;;; your option) any later version.
;;;
;;; This program 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 program.  If not, see <http://www.gnu.org/licenses/>.

;;;; Commentary:
;;;
;;; This script provides a Guile test driver using the SRFI-64 Scheme API for
;;; test suites.  SRFI-64 is distributed with Guile since version 2.0.9.
;;;
;;;; Co</td></tr></table>
<table class='tabs'><tr><td>
<a href='/guix/about/'>about</a><a href='/guix/'>summary</a><a href='/guix/refs/?id=53c05faf18b30f3d5746878bc52c7b7c46d43352'>refs</a><a href='/guix/log/gnu/packages/openstack.scm'>log</a><a href='/guix/tree/gnu/packages/openstack.scm?id=53c05faf18b30f3d5746878bc52c7b7c46d43352'>tree</a><a href='/guix/commit/gnu/packages/openstack.scm?id=53c05faf18b30f3d5746878bc52c7b7c46d43352'>commit</a><a class='active' href='/guix/diff/gnu/packages/openstack.scm?id=53c05faf18b30f3d5746878bc52c7b7c46d43352'>diff</a></td><td class='form'><form class='right' method='get' action='/guix/log/gnu/packages/openstack.scm'>
<input type='hidden' name='id' value='53c05faf18b30f3d5746878bc52c7b7c46d43352'/><select name='qt'>
<option value='grep'>log msg</option>
<option value='author'>author</option>
<option value='committer'>committer</option>
<option value='range'>range</option>
</select>
<input class='txt' type='search' size='10' name='q' value=''/>
<input type='submit' value='search'/>
</form>
</td></tr></table>
<div class='path'>path: <a href='/guix/diff/?id=53c05faf18b30f3d5746878bc52c7b7c46d43352'>root</a>/<a href='/guix/diff/gnu?id=53c05faf18b30f3d5746878bc52c7b7c46d43352'>gnu</a>/<a href='/guix/diff/gnu/packages?id=53c05faf18b30f3d5746878bc52c7b7c46d43352'>packages</a>/<a href='/guix/diff/gnu/packages/openstack.scm?id=53c05faf18b30f3d5746878bc52c7b7c46d43352'>openstack.scm</a></div><div class='content'><div class='cgit-panel'><b>diff options</b><form method='get'><input type='hidden' name='id' value='53c05faf18b30f3d5746878bc52c7b7c46d43352'/><table><tr><td colspan='2'/></tr><tr><td class='label'>context:</td><td class='ctrl'><select name='context' onchange='this.form.submit();'><option value='1'>1</option><option value='2'>2</option><option value='3' selected='selected'>3</option><option value='4'>4</option><option value='5'>5</option><option value='6'>6</option><option value='7'>7</option><option value='8'>8</option><option value='9'>9</option><option value='10'>10</option><option value='15'>15</option><option value='20'>20</option><option value='25'>25</option><option value='30'>30</option><option value='35'>35</option><option value='40'>40</option></select></td></tr><tr><td class='label'>space:</td><td class='ctrl'><select name='ignorews' onchange='this.form.submit();'><option value='0' selected='selected'>include</option><option value='1'>ignore</option></select></td></tr><tr><td class='label'>mode:</td><td class='ctrl'><select name='dt' onchange='this.form.submit();'><option value='0' selected='selected'>unified</option><option value='1'>ssdiff</option><option value='2'>stat only</option></select></td></tr><tr><td/><td class='ctrl'><noscript><input type='submit' value='reload'/></noscript></td></tr></table></form></div><div class='diffstat-header'><a href='/guix/diff/?id=53c05faf18b30f3d5746878bc52c7b7c46d43352'>Diffstat</a> (limited to 'gnu/packages/openstack.scm')</div><table summary='diffstat' class='diffstat'></table><div class='diffstat-summary'>0 files changed, 0 insertions, 0 deletions</div><table summary='diff' class='diff'><tr><td></td></tr></table></div> <!-- class=content -->
                         <div class=footer>generated by
                             <a href="https://git.zx2c4.com/cgit/about/">
                                 cgit
                             </a>
                         </div>
                        </div> <!-- id=cgit -->
</body>
</html>
ng-append test-name " - " (test-runner-test-name runner))
         out-port))
      (when (result? 'expected-value)
        (test-display "expected-value" (result 'expected-value)))
      (when (result? 'expected-error)
        (test-display "expected-error" (result 'expected-error) #:pretty? #t))
      (when (result? 'actual-value)
        (test-display "actual-value" (result 'actual-value)))
      (when (result? 'actual-error)
        (test-display "actual-error" (result 'actual-error) #:pretty? #t))
      (test-display "result" (result->string (result 'result-kind)))
      (newline)
      (test-display ":test-result"
                    (string-append (result->string (test-result-kind runner))
                                   " " (test-runner-test-name runner))
                    trs-port)))

  (define (test-on-group-end-gnu runner)
    ;; Procedure called by a 'test-end', including at the end of a test-group.
    (let ((fail (or (positive? (test-runner-fail-count runner))
                    (positive? (test-runner-xpass-count runner))))
          (skip (or (positive? (test-runner-skip-count runner))
                    (positive? (test-runner-xfail-count runner)))))
      ;; XXX: The global results need some refinements for XPASS.
      (test-display ":global-test-result"
                    (if fail "FAIL" (if skip "SKIP" "PASS"))
                    trs-port)
      (test-display ":recheck"
                    (if fail "yes" "no")
                    trs-port)
      (test-display ":copy-in-global-log"
                    (if (or fail skip) "yes" "no")
                    trs-port)
      (when brief?
        ;; Display the global test group result on the console.
        (test-display (result->string (if fail 'fail (if skip 'skip 'pass))
                                      #:colorize? color?)
                      test-name
                      out-port))
      #f))

  (let ((runner (test-runner-null)))
    (test-runner-on-test-begin! runner test-on-test-begin-gnu)
    (test-runner-on-test-end! runner test-on-test-end-gnu)
    (test-runner-on-group-end! runner test-on-group-end-gnu)
    (test-runner-on-bad-end-name! runner test-on-bad-end-name-simple)
    runner))


;;;
;;; Entry point.
;;;

(define (main . args)
  (let* ((opts   (getopt-long (command-line) %options))
         (option (cut option-ref opts <> <>)))
    (cond
     ((option 'help #f)    (show-help))
     ((option 'version #f) (format #t "test-driver.scm ~A" script-version))
     (else
      (let ((log (open-file (option 'log-file "") "w0"))
            (trs (open-file (option 'trs-file "") "wl"))
            (out (duplicate-port (current-output-port) "wl")))
        (redirect-port log (current-output-port))
        (redirect-port log (current-warning-port))
        (redirect-port log (current-error-port))
        (test-with-runner
            (test-runner-gnu (option 'test-name #f)
                             #:color? (option->boolean opts 'color-tests)
                             #:brief? (option->boolean opts 'brief)
                             #:out-port out #:trs-port trs)
          (load-from-path (option 'test-name #f)))
        (close-port log)
        (close-port trs)
        (close-port out))))
    (exit 0)))

;;; Local Variables:
;;; eval: (add-hook 'write-file-functions 'time-stamp)
;;; time-stamp-start: "(define script-version \""
;;; time-stamp-format: "%:y-%02m-%02d.%02H"
;;; time-stamp-time-zone: "UTC"
;;; time-stamp-end: "\") ;UTC"
;;; End:

;;;; test-driver.scm ends here.