5 # Copyright (C) 1998, 2000, 2001, 2002, 2003, 2005 Free Software
8 # This program is free software: you can redistribute it and/or modify
9 # it under the terms of the GNU General Public License as published by
10 # the Free Software Foundation, either version 3 of the License, or
11 # (at your option) any later version.
13 # This program is distributed in the hope that it will be useful,
14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 # GNU General Public License for more details.
18 # You should have received a copy of the GNU General Public License
19 # along with this program. If not, see <http://www.gnu.org/licenses/>.
28 use POSIX qw
(assert
);
30 (my $ME = $0) =~ s
|.*/||;
32 BEGIN { push @INC, '.' if '.' ne '.'; }
44 foreach $test_vector (Test
::test_vector
())
46 my ($test_name, $flags, $in_spec, $expected, $e_ret_code, $rest) =
48 die "$0: wrong number of elements in test $test_name\n"
49 if (!defined $e_ret_code || defined $rest);
50 assert
(!ref $test_name);
52 assert
(!ref $e_ret_code);
54 die "$0: duplicate test name \`$test_name'\n"
55 if (defined $seen{$test_name});
56 $seen{$test_name} = 1;
60 my $t8 = lc substr $test_name, 0, 8;
63 warn "$ME: 8.3 test name conflict: "
64 . "$test_name, $seen_8dot3{$t8}\n";
67 $seen_8dot3{$t8} = $test_name;
75 # Given a spec for the input file(s) or expected output file of a single
76 # test, create a file for any string. A file is created for each literal
77 # string -- not for named files. Whether a perl `string' is treated as
78 # a string to be put in a file for a test or the name of an existing file
79 # depends on how many references have to be traversed to get from
80 # the top level variable to the actual string literal.
81 # If $SPEC is a literal Perl string (not a reference), then treat $SPEC
82 # as the contents of a file.
83 # If $SPEC is a hash reference, then there are no inputs.
84 # If $SPEC is an array reference, consider each element of the array.
85 # If the element is a string reference, treat the string as the name of
86 # an existing file. Otherwise, the element must be a string and is treated
87 # just like a scalar $SPEC. When a file is created, its name is derived
88 # from the name TEST_NAME of the corresponding test and the TYPE of file.
89 # E.g., the inputs for test `3a' would be named t3a.in1 and t3a.in2, and
90 # the expected output for test `7c' would be named t7c.exp.
92 # Also, return two lists of file names:
93 # - maintainer-generated files -- names of files created by this function
94 # - files named explicitly in Test.pm
96 sub spec_to_list
($$$)
98 my ($spec, $test_name, $type) = @_;
100 assert
($type eq $In || $type eq $Exp);
106 # If SPEC is a hash reference, return empty lists.
107 if (ref $spec eq 'HASH')
109 assert
($type eq $In);
111 EXPLICIT
=> \
@explicit_file,
112 MAINT_GEN
=> \
@maint_gen_file
118 assert
(ref $spec eq 'ARRAY' || ref $spec eq 'HASH');
120 foreach $file_spec (@
$spec)
122 # A file spec may be a string or a reference.
123 # If it's a string, that string is to be the contents of a
124 # generated (by this script) file with name derived from the
126 # If it's a reference, then it must be the name of an existing
130 my $r = ref $file_spec;
131 die "bad test: $test_name is $r\n"
132 if ref $file_spec ne 'SCALAR';
133 my $existing_file = $$file_spec;
134 # FIXME: make sure $existing_file exists somewhere.
135 push (@explicit_file, $existing_file);
139 push (@content_string, $file_spec);
145 push (@content_string, $spec);
150 foreach $file_contents (@content_string)
152 my $suffix = (@content_string > 1 ?
$i : '');
153 my $maint_gen_file = "$test_name$type$suffix";
154 push (@maint_gen_file, $maint_gen_file);
155 open (F
, ">$srcdir/$maint_gen_file") || die "$0: $maint_gen_file: $!\n";
156 print F
$file_contents;
157 close (F
) || die "$0: $maint_gen_file: $!\n";
162 foreach $i (@explicit_file, @maint_gen_file)
165 if (length ($i) > $max_len)
167 warn "$0: $i: generated test file name would be longer than"
168 . " $max_len characters\n";
175 EXPLICIT
=> \
@explicit_file,
176 MAINT_GEN
=> \
@maint_gen_file
184 my ($preferred_line_len, @tok) = @_;
185 assert
($preferred_line_len > 0);
191 if ($line && length ($line) + 1 + length ($word) > $preferred_line_len)
193 push (@lines, $line);
197 my $sp = ($line ?
' ' : '');
200 push (@lines, $line);
204 # ~~~~~~~ main ~~~~~~~~
208 die "Usage: $0: srcdir program-name\n" if @ARGV != 1;
215 # Output three lists of files:
216 # EXPLICIT -- file names specified in Test.pm
217 # MAINT_GEN -- maintainer-generated files
218 # RUN_GEN -- files created when running the tests
223 foreach $test_vector (Test
::test_vector
())
225 my ($test_name, $flags, $in_spec, $exp_spec, $e_ret_code)
228 push (@run, ("$test_name$Out", "$test_name$Err"));
230 my $in = spec_to_list
($in_spec, $test_name, $In);
231 push (@exp, @
{$in->{EXPLICIT
}});
232 push (@maint, @
{$in->{MAINT_GEN
}});
234 my $e = spec_to_list
($exp_spec, $test_name, $Exp);
235 push (@exp, @
{$e->{EXPLICIT
}});
236 push (@maint, @
{$e->{MAINT_GEN
}});
239 # The list of explicitly mentioned files may contain duplicates.
240 # Eliminated any duplicates.
241 my %e = map {$_ => 1} @exp;
245 print join (" \\\n", wrap
($len, 'explicit =', @exp)), "\n";
246 print join (" \\\n", wrap
($len, 'maint_gen =', @maint)), "\n";
247 print join (" \\\n", wrap
($len, 'run_gen =', @run)), "\n";
254 # This script was generated automatically by $ME.
259 test "\$VERBOSE" && echo=echo || echo=:
260 \$echo testing program: \$xx
262 test "\$srcdir" || srcdir=.
263 test "\$VERBOSE" && \$xx --version 2> /dev/null
265 # Make sure we get English translations.
279 foreach $test_vector (Test::test_vector ())
281 my ($test_name, $flags, $in_spec, $exp_spec, $e_ret_code)
284 my $in = spec_to_list ($in_spec, $test_name, $In);
286 my @srcdir_rel_in_file;
288 foreach $f (@{$in->{EXPLICIT}}, @{$in->{MAINT_GEN}})
290 push (@srcdir_rel_in_file, "\$srcdir/$f");
293 my $exp = spec_to_list ($exp_spec, $test_name, $Exp);
294 my @all = (@{$exp->{EXPLICIT}}, @{$exp->{MAINT_GEN}});
296 my $exp_name = "\$srcdir/$all[0]";
297 my $out = "$test_name$Out";
298 my $err_output = "$test_name$Err";
300 my %valid_via = map {$_ => 1} qw (REDIR FILE PIPE);
301 my %via_msg_string = (REDIR => '<', FILE => 'F', PIPE => '|');
303 # Inhibit warnings about `used only once'.
304 die if 0 && $Test::input_via{$test_name} && $Test::input_via_default;
305 die if 0 && $Test::env{$test_name} && $Test::env_default;
307 my $vias = $Test::input_via{$test_name} || $Test::input_via_default
310 my $n_vias = keys %$vias;
312 foreach $via (sort keys %$vias)
315 my $val = $vias->{$via};
316 my $via_msg = ($n_vias == 1 ? '' : $via_msg_string{$via});
317 my $file_args = join (' ', @srcdir_rel_in_file);
319 my $env = $Test::env{$test_name} || $Test::env_default || [''];
321 or die "$ME: unexpected environment: @$env\n";
323 my $env_prefix = ($env ? "$env " : '');
327 $cmd = "$env_prefix\$xx $flags $file_args > $out 2> $err_output";
329 elsif ($via eq 'PIPE')
331 $via_msg = "|$val" if $val;
333 $cmd = "$val $file_args | $env_prefix\$xx $flags"
334 . " > $out 2> $err_output";
338 assert (@srcdir_rel_in_file == 1);
339 $cmd = "$env_prefix\$xx $flags"
340 . " < $file_args > $out 2> $err_output";
344 my $sep = ($via_msg && $e ? ':' : '');
345 my $msg = "$e$sep$via_msg";
346 $msg = "($msg)" if $msg;
347 my $t_name = "$test_name$msg";
352 if test \
$code != $e_ret_code; then
353 \
$echo "Test $t_name failed: \$xx return code \$code differs from expected value $e_ret_code" 1>&2
354 errors
=`expr \$errors + 1`
356 cmp $out $exp_name > /dev/null
2>&1
358 0) if test
"\$VERBOSE"; then \
$echo "passed $t_name"; fi
;;
359 1) \
$echo "Test $t_name failed: files $out and $exp_name differ" 1>&2
360 (diff
-c
$out $exp_name) 2> /dev/null
361 errors
=`expr \$errors + 1`;;
362 2) \
$echo "Test $t_name may have failed." 1>&2
363 \
$echo The command
\"cmp $out $exp_name\" failed
. 1>&2
364 errors
=`expr \$errors + 1`;;
367 test
-s
$err_output || rm
-f
$err_output
372 if test \$errors = 0; then
373 \$echo Passed all $n_tests tests. 1>&2
375 \$echo Failed \$errors tests. 1>&2
377 test \$errors = 0 || errors=1