coreutils/tests/mk-script

#! /usr/bin/perl -w
# -*- perl -*-
# Make test scripts.

# Copyright (C) 1998, 2000, 2001, 2002, 2003, 2005 Free Software
# Foundation, Inc.

# This program is free software: you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 3 of the License, or
# (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program.  If not, see <http://www.gnu.org/licenses/>.

my $In = '.I';
my $Out = '.O';
my $Exp = '.X';
my $Err = '.E';

require 5.002;
use strict;
use POSIX qw (assert);

(my $ME = $0) =~ s|.*/||;

BEGIN { push @INC, '.' if '.' ne '.'; }
use Test;

my $srcdir = shift;

sub validate
{
  my %seen;
  my %seen_8dot3;

  my $bad_test_name;
  my $test_vector;
  foreach $test_vector (Test::test_vector ())
    {
      my ($test_name, $flags, $in_spec, $expected, $e_ret_code, $rest) =
	@$test_vector;
      die "$0: wrong number of elements in test $test_name\n"
	if (!defined $e_ret_code || defined $rest);
      assert (!ref $test_name);
      assert (!ref $flags);
      assert (!ref $e_ret_code);

      die "$0: duplicate test name \`$test_name'\n"
	if (defined $seen{$test_name});
      $seen{$test_name} = 1;

      if (0)
	{
	  my $t8 = lc substr $test_name, 0, 8;
	  if ($seen_8dot3{$t8})
	    {
	      warn "$ME: 8.3 test name conflict: "
		. "$test_name, $seen_8dot3{$t8}\n";
	      $bad_test_name = 1;
	    }
	  $seen_8dot3{$t8} = $test_name;
	}
    }

  $bad_test_name
    and exit 1;
}

# Given a spec for the input file(s) or expected output file of a single
# test, create a file for any string.  A file is created for each literal
# string -- not for named files.  Whether a perl `string' is treated as
# a string to be put in a file for a test or the name of an existing file
# depends on how many references have to be traversed to get from
# the top level variable to the actual string literal.
# If $SPEC is a literal Perl string (not a reference), then treat $SPEC
# as the contents of a file.
# If $SPEC is a hash reference, then there are no inputs.
# If $SPEC is an array reference, consider each element of the array.
# If the element is a string reference, treat the string as the name of
# an existing file.  Otherwise, the element must be a string and is treated
# just like a scalar $SPEC.  When a file is created, its name is derived
# from the name TEST_NAME of the corresponding test and the TYPE of file.
# E.g., the inputs for test `3a' would be named t3a.in1 and t3a.in2, and
# the expected output for test `7c' would be named t7c.exp.
#
# Also, return two lists of file names:
# - maintainer-generated files -- names of files created by this function
# - files named explicitly in Test.pm

