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