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.
This commit is contained in:
David Thompson
parent
32883938eb
commit
397bc485d4
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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 \
|
||||
|
|
|
|||
|
|
@ -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:
|
||||
|
|
@ -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])
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
|
|
@ -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 $?
|
||||
|
|
@ -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))))
|
||||
Loading…
Reference in New Issue