update qtest to 1.4

git-svn-id: svn+q:///qpdf/trunk@800 71b93d88-0707-0410-a8cf-f5a4172ac649

update qtest to 1.4
git-svn-id: svn+q:///qpdf/trunk@800 71b93d88-0707-0410-a8cf-f5a4172ac649
Jay Berkenbilt
1 parent 9f45538c
Showing 2 changed files with 265 additions and 100 deletions
qtest/bin/qtest-driver
qtest/module/TestDriver.pm
@@ -33,7 +33,7 @@ require TestDriver;
 if ((@ARGV == 1) && ($ARGV[0] eq '--version'))
 {
-    print "$whoami version 1.3\n";
+    print "$whoami version 1.4\n";
     exit 0;
 }
 if ((@ARGV == 1) && ($ARGV[0] eq '--print-path'))
@@ -84,7 +84,8 @@ if (@bindirs)
 	    fatal("can't canonicalize path to bindir $d: $!");
 	push(@path, $abs);
     }
-    my $path = join(':', @path) . ':' . $ENV{'PATH'};
+    my $sep = ($^O eq 'MSWin32' ? ';' : ':');
+    my $path = join($sep, @path) . $sep . $ENV{'PATH'};
     # Delete and explicitly recreate the PATH environment variable.
     # This seems to be more reliable.  If we just reassign, in some
     # cases, the modified environment is not inherited by the child
