utils: Clean up and add tests.

* haunt/utils.scm (flat-map, string-split-at): Add docstring. (file-name-components): Adjust slightly to handle "/". (join-file-name-components): Use prefix string join grammar. (absolute-file-name): Add docstring. * test-env.in: New file. * tests/utils.scm: New file. * Makefile.am (TESTS, TEST_EXTENSIONS, SCM_LOG_COMPILER, AM_SCM_LOG_FLAGS): New variables. * configure.ac: Add test-env pre-processed file. * build-aux/test-driver: New file.
2015-10-14 10:44:00 -04:00
parent 32883938eb
commit 397bc485d4
7 changed files with 287 additions and 5 deletions
--- a/.gitignore
+++ b/.gitignore
@@ -2,7 +2,6 @@ Makefile
 Makefile.in
 /aclocal.m4
 /autom4te.cache/
-/build-aux/
 /config.log
 /config.status
 /configure
@@ -15,3 +14,8 @@ Makefile.in
 /scripts/haunt
 *.tar.gz
 /website/site
+/test-env
+*.log
+*.trs
+/build-aux/install-sh
+/build-aux/missing
--- a/Makefile.am
+++ b/Makefile.am
@@ -69,6 +69,13 @@ SOURCES +=					\

 endif

+TESTS =						\
+  tests/utils.scm
+
+TEST_EXTENSIONS = .scm
+SCM_LOG_COMPILER = $(top_builddir)/test-env $(GUILE)
+AM_SCM_LOG_FLAGS = --no-auto-compile -L "$(top_srcdir)"
+
 EXTRA_DIST +=					\
  pre-inst-env.in				\
  README.md					\