sub spec_to_list ($$$)
{
  my ($spec, $test_name, $type) = @_;

  assert ($type eq $In || $type eq $Exp);

  my @explicit_file;
  my @maint_gen_file;
  my @content_string;

  # If SPEC is a hash reference, return empty lists.
  if (ref $spec eq 'HASH')
    {
      assert ($type eq $In);
      return {
	EXPLICIT => \@explicit_file,
	MAINT_GEN => \@maint_gen_file
	};
    }

  if (ref $spec)
    {
      assert (ref $spec eq 'ARRAY' || ref $spec eq 'HASH');
      my $file_spec;
      foreach $file_spec (@$spec)
	{
	  # A file spec may be a string or a reference.
	  # If it's a string, that string is to be the contents of a
	  # generated (by this script) file with name derived from the
	  # name of this test.
	  # If it's a reference, then it must be the name of an existing
	  # file.
	  if (ref $file_spec)
	    {
	      my $r = ref $file_spec;
	      die "bad test: $test_name is $r\n"
		if ref $file_spec ne 'SCALAR';
	      my $existing_file = $$file_spec;
	      # FIXME: make sure $existing_file exists somewhere.
	      push (@explicit_file, $existing_file);
	    }
	  else
	    {
	      push (@content_string, $file_spec);
	    }
	}
    }
  else
    {
      push (@content_string, $spec);
    }

  my $i = 1;
  my $file_contents;
  foreach $file_contents (@content_string)
    {
      my $suffix = (@content_string > 1 ? $i : '');
      my $maint_gen_file = "$test_name$type$suffix";
      push (@maint_gen_file, $maint_gen_file);
      open (F, ">$srcdir/$maint_gen_file") || die "$0: $maint_gen_file: $!\n";
      print F $file_contents;
      close (F) || die "$0: $maint_gen_file: $!\n";
      ++$i;
    }

  my $n_fail = 0;
  foreach $i (@explicit_file, @maint_gen_file)
    {
      my $max_len = 14;
      if (length ($i) > $max_len)
	{
	  warn "$0: $i: generated test file name would be longer than"
	    . " $max_len characters\n";
	  ++$n_fail;
	}
    }
  exit (1) if $n_fail;

  my %h = (
    EXPLICIT => \@explicit_file,
    MAINT_GEN => \@maint_gen_file
  );

  return \%h;
}

sub wrap
{
  my ($preferred_line_len, @tok) = @_;
  assert ($preferred_line_len > 0);
  my @lines;
  my $line = '';
  my $word;
  foreach $word (@tok)
    {
      if ($line && length ($line) + 1 + length ($word) > $preferred_line_len)
	{
	  push (@lines, $line);
	  $line = $word;
	  next;
	}
      my $sp = ($line ? ' ' : '');
      $line .= "$sp$word";
    }
  push (@lines, $line);
  return @lines;
}

# ~~~~~~~ main ~~~~~~~~
{
  $| = 1;

  die "Usage: $0: srcdir program-name\n" if @ARGV != 1;

  my $xx = $ARGV[0];

  if ($xx eq '--list')
    {
      validate ();
      # Output three lists of files:
      # EXPLICIT -- file names specified in Test.pm
      # MAINT_GEN -- maintainer-generated files
      # RUN_GEN -- files created when running the tests
      my $test_vector;
      my @exp;
      my @maint;
      my @run;
      foreach $test_vector (Test::test_vector ())
	{
	  my ($test_name, $flags, $in_spec, $exp_spec, $e_ret_code)
	    = @$test_vector;

	  push (@run, ("$test_name$Out", "$test_name$Err"));

	  my $in = spec_to_list ($in_spec, $test_name, $In);
	  push (@exp, @{$in->{EXPLICIT}});
	  push (@maint, @{$in->{MAINT_GEN}});

	  my $e = spec_to_list ($exp_spec, $test_name, $Exp);
	  push (@exp, @{$e->{EXPLICIT}});
	  push (@maint, @{$e->{MAINT_GEN}});
	}

      # The list of explicitly mentioned files may contain duplicates.
      # Eliminated any duplicates.
      my %e = map {$_ => 1} @exp;
      @exp = sort keys %e;

      my $len = 77;
      print join (" \\\n", wrap ($len, 'explicit =', @exp)), "\n";
      print join (" \\\n", wrap ($len, 'maint_gen =', @maint)), "\n";
      print join (" \\\n", wrap ($len, 'run_gen =', @run)), "\n";

      exit 0;
    }

  print <<EOF1;
#! /bin/sh
# This script was generated automatically by $ME.
case \$# in
  0\) xx='$xx';;
  *\) xx="\$1";;
esac
test "\$VERBOSE" && echo=echo || echo=:
\$echo testing program: \$xx
errors=0
test "\$srcdir" || srcdir=.
test "\$VERBOSE" && \$xx --version 2> /dev/null

# Make sure we get English translations.
LANGUAGE=C
export LANGUAGE
LC_ALL=C
export LC_ALL
LANG=C
export LANG

