tests/mk-script

   1 #! /usr/bin/perl -w
   2 # -*- perl -*-
   3 # Make test scripts.
   4
   5 # Copyright (C) 1998, 2000, 2001, 2002, 2003, 2005 Free Software
   6 # Foundation, Inc.
   7
   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 2 of the License, or
  11 # (at your option) any later version.
  12
  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.
  17
  18 # You should have received a copy of the GNU General Public License
  19 # along with this program; if not, write to the Free Software
  20 # Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  21 # 02110-1301, USA.
  22
  23 my $In = '.I';
  24 my $Out = '.O';
  25 my $Exp = '.X';
  26 my $Err = '.E';
  27
  28 require 5.002;
  29 use strict;
  30 use POSIX qw (assert);
  31
  32 (my $ME = $0) =~ s|.*/||;
  33
  34 BEGIN { push @INC, '.' if '.' ne '.'; }
  35 use Test;
  36
  37 my $srcdir = shift;
  38
  39 sub validate
  40 {
  41   my %seen;
  42   my %seen_8dot3;
  43
  44   my $bad_test_name;
  45   my $test_vector;
  46   foreach $test_vector (Test::test_vector ())
  47     {
  48       my ($test_name, $flags, $in_spec, $expected, $e_ret_code, $rest) =
  49         @$test_vector;
  50       die "$0: wrong number of elements in test $test_name\n"
  51         if (!defined $e_ret_code || defined $rest);
  52       assert (!ref $test_name);
  53       assert (!ref $flags);
  54       assert (!ref $e_ret_code);
  55
  56       die "$0: duplicate test name \`$test_name'\n"
  57         if (defined $seen{$test_name});
  58       $seen{$test_name} = 1;
  59
  60       if (0)
  61         {
  62           my $t8 = lc substr $test_name, 0, 8;
  63           if ($seen_8dot3{$t8})
  64             {
  65               warn "$ME: 8.3 test name conflict: "
  66                 . "$test_name, $seen_8dot3{$t8}\n";
  67               $bad_test_name = 1;
  68             }
  69           $seen_8dot3{$t8} = $test_name;
  70         }
  71     }
  72
  73   $bad_test_name
  74     and exit 1;
  75 }
  76
  77 # Given a spec for the input file(s) or expected output file of a single
  78 # test, create a file for any string.  A file is created for each literal
  79 # string -- not for named files.  Whether a perl `string' is treated as
  80 # a string to be put in a file for a test or the name of an existing file
  81 # depends on how many references have to be traversed to get from
  82 # the top level variable to the actual string literal.
  83 # If $SPEC is a literal Perl string (not a reference), then treat $SPEC
  84 # as the contents of a file.
  85 # If $SPEC is a hash reference, then there are no inputs.
  86 # If $SPEC is an array reference, consider each element of the array.
  87 # If the element is a string reference, treat the string as the name of
  88 # an existing file.  Otherwise, the element must be a string and is treated
  89 # just like a scalar $SPEC.  When a file is created, its name is derived
  90 # from the name TEST_NAME of the corresponding test and the TYPE of file.
  91 # E.g., the inputs for test `3a' would be named t3a.in1 and t3a.in2, and
  92 # the expected output for test `7c' would be named t7c.exp.
  93 #
  94 # Also, return two lists of file names:
  95 # - maintainer-generated files -- names of files created by this function
  96 # - files named explicitly in Test.pm
  97
  98 sub spec_to_list ($$$)
  99 {
 100   my ($spec, $test_name, $type) = @_;
 101
 102   assert ($type eq $In || $type eq $Exp);
 103
 104   my @explicit_file;
 105   my @maint_gen_file;
 106   my @content_string;
 107
 108   # If SPEC is a hash reference, return empty lists.
 109   if (ref $spec eq 'HASH')
 110     {
 111       assert ($type eq $In);
 112       return {
 113         EXPLICIT => \@explicit_file,
 114         MAINT_GEN => \@maint_gen_file
 115         };
 116     }
 117
 118   if (ref $spec)
 119     {
 120       assert (ref $spec eq 'ARRAY' || ref $spec eq 'HASH');
 121       my $file_spec;
 122       foreach $file_spec (@$spec)
 123         {
 124           # A file spec may be a string or a reference.
 125           # If it's a string, that string is to be the contents of a
 126           # generated (by this script) file with name derived from the
 127           # name of this test.
 128           # If it's a reference, then it must be the name of an existing
 129           # file.
 130           if (ref $file_spec)
 131             {
 132               my $r = ref $file_spec;
 133               die "bad test: $test_name is $r\n"
 134                 if ref $file_spec ne 'SCALAR';
 135               my $existing_file = $$file_spec;
 136               # FIXME: make sure $existing_file exists somewhere.
 137               push (@explicit_file, $existing_file);
 138             }
 139           else
 140             {
 141               push (@content_string, $file_spec);
 142             }
 143         }
 144     }
 145   else
 146     {
 147       push (@content_string, $spec);
 148     }
 149
 150   my $i = 1;
 151   my $file_contents;
 152   foreach $file_contents (@content_string)
 153     {
 154       my $suffix = (@content_string > 1 ? $i : '');
 155       my $maint_gen_file = "$test_name$type$suffix";
 156       push (@maint_gen_file, $maint_gen_file);
 157       open (F, ">$srcdir/$maint_gen_file") || die "$0: $maint_gen_file: $!\n";
 158       print F $file_contents;
 159       close (F) || die "$0: $maint_gen_file: $!\n";
 160       ++$i;
 161     }
 162
 163   my $n_fail = 0;
 164   foreach $i (@explicit_file, @maint_gen_file)
 165     {
 166       my $max_len = 14;
 167       if (length ($i) > $max_len)
 168         {
 169           warn "$0: $i: generated test file name would be longer than"
 170             . " $max_len characters\n";
 171           ++$n_fail;
 172         }
 173     }
 174   exit (1) if $n_fail;
 175
 176   my %h = (
 177     EXPLICIT => \@explicit_file,
 178     MAINT_GEN => \@maint_gen_file
 179   );
 180
 181   return \%h;
 182 }
 183
 184 sub wrap
 185 {
 186   my ($preferred_line_len, @tok) = @_;
 187   assert ($preferred_line_len > 0);
 188   my @lines;
 189   my $line = '';
 190   my $word;
 191   foreach $word (@tok)
 192     {
 193       if ($line && length ($line) + 1 + length ($word) > $preferred_line_len)
 194         {
 195           push (@lines, $line);
 196           $line = $word;
 197           next;
 198         }
 199       my $sp = ($line ? ' ' : '');
 200       $line .= "$sp$word";
 201     }
 202   push (@lines, $line);
 203   return @lines;
 204 }
 205
 206 # ~~~~~~~ main ~~~~~~~~
 207 {
 208   $| = 1;
 209
 210   die "Usage: $0: srcdir program-name\n" if @ARGV != 1;
 211
 212   my $xx = $ARGV[0];
 213
 214   if ($xx eq '--list')
 215     {
 216       validate ();
 217       # Output three lists of files:
 218       # EXPLICIT -- file names specified in Test.pm
 219       # MAINT_GEN -- maintainer-generated files
 220       # RUN_GEN -- files created when running the tests
 221       my $test_vector;
 222       my @exp;
 223       my @maint;
 224       my @run;
 225       foreach $test_vector (Test::test_vector ())
 226         {
 227           my ($test_name, $flags, $in_spec, $exp_spec, $e_ret_code)
 228             = @$test_vector;
 229
 230           push (@run, ("$test_name$Out", "$test_name$Err"));
 231
 232           my $in = spec_to_list ($in_spec, $test_name, $In);
 233           push (@exp, @{$in->{EXPLICIT}});
 234           push (@maint, @{$in->{MAINT_GEN}});
 235
 236           my $e = spec_to_list ($exp_spec, $test_name, $Exp);
 237           push (@exp, @{$e->{EXPLICIT}});
 238           push (@maint, @{$e->{MAINT_GEN}});
 239         }
 240
 241       # The list of explicitly mentioned files may contain duplicates.
 242       # Eliminated any duplicates.
 243       my %e = map {$_ => 1} @exp;
 244       @exp = sort keys %e;
 245
 246       my $len = 77;
 247       print join (" \\\n", wrap ($len, 'explicit =', @exp)), "\n";
 248       print join (" \\\n", wrap ($len, 'maint_gen =', @maint)), "\n";
 249       print join (" \\\n", wrap ($len, 'run_gen =', @run)), "\n";
 250
 251       exit 0;
 252     }
 253
 254   print <<EOF1;
 255 #! /bin/sh
 256 # This script was generated automatically by $ME.
 257 case \$# in
 258   0\) xx='$xx';;
 259   *\) xx="\$1";;
 260 esac
 261 test "\$VERBOSE" && echo=echo || echo=:
 262 \$echo testing program: \$xx
 263 errors=0
 264 test "\$srcdir" || srcdir=.
 265 test "\$VERBOSE" && \$xx --version 2> /dev/null
 266
 267 # Make sure we get English translations.
 268 LANGUAGE=C
 269 export LANGUAGE
 270 LC_ALL=C
 271 export LC_ALL
 272 LANG=C
 273 export LANG
 274
 275 EOF1
 276
 277   validate ();
 278
 279   my $n_tests = 0;
 280   my $test_vector;
 281   foreach $test_vector (Test::test_vector ())
 282     {
 283       my ($test_name, $flags, $in_spec, $exp_spec, $e_ret_code)
 284         = @$test_vector;
 285
 286       my $in = spec_to_list ($in_spec, $test_name, $In);
 287
 288       my @srcdir_rel_in_file;
 289       my $f;
 290       foreach $f (@{$in->{EXPLICIT}}, @{$in->{MAINT_GEN}})
 291         {
 292           push (@srcdir_rel_in_file, "\$srcdir/$f");
 293         }
 294
 295       my $exp = spec_to_list ($exp_spec, $test_name, $Exp);
 296       my @all = (@{$exp->{EXPLICIT}}, @{$exp->{MAINT_GEN}});
 297       assert (@all == 1);
 298       my $exp_name = "\$srcdir/$all[0]";
 299       my $out = "$test_name$Out";
 300       my $err_output = "$test_name$Err";
 301
 302       my %valid_via = map {$_ => 1} qw (REDIR FILE PIPE);
 303       my %via_msg_string = (REDIR => '<', FILE => 'F', PIPE => '|');
 304
 305       # Inhibit warnings about `used only once'.
 306       die if 0 && $Test::input_via{$test_name} && $Test::input_via_default;
 307       die if 0 && $Test::env{$test_name} && $Test::env_default;
 308
 309       my $vias = $Test::input_via{$test_name} || $Test::input_via_default
 310         || {FILE => 0};
 311
 312       my $n_vias = keys %$vias;
 313       my $via;
 314       foreach $via (sort keys %$vias)
 315         {
 316           my $cmd;
 317           my $val = $vias->{$via};
 318           my $via_msg = ($n_vias == 1 ? '' : $via_msg_string{$via});
 319           my $file_args = join (' ', @srcdir_rel_in_file);
 320
 321           my $env = $Test::env{$test_name} || $Test::env_default || [''];
 322           @$env == 1
 323             or die "$ME: unexpected environment: @$env\n";
 324           $env = $env->[0];
 325           my $env_prefix = ($env ? "$env " : '');
 326
 327           if ($via eq 'FILE')
 328             {
 329               $cmd = "$env_prefix\$xx $flags $file_args > $out 2> $err_output";
 330             }
 331           elsif ($via eq 'PIPE')
 332             {
 333               $via_msg = "|$val" if $val;
 334               $val ||= 'cat';
 335               $cmd = "$val $file_args | $env_prefix\$xx $flags"
 336                 . " > $out 2> $err_output";
 337             }
 338           else
 339             {
 340               assert (@srcdir_rel_in_file == 1);
 341               $cmd = "$env_prefix\$xx $flags"
 342                 . " < $file_args > $out 2> $err_output";
 343             }
 344
 345           my $e = $env;
 346           my $sep = ($via_msg && $e ? ':' : '');
 347           my $msg = "$e$sep$via_msg";
 348           $msg = "($msg)" if $msg;
 349           my $t_name = "$test_name$msg";
 350           ++$n_tests;
 351           print <<EOF;
 352 $cmd
 353 code=\$?
 354 if test \$code != $e_ret_code; then
 355   \$echo "Test $t_name failed: \$xx return code \$code differs from expected value $e_ret_code" 1>&2
 356   errors=`expr \$errors + 1`
 357 else
 358   cmp $out $exp_name > /dev/null 2>&1
 359   case \$? in
 360     0) if test "\$VERBOSE"; then \$echo "passed $t_name"; fi;;
 361     1) \$echo "Test $t_name failed: files $out and $exp_name differ" 1>&2
 362        (diff -c $out $exp_name) 2> /dev/null
 363        errors=`expr \$errors + 1`;;
 364     2) \$echo "Test $t_name may have failed." 1>&2
 365        \$echo The command \"cmp $out $exp_name\" failed. 1>&2
 366        errors=`expr \$errors + 1`;;
 367   esac
 368 fi
 369 test -s $err_output || rm -f $err_output
 370 EOF
 371         }
 372     }
 373   print <<EOF3
 374 if test \$errors = 0; then
 375   \$echo Passed all $n_tests tests. 1>&2
 376 else
 377   \$echo Failed \$errors tests. 1>&2
 378 fi
 379 test \$errors = 0 || errors=1
 380 exit \$errors
 381 EOF3
 382 }