--- a/build-aux/test-driver
+++ b/build-aux/test-driver
@@ -0,0 +1,148 @@
+#!/bin/sh
+# test-driver - basic testsuite driver script.
+
+scriptversion=2015-10-14.01; # UTC
+
+# Copyright (C) 2011-2014 Free Software Foundation, Inc.
+#
+# 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 2, 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.
+
+# This file is maintained in Automake, please report
+# bugs to <bug-automake@gnu.org> or send patches to
+# <automake-patches@gnu.org>.
+
+# Make unconditional expansion of undefined variables an error.  This
+# helps a lot in preventing typo-related bugs.
+set -u
+
+usage_error ()
+{
+  echo "$0: $*" >&2
+  print_usage >&2
+  exit 2
+}
+
+print_usage ()
+{
+  cat <<END
+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}] [--]
+              TEST-SCRIPT [TEST-SCRIPT-ARGUMENTS]
+The '--test-name', '--log-file' and '--trs-file' options are mandatory.
+END
+}
+
+test_name= # Used for reporting.
+log_file=  # Where to save the output of the test script.
+trs_file=  # Where to save the metadata of the test run.
+expect_failure=no
+color_tests=no
+enable_hard_errors=yes
+while test $# -gt 0; do
+  case $1 in
+  --help) print_usage; exit $?;;
+  --version) echo "test-driver $scriptversion"; exit $?;;
+  --test-name) test_name=$2; shift;;
+  --log-file) log_file=$2; shift;;
+  --trs-file) trs_file=$2; shift;;
+  --color-tests) color_tests=$2; shift;;
+  --expect-failure) expect_failure=$2; shift;;
+  --enable-hard-errors) enable_hard_errors=$2; shift;;
+  --) shift; break;;
+  -*) usage_error "invalid option: '$1'";;
+   *) break;;
+  esac
+  shift
+done
+
+missing_opts=
+test x"$test_name" = x && missing_opts="$missing_opts --test-name"
+test x"$log_file"  = x && missing_opts="$missing_opts --log-file"
+test x"$trs_file"  = x && missing_opts="$missing_opts --trs-file"
+if test x"$missing_opts" != x; then
+  usage_error "the following mandatory options are missing:$missing_opts"
+fi
+
+if test $# -eq 0; then
+  usage_error "missing argument"
+fi
+
+if test $color_tests = yes; then
+  # Keep this in sync with 'lib/am/check.am:$(am__tty_colors)'.
+  red='[0;31m' # Red.
+  grn='[0;32m' # Green.
+  lgn='[1;32m' # Light green.
+  blu='[1;34m' # Blue.
+  mgn='[0;35m' # Magenta.
+  std='[m'     # No color.
+else
+  red= grn= lgn= blu= mgn= std=
+fi
+
+do_exit='rm -f $log_file $trs_file; (exit $st); exit $st'
+trap "st=129; $do_exit" 1
+trap "st=130; $do_exit" 2
+trap "st=141; $do_exit" 13
+trap "st=143; $do_exit" 15
+
+# Test script is run here.
+"$@" >$log_file 2>&1
+estatus=$?
+
+if test $enable_hard_errors = no && test $estatus -eq 99; then
+  tweaked_estatus=1
+else
+  tweaked_estatus=$estatus
+fi
+
+case $tweaked_estatus:$expect_failure in
+  0:yes) col=$red res=XPASS recheck=yes gcopy=yes;;
+  0:*)   col=$grn res=PASS  recheck=no  gcopy=no;;
+  77:*)  col=$blu res=SKIP  recheck=no  gcopy=yes;;
+  99:*)  col=$mgn res=ERROR recheck=yes gcopy=yes;;
+  *:yes) col=$lgn res=XFAIL recheck=no  gcopy=yes;;
+  *:*)   col=$red res=FAIL  recheck=yes gcopy=yes;;
+esac
+
+# Report the test outcome and exit status in the logs, so that one can
+# know whether the test passed or failed simply by looking at the '.log'
+# file, without the need of also peaking into the corresponding '.trs'
+# file (automake bug#11814).
+echo "$res $test_name (exit status: $estatus)" >>$log_file
+
+# Report outcome to console.
+echo "${col}${res}${std}: $test_name"
+
+# Register the test result, and other relevant metadata.
+echo ":test-result: $res" > $trs_file
+echo ":global-test-result: $res" >> $trs_file
+echo ":recheck: $recheck" >> $trs_file
+echo ":copy-in-global-log: $gcopy" >> $trs_file
+
+# Local Variables:
+# mode: shell-script
+# sh-indentation: 2
+# eval: (add-hook 'write-file-hooks 'time-stamp)
+# time-stamp-start: "scriptversion="
+# time-stamp-format: "%:y-%02m-%02d.%02H"
+# time-stamp-time-zone: "UTC"
+# time-stamp-end: "; # UTC"
+# End:
--- a/configure.ac
+++ b/configure.ac
@@ -8,6 +8,7 @@ AM_SILENT_RULES([yes])

 AC_CONFIG_FILES([Makefile example/Makefile website/Makefile haunt/config.scm])
 AC_CONFIG_FILES([pre-inst-env], [chmod +x pre-inst-env])
+AC_CONFIG_FILES([test-env], [chmod +x test-env])
 AC_CONFIG_FILES([scripts/haunt], [chmod +x scripts/haunt])

 GUILE_PROGS([2.0.11])
