From 470cfd94915fdc37c7c38b1626e16ddc061113dd Mon Sep 17 00:00:00 2001 From: Jim Meyering Date: Wed, 4 Feb 1998 12:41:35 +0000 Subject: . --- tests/mk-script | 338 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 338 insertions(+) create mode 100755 tests/mk-script diff --git a/tests/mk-script b/tests/mk-script new file mode 100755 index 000000000..0f360ac30 --- /dev/null +++ b/tests/mk-script @@ -0,0 +1,338 @@ +#! /usr/bin/perl -w +# -*- perl -*- + +my $In = '.I'; +my $Out = '.O'; +my $Exp = '.X'; +my $Err = '.E'; + +require 5.002; +use strict; +use POSIX qw (assert); + +BEGIN { push @INC, '.' if '.' ne '.'; } +use Test; + +my $srcdir = '.'; + +sub validate +{ + my %seen; + my $test_vector; + foreach $test_vector (Test::test_vector ()) + { + my ($test_name, $flags, $in_spec, $expected, $e_ret_code, $rest) = + @$test_vector; + die "$0: wrong number of elements in test $test_name\n" + if (!defined $e_ret_code || defined $rest); + assert (!ref $test_name); + assert (!ref $flags); + assert (!ref $e_ret_code); + + die "$0: duplicate test name \`$test_name'\n" + if (defined $seen{$test_name}); + $seen{$test_name} = 1; + } +} + +# Given a spec for the input file(s) or expected output file of a single +# test, create a file for any string. A file is created for each literal +# string -- not for named files. Whether a perl `string' is treated as +# a string to be put in a file for a test or the name of an existing file +# depends on how many references have to be traversed to get from +# the top level variable to the actual string literal. +# If $SPEC is a literal Perl string (not a reference), then treat $SPEC +# as the contents of a file. +# If $SPEC is a hash reference, then there are no inputs. +# If $SPEC is an array reference, consider each element of the array. +# If the element is a string reference, treat the string as the name of +# an existing file. Otherwise, the element must be a string and is treated +# just like a scalar $SPEC. When a file is created, its name is derived +# from the name TEST_NAME of the corresponding test and the TYPE of file. +# E.g., the inputs for test `3a' would be named t3a.in1 and t3a.in2, and +# the expected output for test `7c' would be named t7c.exp. +# +# Also, return two lists of file names: +# - maintainer-generated files -- names of files created by this function +# - files named explicitly in Test.pm + +sub spec_to_list ($$$) +{ + my ($spec, $test_name, $type) = @_; + + assert ($type eq $In || $type eq $Exp); + + my @explicit_file; + my @maint_gen_file; + my @content_string; + + # If SPEC is a hash reference, return empty lists. + if (ref $spec eq 'HASH') + { + assert ($type eq $In); + return { + EXPLICIT => \@explicit_file, + MAINT_GEN => \@maint_gen_file + }; + } + + if (ref $spec) + { + assert (ref $spec eq 'ARRAY' || ref $spec eq 'HASH'); + my $file_spec; + foreach $file_spec (@$spec) + { + # A file spec may be a string or a reference. + # If it's a string, that string is to be the contents of a + # generated (by this script) file with name derived from the + # name of this test. + # If it's a reference, then it must be the name of an existing + # file. + if (ref $file_spec) + { + my $r = ref $file_spec; + die "bad test: $test_name is $r\n" + if ref $file_spec ne 'SCALAR'; + my $existing_file = $$file_spec; + # FIXME: make sure $existing_file exists somewhere. + push (@explicit_file, $existing_file); + } + else + { + push (@content_string, $file_spec); + } + } + } + else + { + push (@content_string, $spec); + } + + my $i = 1; + my $file_contents; + foreach $file_contents (@content_string) + { + my $suffix = (@content_string > 1 ? $i : ''); + my $maint_gen_file = "$test_name$type$suffix"; + push (@maint_gen_file, $maint_gen_file); + open (F, ">$srcdir/$maint_gen_file") || die "$0: $maint_gen_file: $!\n"; + print F $file_contents; + close (F) || die "$0: $maint_gen_file: $!\n"; + ++$i; + } + + my $n_fail = 0; + foreach $i (@explicit_file, @maint_gen_file) + { + my $max_len = 14; + if (length ($i) > $max_len) + { + warn "$0: $i: generated test file name would be longer than" + . " $max_len characters\n"; + ++$n_fail; + } + } + exit (1) if $n_fail; + + my %h = ( + EXPLICIT => \@explicit_file, + MAINT_GEN => \@maint_gen_file + ); + + return \%h; +} + +sub wrap +{ + my ($preferred_line_len, @tok) = @_; + assert ($preferred_line_len > 0); + my @lines; + my $line = ''; + my $word; + foreach $word (@tok) + { + if ($line && length ($line) + 1 + length ($word) > $preferred_line_len) + { + push (@lines, $line); + $line = $word; + next; + } + my $sp = ($line ? ' ' : ''); + $line .= "$sp$word"; + } + push (@lines, $line); + return @lines; +} + +# ~~~~~~~ main ~~~~~~~~ +{ + $| = 1; + + die "Usage: $0: program-name\n" if @ARGV != 1; + + my $xx = $ARGV[0]; + + if ($xx eq '--list') + { + validate (); + # Output three lists of files: + # EXPLICIT -- file names specified in Test.pm + # MAINT_GEN -- maintainer-generated files + # RUN_GEN -- files created when running the tests + my $test_vector; + my @exp; + my @maint; + my @run; + foreach $test_vector (Test::test_vector ()) + { + my ($test_name, $flags, $in_spec, $exp_spec, $e_ret_code) + = @$test_vector; + + push (@run, ("$test_name$Out", "$test_name$Err")); + + my $in = spec_to_list ($in_spec, $test_name, $In); + push (@exp, @{$in->{EXPLICIT}}); + push (@maint, @{$in->{MAINT_GEN}}); + + my $e = spec_to_list ($exp_spec, $test_name, $Exp); + push (@exp, @{$e->{EXPLICIT}}); + push (@maint, @{$e->{MAINT_GEN}}); + } + + # The list of explicitly mentioned files may contain duplicates. + # Eliminated any duplicates. + my %e = map {$_ => 1} @exp; + @exp = sort keys %e; + + my $len = 77; + print join (" \\\n", wrap ($len, 'explicit =', @exp)), "\n"; + print join (" \\\n", wrap ($len, 'maint_gen =', @maint)), "\n"; + print join (" \\\n", wrap ($len, 'run_gen =', @run)), "\n"; + + exit 0; + } + + print < /dev/null + +# Make sure we get English translations. +LANGUAGE=C +export LANGUAGE +LC_ALL=C +export LC_ALL +LANG=C +export LANG + +EOF1 + + validate (); + + my $n_tests = 0; + my $test_vector; + foreach $test_vector (Test::test_vector ()) + { + my ($test_name, $flags, $in_spec, $exp_spec, $e_ret_code) + = @$test_vector; + + my $in = spec_to_list ($in_spec, $test_name, $In); + + my @srcdir_rel_in_file; + my $f; + foreach $f (@{$in->{EXPLICIT}}, @{$in->{MAINT_GEN}}) + { + push (@srcdir_rel_in_file, "\$srcdir/$f"); + } + + my $exp = spec_to_list ($exp_spec, $test_name, $Exp); + my @all = (@{$exp->{EXPLICIT}}, @{$exp->{MAINT_GEN}}); + assert (@all == 1); + my $exp_name = "\$srcdir/$all[0]"; + my $out = "$test_name$Out"; + my $err_output = "$test_name$Err"; + + my %valid_via = map {$_ => 1} qw (REDIR FILE PIPE); + my %via_msg_string = (REDIR => '<', FILE => 'F', PIPE => '|'); + + # Inhibit warnings about `used only once'. + die if 0 && $Test::input_via{$test_name} && $Test::input_via_default; + die if 0 && $Test::env{$test_name} && $Test::env_default; + + my $vias = $Test::input_via{$test_name} || $Test::input_via_default + || {FILE => 0}; + + my $n_vias = keys %$vias; + my ($via, $val); + while (($via, $val) = each %$vias) + { + my $cmd; + my $via_msg = ($n_vias == 1 ? '' : $via_msg_string{$via}); + my $file_args = join (' ', @srcdir_rel_in_file); + + if ($via eq 'FILE') + { + $cmd = "\$xx $flags $file_args > $out 2> $err_output"; + } + elsif ($via eq 'PIPE') + { + $via_msg = "|$val" if $val; + $val ||= 'cat'; + $cmd = "$val $file_args | \$xx $flags > $out 2> $err_output"; + } + else + { + assert (@srcdir_rel_in_file == 1); + $cmd = "\$xx $flags < $file_args > $out 2> $err_output"; + } + + my $env = $Test::env{$test_name} || $Test::env_default || ['']; + my $e; + foreach $e (@$env) + { + my $sep = ($via_msg && $e ? ':' : ''); + my $msg = "$e$sep$via_msg"; + $msg = "($msg)" if $msg; + my $t_name = "$test_name$msg"; + my $e_cmd = ($e ? "$e " : ''); + ++$n_tests; + print <&2 + errors=`expr \$errors + 1` +else + cmp $out $exp_name > /dev/null 2>&1 + case \$? in + 0) if test "\$VERBOSE" ; then \$echo "passed $t_name"; fi ;; + 1) \$echo "Test $t_name failed: files $out and $exp_name differ" 1>&2; + errors=`expr \$errors + 1` ;; + 2) \$echo "Test $t_name may have failed." 1>&2; + \$echo The command \"cmp $out $exp_name\" failed. 1>&2 ; + errors=`expr \$errors + 1` ;; + esac +fi +test -s $err_output || rm -f $err_output +EOF + } + } + } + print <&2 +else + \$echo Failed \$errors tests. 1>&2 +fi +test \$errors = 0 || errors=1 +exit \$errors +EOF3 +} -- cgit v1.2.3-70-g09d2