EOF1

  validate ();

  my $n_tests = 0;
  my $test_vector;
  foreach $test_vector (Test::test_vector ())
    {
      my ($test_name, $flags, $in_spec, $exp_spec, $e_ret_code)
	= @$test_vector;

      my $in = spec_to_list ($in_spec, $test_name, $In);

      my @srcdir_rel_in_file;
      my $f;
      foreach $f (@{$in->{EXPLICIT}}, @{$in->{MAINT_GEN}})
	{
	  push (@srcdir_rel_in_file, "\$srcdir/$f");
	}

      my $exp = spec_to_list ($exp_spec, $test_name, $Exp);
      my @all = (@{$exp->{EXPLICIT}}, @{$exp->{MAINT_GEN}});
      assert (@all == 1);
      my $exp_name = "\$srcdir/$all[0]";
      my $out = "$test_name$Out";
      my $err_output = "$test_name$Err";

      my %valid_via = map {$_ => 1} qw (REDIR FILE PIPE);
      my %via_msg_string = (REDIR => '<', FILE => 'F', PIPE => '|');

      # Inhibit warnings about `used only once'.
      die if 0 && $Test::input_via{$test_name} && $Test::input_via_default;
      die if 0 && $Test::env{$test_name} && $Test::env_default;

      my $vias = $Test::input_via{$test_name} || $Test::input_via_default
	|| {FILE => 0};

      my $n_vias = keys %$vias;
      my $via;
      foreach $via (sort keys %$vias)
	{
	  my $cmd;
	  my $val = $vias->{$via};
	  my $via_msg = ($n_vias == 1 ? '' : $via_msg_string{$via});
	  my $file_args = join (' ', @srcdir_rel_in_file);

	  my $env = $Test::env{$test_name} || $Test::env_default || [''];
	  @$env == 1
	    or die "$ME: unexpected environment: @$env\n";
	  $env = $env->[0];
	  my $env_prefix = ($env ? "$env " : '');

	  if ($via eq 'FILE')
	    {
	      $cmd = "$env_prefix\$xx $flags $file_args > $out 2> $err_output";
	    }
	  elsif ($via eq 'PIPE')
	    {
	      $via_msg = "|$val" if $val;
	      $val ||= 'cat';
	      $cmd = "$val $file_args | $env_prefix\$xx $flags"
		. " > $out 2> $err_output";
	    }
	  else
	    {
	      assert (@srcdir_rel_in_file == 1);
	      $cmd = "$env_prefix\$xx $flags"
		. " < $file_args > $out 2> $err_output";
	    }

	  my $e = $env;
	  my $sep = ($via_msg && $e ? ':' : '');
	  my $msg = "$e$sep$via_msg";
	  $msg = "($msg)" if $msg;
	  my $t_name = "$test_name$msg";
	  ++$n_tests;
	  print <<EOF;
$cmd
code=\$?
if test \$code != $e_ret_code; then
  \$echo "Test $t_name failed: \$xx return code \$code differs from expected value $e_ret_code" 1>&2
  errors=`expr \$errors + 1`
else
  cmp $out $exp_name > /dev/null 2>&1
  case \$? in
    0) if test "\$VERBOSE"; then \$echo "passed $t_name"; fi;;
    1) \$echo "Test $t_name failed: files $out and $exp_name differ" 1>&2
       (diff -c $out $exp_name) 2> /dev/null
       errors=`expr \$errors + 1`;;
    2) \$echo "Test $t_name may have failed." 1>&2
       \$echo The command \"cmp $out $exp_name\" failed. 1>&2
       errors=`expr \$errors + 1`;;
  esac
fi
test -s $err_output || rm -f $err_output
EOF
	}
    }
  print <<EOF3
if test \$errors = 0; then
  \$echo Passed all $n_tests tests. 1>&2
else
  \$echo Failed \$errors tests. 1>&2
fi
test \$errors = 0 || errors=1
exit \$errors
EOF3
}