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