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: }