5 files changed, 249 insertions, 1 deletions

diff --git a/.gitignore b/.gitignore
index d4fc72a..b998b13 100644
--- a/.gitignore
+++ b/.gitignore
@@ -1,5 +1,7 @@
 *.go
+*.log
 *.o
+*.trs
 *~
 .deps
 .dirstamp
diff --git a/Makefile.am b/Makefile.am
index ec98ef3..020aac6 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -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) \
diff --git a/build-aux/test-driver.scm b/build-aux/test-driver.scm
new file mode 100644
index 0000000..01edf93
--- /dev/null
+++ b/build-aux/test-driver.scm
@@ -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.
diff --git a/configure.ac b/configure.ac
index c6c77d9..892eb19 100644
--- a/configure.ac
+++ b/configure.ac
@@ -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
 
diff --git a/tests/job-specifier.scm b/tests/job-specifier.scm
new file mode 100644
index 0000000..889530b
--- /dev/null
+++ b/tests/job-specifier.scm
@@ -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)