tests/mk-script

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