@@ -112,8 +113,18 @@ $ENV{&#39;IN_TESTSUITE&#39;} = 1;
 # be inspected by impatient test suite runners.  It is not intended to
 # be a "secure" (unpredictable) path.
 my $tempdir = File::Spec->tmpdir() . "/testtemp.$$";
+my $thispid = $$;
-my $file_cleanup = new TestDriver::TmpFileDeleter([$tempdir]);
+END
+{
+    # We have to make sure we don't call this from the child
+    # qtest-driver when fork is called.
+    if ((defined $thispid) && ($$ == $thispid) && (defined $tempdir))
+    {
+	local $?;
+	TestDriver::rmrf($tempdir) if -d $tempdir;
+    }
+}
 $| = 1;
 $SIG{'PIPE'} = 'IGNORE';
@@ -471,6 +482,7 @@ sub parse_tc_file
     return unless defined $tc_input;
     my $tc = new IO::File("<$tc_input") or fatal("can't read $tc_input: $!");
+    binmode $tc;
     while (<$tc>)
     {
 	s/\r?\n$//s;
@@ -480,7 +492,7 @@ sub parse_tc_file
 	{
 	    $tc_ignored_scopes{$1} = 1;
 	}
-	elsif (m/^\s*?(\S.+?)\s+(\d+)$/)
+	elsif (m/^\s*?(\S.+?)\s+(\d+)\s*$/)
 	{
 	    my ($case, $n) = ($1, $2);
 	    if (exists $tc_cases{$case})
@@ -602,6 +614,7 @@ sub tc_do_final_checks
     my %seen_cases = ();
     my $tc = new IO::File("<$tc_log");
+    binmode $tc;
     if ($tc)
     {
 	binmode $tc;
@@ -610,7 +623,7 @@ sub tc_do_final_checks
 	    s/\r?\n$//s;
 	    next if m/^\#/;
 	    next if m/^\s*$/;
-	    if (m/^(.+) (\d+)$/)
+	    if (m/^(.+) (\d+)\s*$/)
 	    {
 		$seen_cases{$1}{$2} = 1;
 	    }
@@ -34,27 +34,6 @@ sub DESTROY
     defined($$pid) && $$pid && kill 15, $$pid;
 }
-package TestDriver::TmpFileDeleter;
-
-use vars qw($f_files);
-$f_files = 'files';
-
-sub new
-{
-    my $class = shift;
-    my $rep = +{+__PACKAGE__ => {} };
-    $rep->{+__PACKAGE__}{$f_files} = shift;
-    bless $rep, $class;
-}
-
-sub DESTROY
-{
-    local $?;
-    my $rep = shift;
-    my $files = ($rep->{+__PACKAGE__}{$f_files});
-    map { TestDriver::rmrf($_) } @$files;
-}
-
 package TestDriver;
 use IO::Handle;
@@ -122,6 +101,14 @@ my $color_red = &quot;&quot;;
 my $color_magenta = "";
 my $color_emph = "";
+# MSWin32 support
+my $in_windows = 0;
+my $winbin = undef;
+if ($^O eq 'MSWin32')
+{
+    $in_windows = 1;
+}
+
 sub get_tty_features
 {
     my $got_size = 0;
@@ -157,6 +144,17 @@ sub get_tty_features
     }
     eval
     {
+	if ($in_windows)
+	{
+	    eval
+	    {
+		# If you don't have this module, you may want to set
+		# the environment variable ANSI_COLORS_DISABLED to 1
+		# to avoid "garbage" output around PASSED, FAILED,
+		# etc.
+		require Win32::Console::ANSI;
+	    }
+	}
 	require Term::ANSIColor;
 	$color_reset = Term::ANSIColor::RESET();
 	$color_green = Term::ANSIColor::GREEN();
@@ -243,7 +241,8 @@ sub new
 	   ($ARGV[10] =~ m/^-stdout-tty=([01])$/) &&
 	   (-d $ARGV[5])))
     {
-	die +__PACKAGE__, ": improper invocation of test driver $0\n";
+	die +__PACKAGE__, ": improper invocation of test driver $0 (" .
+	    join(' ', @ARGV) . ")\n";
     }
     my $fd = ($ARGV[0] eq '-fd') ? $ARGV[1] : undef;
     my $port = ($ARGV[0] eq '-port') ? $ARGV[1] : undef;
@@ -435,7 +434,9 @@ sub prompt
     {
 	print "To avoid question, place answer in" .
 	    " environment variable \$$env\n";
-	if (-t STDIN)
+	# Note: ActiveState perl 5.10.1 gives the wrong answer for -t
+	# STDIN.
+	if ((-t STDIN) && (-t STDOUT))
 	{
 	    print "$msg ";
 	    chop($answer = <STDIN>);
@@ -506,10 +507,13 @@ sub get_start_dir
 #      EXIT_STATUS: the exit status of the command.  Required iff the
 #      intput is specified by COMMAND.  A value of undef means that we
-#      don't care about the exit status of a command.  An integer
-#      value is the ordinary exit status of a command.  A string of
-#      the form SIG:n indicates that the program has exited with
-#      signal n.
+#      don't care about the exit status of a command.  The special
+#      value of '!0' means we allow any abnormal exit status but we
+#      don't care what the specific exit status is.  An integer value
+#      is the ordinary exit status of a command.  A string of the form
+#      SIG:n indicates that the program has exited with signal n.
+#      Note that SIG:n is not reliable in a Windows (non-Cygwin)
+#      environment.
 #      THREAD_DATA: If specified, the test output is expected to
 #      contain multithreaded output with output lines marked by thread
@@ -674,7 +678,7 @@ sub runtest
     my $pid = undef;
     my $pid_killer = new TestDriver::PidKiller(\$pid);
     my $in = new IO::Handle;
-    my $use_tempfile = ($^O eq 'MSWin32');
+    my $use_tempfile = $in_windows;
     my $tempout_status = undef;
     if (defined $in_string)
     {
@@ -692,60 +696,48 @@ sub runtest
     }
     elsif (defined $in_command)
     {
-	my $tempfilename = "$tempdir/tempout";
-	my $tempfile = undef;
-	if ($use_tempfile)
+	if (ref($in_command) eq 'ARRAY')
 	{
-	    $tempfile = new IO::File(">$tempfilename") or
-		die +(+__PACKAGE__,
-		      "->runtest: unable to create $tempfilename: $!\n");
-	    $pid = fork;
-	    croak +__PACKAGE__, "->runtest: fork failed: $!\n"
-		unless defined $pid;
+	    &QTC::TC("testdriver", "TestDriver input command array");
 	}
-	else
+	elsif (ref($in_command) eq '')
 	{
-	    $pid = open($in, "-|");
-	    croak +__PACKAGE__, "->runtest: fork failed: $!\n"
-		unless defined $pid;
+	    &QTC::TC("testdriver", "TestDriver input command string");
 	}
-	if ($pid == 0)
+
+	if ($use_tempfile)
 	{
-	    # child
-	    if (defined $tempfile)
-	    {
-		open(STDOUT, ">&", $tempfile);
-	    }
-	    open(STDERR, ">&STDOUT");
-	    open(STDIN, '<', \ "");
-	    if (ref($in_command) eq 'ARRAY')
-	    {
-		&QTC::TC("testdriver", "TestDriver input command array");
-		exec @$in_command or
-		    croak+(+__PACKAGE__,
-			   "->runtest: unable to run command ",
-			   join(' ', @$in_command), "\n");
-	    }
-	    else
-	    {
-		&QTC::TC("testdriver", "TestDriver input command string");
-		exec $in_command or
-		    croak+(+__PACKAGE__,
-			   "->runtest: unable to run command ",
-			   $in_command, "\n");
-	    }
+	    my $tempout = "$tempdir/tempout";
+	    $tempout_status = $rep->winrun(
+		$in_command, File::Spec->devnull(), $tempout);
+	    open($in, "<$tempout") or
+		croak +(+__PACKAGE__,
+			"->runtest: unable to read from" .
+			" input file $tempout: $!\n");
 	}
 	else
 	{
-	    if (defined $tempfile)
+	    $pid = open($in, "-|");
+	    croak +__PACKAGE__, "->runtest: fork failed: $!\n"
+		unless defined $pid;
+	    if ($pid == 0)
 	    {
-		waitpid($pid, 0);
-		$tempout_status = $?;
-		$pid = undef;
-		open($in, "<$tempfilename") or
-		    croak +(+__PACKAGE__,
-			    "->runtest: unable to read from" .
-			    " input file $tempfilename: $!\n");
+		open(STDERR, ">&STDOUT");
+		open(STDIN, '<', \ "");
+		if (ref($in_command) eq 'ARRAY')
+		{
+		    exec @$in_command or
+			croak+(+__PACKAGE__,
+			       "->runtest: unable to run command ",
+			       join(' ', @$in_command), "\n");
+		}
+		else
+		{
+		    exec $in_command or
+			croak+(+__PACKAGE__,
+			       "->runtest: unable to run command ",
+			       $in_command, "\n");
+		}
 	    }
 	}
     }
@@ -758,21 +750,46 @@ sub runtest
     # Open file handle into which to write the actual output
     my $actual = new IO::File;
     my $actual_file = "$tempdir/actual";
+
     if (defined $in_filter)
     {
 	&QTC::TC("testdriver", "TestDriver filter defined");
+	if ($use_tempfile)
+	{
+	    my $filter_file = "$tempdir/filter";
+	    open(F, ">$filter_file.1") or
+		croak+(+__PACKAGE__,
+		       "->runtest: unable to create $filter_file.1: $!\n");
+	    binmode F;
+	    while (<$in>)
+	    {
+		print F;
+	    }
+	    $in->close();
+	    close(F);
+	    $rep->winrun($in_filter, "$filter_file.1", $filter_file);
+	    open($in, "<$filter_file") or
+		croak +(+__PACKAGE__,
+			"->runtest: unable to read from" .
+			" input file $filter_file: $!\n");
+	    binmode $in;
+	    $in_filter = undef;
+	}
+    }
+    if (defined $in_filter)
+    {
 	# Write through filter to actual file
 	open($actual, "| $in_filter > $actual_file") or
-	    croak +(+__PACKAGE__, ": pipe to filter $in_filter failed: $!\n");
-	binmode $actual;
+	    croak +(+__PACKAGE__,
+		    ": pipe to filter $in_filter failed: $!\n");
     }
     else
     {
 	&QTC::TC("testdriver", "TestDriver filter not defined");
 	open($actual, ">$actual_file") or
 	    die +(+__PACKAGE__, ": write to $actual_file failed: $!\n");
-	binmode $actual;
     }
+    binmode $actual;
     # Write from input to actual output, normalizing spaces and
     # newlines if needed
@@ -815,16 +832,43 @@ sub runtest
 	{
 	    $exit_status = $?;
 	}
-	if (WIFSIGNALED($exit_status))
+	my $exit_status_number = 0;
+	my $exit_status_signal = 0;
+	if ($in_windows)
 	{
-	    &QTC::TC("testdriver", "TestDriver exit status signal");
+	    # WIFSIGNALED et al are not defined.  This is emperically
+	    # what happens with MSYS 1.0.11 and ActiveState Perl
+	    # 5.10.1.
+	    if ($exit_status & 0x8000)
+	    {
+		$exit_status_signal = 1;
+		$exit_status = ($exit_status & 0xfff) >> 8;
+		$exit_status = "SIG:$exit_status";
+	    }
+	    elsif ($exit_status >= 256)
+	    {
+		$exit_status_number = 1;
+		$exit_status = $exit_status >> 8;
+	    }
+	}
+	elsif (WIFSIGNALED($exit_status))
+	{
+	    $exit_status_signal = 1;
 	    $exit_status = "SIG:" . WTERMSIG($exit_status);
 	}
 	elsif (WIFEXITED($exit_status))
 	{
-	    &QTC::TC("testdriver", "TestDriver exit status number");
+	    $exit_status_number = 1;
 	    $exit_status = WEXITSTATUS($exit_status);
 	}
+	if ($exit_status_number)
+	{
+	    &QTC::TC("testdriver", "TestDriver exit status number");
+	}
+	if ($exit_status_signal)
+	{
+	    &QTC::TC("testdriver", "TestDriver exit status signal");
+	}
     }
     $? = 0;
     $actual->close();
@@ -837,9 +881,15 @@ sub runtest
     # Compare exit statuses.  This expression is always true when the
     # input was not from a command.
-    my $status_match = ((! defined $out_exit_status) ||
-			((defined $exit_status) &&
-			 ($exit_status eq $out_exit_status)));
+    if ((defined $out_exit_status) && ($out_exit_status eq '!0'))
+    {
+	&QTC::TC("testdriver", "TestDriver non-zero exit status");
+    }
+    my $status_match =
+	((! defined $out_exit_status) ||
+	 ((defined $exit_status) &&
+	  ( (($out_exit_status eq '!0') && ($exit_status ne 0)) ||
+	    ($exit_status eq $out_exit_status) )));
     # Compare actual output with expected output.
     my $expected_file = undef;
@@ -923,9 +973,9 @@ sub runtest
 	else
 	{
 	    $output_diff = "$tempdir/difference";
-	    my $r = safe_pipe(['diff', '-a', '-u',
-			       $expected_file, $actual_file],
-			      $output_diff);
+	    my $r = $rep->safe_pipe(['diff', '-a', '-u',
+				     $expected_file, $actual_file],
+				    $output_diff);
 	    $output_match = ($r == 0);
 	}
     }
@@ -1228,6 +1278,7 @@ sub print_testid
     my $tc_filename = $ENV{'TC_FILENAME'} || "";
     if ($tc_filename && open(F, ">>$tc_filename"))
     {
+	binmode F;
 	printf F "# $category %2d (%s)\n", $testnum, $description;
 	close(F);
     }
@@ -1331,6 +1382,7 @@ sub analyze_threaded_output
     my ($file, $threads, $seqgroups, $errors) = @_;
     my $sequence_checking = 1;
     open(F, "<$file") or die +__PACKAGE__, ": can't open $file: $!\n";
+    binmode F;
     my $cur_thread = undef;
     while (<F>)
     {
@@ -1376,6 +1428,10 @@ sub handle_line
 		 "$file:$.: no input file for thread $thread; " .
 		 "sequence checking abandoned\n");
 	}
+	else
+	{
+	    binmode $fh;
+	}
 	$threads->{$thread} = $fh;
     }
     my $known = defined($threads->{$thread});
