#! @PERL@ -w # -*- perl -*- # @configure_input@ my $In = '.I'; my $Out = '.O'; my $Exp = '.X'; my $Err = '.E'; require 5.002; use strict; use POSIX qw (assert); BEGIN { push @INC, '@srcdir@' if '@srcdir@' ne '.'; } use Test; my $srcdir = '@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 "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 }