dmbcs/mcron
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

job-specifier: range: Add tests.

Browse source 
* build-aux/test-driver.scm: New script.
* configure.ac (AC_REQUIRE_AUX_FILE): Add it.
* tests/job-specifier.scm: New test.
* Makefile.am (TEST_EXTENSIONS, AM_TESTS_ENVIRONMENT, SCM_LOG_DRIVER)
(TESTS): New variables.
(EXTRA_DIST): Update.
* .gitignore: Likewise.
This commit is contained in:
Mathieu Lirzin 2016-05-10 01:06:10 +02:00
commit 9d173e23bc
No known key found for this signature in database
GPG key ID: 0ADEE10094604D37
5 changed files with 249 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

2
.gitignore vendored
View file

@ -1,5 +1,7 @@
*.go
*.log
*.o
*.trs
*~
.deps
.dirstamp

11
Makefile.am
View file

@ -61,6 +61,15 @@ modules = \
$(dist_mcronscript_DATA) \
src/mcron/config.scm
TEST_EXTENSIONS = .scm
AM_TESTS_ENVIRONMENT = env GUILE_AUTO_COMPILE='0'
SCM_LOG_DRIVER = \
$(builddir)/pre-inst-env $(GUILE) \
$(srcdir)/build-aux/test-driver.scm
TESTS = tests/job-specifier.scm
# Unset 'GUILE_LOAD_COMPILED_PATH' altogether while compiling. Otherwise, if
# $GUILE_LOAD_COMPILED_PATH contains $(mcronmoduledir), we may find .go files
# in there that are newer than the local .scm files (for instance because the
@ -124,7 +133,7 @@ uninstall-hook:
rm -f $(fpp){cron,crontab}$(EXEEXT); \
fi
EXTRA_DIST = BUGS
EXTRA_DIST = BUGS $(TESTS)
DISTCLEANFILES = src/config.scm
CLEANFILES = \
$(modules:%.scm=%.go) \

193
build-aux/test-driver.scm Normal file
View file

@ -0,0 +1,193 @@
;;;; test-driver.scm - Guile test driver for Automake testsuite harness
(define script-version "2016-05-09.22") ;UTC
;;; Copyright (C) 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/>.
;;;
;;; As a special exception to the GNU General Public License, if you
;;; distribute this file as part of a program that contains a configuration
;;; script generated by Autoconf, you may include it under the same
;;; distribution terms that you use for the rest of that program.
;;;; 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.
;;;
;;;; Code:
(use-modules (ice-9 getopt-long)
(ice-9 pretty-print)
(srfi srfi-26)
(srfi srfi-64))
(define (show-help)
(display "Usage:
test-driver --test-name=NAME --log-file=PATH --trs-file=PATH
[--expect-failure={yes|no}] [--color-tests={yes|no}]
[--enable-hard-errors={yes|no}] [--brief={yes|no}}] [--]
TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS]
The '--test-name', '--log-file' and '--trs-file' options are mandatory.\n"))
(define %options
'((test-name (value #t))
(log-file (value #t))
(trs-file (value #t))
(color-tests (value #t))
(expect-failure (value #t)) ;XXX: not implemented yet
(enable-hard-errors (value #t)) ;not implemented in SRFI-64
(brief (value #t))
(help (single-char #\h) (value #f))
(version (single-char #\V) (value #f))))
(define (option->boolean options key)
"Return #t if the value associated with KEY in OPTIONS is \"yes\"."
(and=> (option-ref options key #f) (cut string=? <> "yes")))
(define* (test-display field value #:optional (port (current-output-port))
#:key pretty?)
"Display \"FIELD: VALUE\\n\" on PORT."
(if pretty?
(begin
(format port "~A:~%" field)
(pretty-print value port #:per-line-prefix "+ "))
(format port "~A: ~A~%" field value)))
(define* (result->string symbol #:key colorize?)
"Return SYMBOL as an upper case string. Use colors when COLORIZE is #t."
(let ((result (string-upcase (symbol->string symbol))))
(if colorize?
(string-append (case symbol
((pass) "") ;green
((xfail) "") ;light green
((skip) "") ;blue
((fail xpass) "") ;red
((error) "")) ;magenta
result
"") ;no color
result)))
(define* (test-runner-gnu test-name #:key color? brief? out-port trs-port)
"Return an custom SRFI-64 test runner. TEST-NAME is a string specifying the
file name of the current the test. COLOR? specifies whether to use colors,
and BRIEF?, well, you know. OUT-PORT and TRS-PORT must be output ports. The
current output port is supposed to be redirected to a '.log' file."
(define (test-on-test-begin-gnu runner)
;; Procedure called at the start of an individual test case, before the
;; test expression (and expected value) are evaluated.
(let ((result (cute assq-ref (test-result-alist runner) <>)))
(test-display "test-name" (result 'test-name))
(test-display "location"
(string-append (result 'source-file) ":"
(number->string (result 'source-line))))
(test-display "source" (result 'source-form) #:pretty? #t)))
(define (test-on-test-end-gnu runner)
;; Procedure called at the end of an individual test case, when the result
;; of the test is available.
(let* ((results (test-result-alist runner))
(result? (cut assq <> results))
(result (cut assq-ref results <>)))
(unless brief?
;; Display the result of each test case on the console.
(test-display
(result->string (test-result-kind runner) #:colorize? color?)
(string-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.
;;;
(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 (string-append (getcwd) "/" (car (option '() '(""))))))
(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.

1
configure.ac
View file

@ -26,6 +26,7 @@ AC_INIT([GNU Mcron], [1.0.8], [bug-mcron@gnu.org])
AC_CONFIG_HEADER([src/config.h])
AC_CONFIG_SRCDIR([src/mcron.c])
AC_CONFIG_AUX_DIR([build-aux])
AC_REQUIRE_AUX_FILE([test-driver.scm])
AM_INIT_AUTOMAKE([subdir-objects])
AM_SILENT_RULES([yes]) # enables silent rules by default

43
tests/job-specifier.scm Normal file
View file

@ -0,0 +1,43 @@
;;;; job-specifier.scm -- tests for (mcron job-specifier) module
;;; Copyright © 2016 Mathieu Lirzin <mthl@gnu.org>
;;;
;;; This file is part of GNU Mcron.
;;;
;;; GNU Mcron 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.
;;;
;;; GNU Mcron 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 GNU Mcron. If not, see <http://www.gnu.org/licenses/>.
(use-modules (srfi srfi-64)
(mcron job-specifier))
(test-begin "job-specifier")
(test-equal "range: basic"
'(0 1 2 3 4 5 6 7 8 9)
(range 0 10))
(test-equal "range: positive step"
'(0 2 4 6 8)
(range 0 10 2))
(test-assert "range: zero step"
;; Since this behavior is undefined, only check if range doesn't crash.
(range 0 5 0))
(test-assert "range: negative step"
;; Since this behavior is undefined, only check if range doesn't crash.
(range 0 5 -2))
(test-assert "range: reverse boundaries"
(range 10 3))
(test-end)