--- a/haunt/utils.scm
+++ b/haunt/utils.scm
@@ -57,9 +57,18 @@ flattened."
                  lst)))

 (define (flat-map proc . lsts)
+  "Apply PROC to each element of each list in LSTS and return a new
+list in which nested lists are concatenated into the result.
+
+For example, the list (1 2 (3)) would be flattened to (1 2 3)."
  (flatten (apply map proc lsts) 1))

 (define (string-split-at str char-pred)
+  "Split STR at the first character that matches CHAR-PRED and return
+a list of one or two strings.  Two strings are returned if the string
+was able to be split, with the character matching CHAR-PRED removed.
+A list containing only STR is returned if CHAR-PRED does not match any
+charcter."
  (let ((i (string-index str char-pred)))
    (if i
        (list (string-take str i)
@@ -68,15 +77,20 @@ flattened."

 (define (file-name-components file-name)
  "Split FILE-NAME into the components delimited by '/'."
-  (if (string-null? file-name)
-      '()
-      (string-split file-name #\/)))
+  (match file-name
+    ("" '())
+    ("/" '(""))
+    (_ (remove string-null? (string-split file-name #\/)))))

 (define (join-file-name-components components)
  "Join COMPONENTS into a file name string."
-  (string-join components "/"))
+  (string-join components "/" 'prefix))

 (define (absolute-file-name file-name)
+  "Return a an absolute file name string relative to the current
+working directory for FILE-NAME, a relative file name string.  If
+FILE-NAME happens to already be absolute, FILE-NAME is returned
+as-is."
  (if (absolute-file-name? file-name)
      file-name
      (string-append (getcwd) "/" file-name)))
--- a/test-env.in
+++ b/test-env.in
@@ -0,0 +1,23 @@
+#!/bin/sh
+
+# Haunt --- Static site generator for GNU Guile
+# Copyright © 2015 David Thompson <davet@gnu.org>
+#
+# This file is part of Haunt.
+#
+# Haunt 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.
+#
+# Haunt 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 Haunt.  If not, see <http://www.gnu.org/licenses/>.
+
+"@abs_top_builddir@/pre-inst-env" "$@"
+
+exit $?
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -0,0 +1,85 @@
+;;; Haunt --- Static site generator for GNU Guile
+;;; Copyright © 2015 David Thompson <davet@gnu.org>
+;;;
+;;; This file is part of Haunt.
+;;;
+;;; Haunt 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.
+;;;
+;;; Haunt 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 Haunt.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (test-utils)
+  #:use-module (srfi srfi-19)
+  #:use-module (srfi srfi-64)
+  #:use-module (haunt utils))
+
+(test-begin "utils")
+
+(test-equal "flatten, all"
+  '(1 2 3 4 5 6)
+  (flatten '(1 (2 3 (4) (5 (6))))))
+
+(test-equal "flatten, limited depth"
+  '(1 2 3 4 5 (6))
+  (flatten '(1 (2 3 (4) (5 (6)))) 2))
+
+(test-equal "flat-map"
+  '(5 7 9)
+  (flat-map (compose list +) '(1 2 3) '(4 5 6)))
+
+(test-equal "string-split-at, no match"
+  '("foo")
+  (string-split-at "foo" #\z))
+
+(test-equal "string-split-at, match"
+  '("foo" "bar")
+  (string-split-at "foo/bar" #\/))
+
+(test-equal "file-name-components, empty string"
+  '()
+  (file-name-components ""))
+
+(test-equal "file-name-components, root directory"
+  '("")
+  (file-name-components "/"))
+
+(test-equal "file-name-components, full file name"
+  '("share" "haunt")
+  (file-name-components "/share/haunt"))
+
+(test-equal "join-file-name-components"
+  "/share/haunt/info/haunt.info"
+  (join-file-name-components '("share" "haunt" "info" "haunt.info")))
+
+(test-equal "absolute-file-name, already absolute"
+  "/share/haunt"
+  (absolute-file-name "/share/haunt"))
+
+(test-equal "absolute-file-name, relative file name"
+  (string-append (getcwd) "/share/haunt")
+  (absolute-file-name "share/haunt"))
+
+(test-equal "take-up-to, less than n elements"
+  '(1 2 3)
+  (take-up-to 4 '(1 2 3)))
+
+(test-equal "take-up-to, more than n elements"
+  '(1 2)
+  (take-up-to 2 '(1 2 3)))
+
+(test-equal "string->date*"
+  (make-date 0 0 15 06 05 09 2015 (date-zone-offset (current-date)))
+  (string->date* "2015-09-05 06:15"))
+
+(test-end)
+
+
+(exit (zero? (test-runner-fail-count (test-runner-current))))