@@ -1463,6 +1519,7 @@ sub output_line
 {
     my ($file, $line) = @_;
     open(O, ">>$file") or die +__PACKAGE__, ": can't open $file: $!\n";
+    binmode O;
     print O $line or die +__PACKAGE__, ": can't append to $file: $!\n";
     close(O) or die +__PACKAGE__, ": close $file failed: $!\n";
 }
@@ -1473,6 +1530,7 @@ sub create_if_missing
     if (! -e $file)
     {
 	open(O, ">$file") or die +__PACKAGE__, ": can't create $file: $!\n";
+	binmode O;
 	print O $line;
 	close(O);
     }
@@ -1485,6 +1543,7 @@ sub split_combined
     my $tempdir = $rep->_tempdir();
     open(C, "<$combined") or die +__PACKAGE__, ": can't open $combined: $!\n";
+    binmode C;
     my %files = ();
     my $last_thread_fh = undef;
     while (<C>)
@@ -1544,6 +1603,7 @@ sub cache_open
 	unlink $file;
 	my $fh = new IO::File(">$file") or
 	    die +__PACKAGE__, ": can't open $file: $!\n";
+	binmode $fh;
 	$cache->{$file} = $fh;
     }
     $cache->{$file};
@@ -1581,20 +1641,13 @@ sub rmrf
 sub safe_pipe
 {
+    my $rep = shift;
     my ($cmd, $outfile) = @_;
     my $result = 0;
-    if ($^O eq 'MSWin32')
+    if ($in_windows)
     {
-	my @cmd = @$cmd;
-	my $cmd_str = shift(@cmd);
-	while (@cmd)
-	{
-	    my $arg = shift(@cmd);
-	    $cmd_str .= " \"$arg\"";
-	}
-	$cmd_str .= " > $outfile 2>&1";
-	$result = system($cmd_str);
+	$result = $rep->winrun($cmd, File::Spec->devnull(), $outfile);
     }
     else
     {
@@ -1624,6 +1677,105 @@ sub safe_pipe
     $result;
 }
+
+sub winrun
+{
+    # This function does several things to make running stuff on
+    # Windows look sort of like running things on UNIX.  It assumes
+    # MinGW perl is running in an MSYS/MinGW environment.
+    #
+    #  * When an MSYS/MinGW program is run with system("..."), its
+    #    newlines generate \r\n, but when it's run from MSYS sh, its
+    #    newlines generate \n.  We want \n for UNIX-like programs.
+    #
+    #  * system("...") in perl doesn't have any special magic to
+    #    handle #! lines in scripts.  A lot of test suites will count
+    #    on that.
+    #
+    #  * There's no Windows equivalent to execve with separate
+    #    arguments, so all sorts of fancy quoting is necessary when *
+    #    dealing with arguments with spaces, etc.
+    #
+    #  * Pipes work unreliably.  Fork emulation is very incomplete.
+    #
+    # To work around these issues, we ensure that everything is
+    # actually executed from the MSYS /bin/sh.  We find the actual
+    # path of that and then write a shell script which we explicitly
+    # invoke as an argument to /bin/sh.  If we have a string that we
+    # want executed with /bin/sh, we include the string in the shell
+    # script.  If we have an array, we pass the array on the
+    # commandline to the shell script and let it preserve spacing.  We
+    # also do our output redirection in the shell script itself since
+    # redirection of STDOUT and STDERR doesn't carry forward to
+    # programs invoked by programs we invoke.  Finally, we filter out
+    # errors generated by the script itself, since it is supposed to
+    # be an invisible buffer for smoother execution of programs.
+    # Experience shows that its output comes from things like printing
+    # the names of signals generated by subsidiary programs.
+
+    my $rep = shift;
+    my ($in_command, $in, $out) = @_;
+    my $tempdir = $rep->_tempdir();
+    my $tempfilename = "$tempdir/winrun.tmp";
+    if (! defined $winbin)
+    {
+	my $comspec = $ENV{'COMSPEC'};
+	$comspec =~ s,\\,/,g;
+	if ((system("sh -c 'cd /bin; $comspec /c cd'" .
+		    " > $tempfilename") == 0) &&
+	    open(F, "<$tempfilename"))
+	{
+	    $winbin = <F>;
+	    close(F);
+	    $winbin =~ s,[\r\n],,g;
+	    $winbin =~ s,\\,/,g;
+	}
+	if (! defined $winbin)
+	{
+	    die +__PACKAGE__, ": unable to find windows path to /bin\n";
+	}
+    }
+    my $script = "$tempdir/tmpscript";
+    open(F, ">$script") or
+	croak +(+__PACKAGE__,
+		"->runtest: unable to open $script to write: $!\n");
+    binmode F;
+    print F "exec >$tempfilename\n";
+    print F "exec 2>&1\n";
+    print F "exec <$in\n";
+    my @cmd = ("$winbin/sh", $script);
+    if (ref($in_command) eq 'ARRAY')
+    {
+	# For debugging, write out the args
+	foreach my $arg (@$in_command)
+	{
+	    print F "# $arg\n";
+	}
+	print F '"$@"', "\n";
+	push(@cmd, @$in_command);
+    }
+    else
+    {
+	print F "$in_command\n";
+    }
+    close(F);
+    my $status = system @cmd;
+    if (open(IN, "<$tempfilename") &&
+	open(OUT, ">$out"))
+    {
+	binmode IN;
+	binmode OUT;
+	while (<IN>)
+	{
+	    next if m/^$script:/;
+	    print OUT;
+	}
+	close(IN);
+	close(OUT);
+    }
+    $status;
+}
+
 1;
 #