From 9a0b88bf7777c153dc46ace22db74ef24d51583a Mon Sep 17 00:00:00 2001 From: Jay Berkenbilt Date: Tue, 29 Apr 2008 12:55:25 +0000 Subject: update release date to actual date git-svn-id: svn+q:///qpdf/trunk@599 71b93d88-0707-0410-a8cf-f5a4172ac649 --- qtest/module/TestDriver.pm | 1566 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1566 insertions(+) create mode 100644 qtest/module/TestDriver.pm (limited to 'qtest/module') diff --git a/qtest/module/TestDriver.pm b/qtest/module/TestDriver.pm new file mode 100644 index 00000000..6e1fa313 --- /dev/null +++ b/qtest/module/TestDriver.pm @@ -0,0 +1,1566 @@ +# -*- perl -*- +# +# This file is part of qtest. +# +# Copyright 1993-2007, Jay Berkenbilt +# +# QTest is distributed under the terms of version 2.0 of the Artistic +# license which may be found in the source distribution. +# + +# Search for "PUBLIC METHODS" to find the public methods and +# documentation on how to use them. + +require 5.008; +use strict; + +package TestDriver::PidKiller; + +use vars qw($f_pid); +$f_pid = 'pid'; + +sub new +{ + my $class = shift; + my $rep = +{+__PACKAGE__ => {} }; + $rep->{+__PACKAGE__}{$f_pid} = shift; + bless $rep, $class; +} + +sub DESTROY +{ + my $rep = shift; + my $pid = $rep->{+__PACKAGE__}{$f_pid}; + 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; +use IO::File; +use IO::Socket; +use IO::Select; +use POSIX ':sys_wait_h'; +use File::Copy; +use File::Find; +use Carp; +use Cwd; +require QTC; + +# Constants + +# Possible test case outcomes +use constant PASS => 'PASS'; +use constant FAIL => 'FAIL'; + +# Input/Output keys +use constant STRING => 'STRING'; +use constant FILE => 'FILE'; +use constant COMMAND => 'COMMAND'; +use constant FILTER => 'FILTER'; +use constant REGEXP => 'REGEXP'; +use constant EXIT_STATUS => 'EXIT_STATUS'; +use constant THREAD_DATA => 'THREAD_DATA'; +use constant TD_THREADS => 'TD_THREADS'; +use constant TD_SEQGROUPS => 'TD_SEQGROUPS'; + +# Flags +use constant NORMALIZE_NEWLINES => 1 << 0; +use constant NORMALIZE_WHITESPACE => 1 << 1; +use constant EXPECT_FAILURE => 1 << 2; + +# Field names +use vars qw($f_socket $f_origdir $f_tempdir $f_testlog $f_testxml $f_suitename); +$f_socket = 'socket'; +$f_origdir = 'origdir'; +$f_tempdir = 'tempdir'; +$f_testlog = 'testlog'; +$f_testxml = 'testxml'; +$f_suitename = 'suitename'; + +use vars qw($f_passes $f_fails $f_xpasses $f_xfails $f_testnum); +$f_passes = 'passes'; # expected passes +$f_fails = 'fails'; # unexpected failures +$f_xpasses = 'xpasses'; # unexpected passes +$f_xfails = 'xfails'; # expected failures +$f_testnum = 'testnum'; + +# Static Variables + +# QTEST_MARGIN sets the number of spaces to after PASSED or FAILED and +# before the rightmost column of the screen. +my $margin = $ENV{'QTEST_MARGIN'} || 8; +$margin += $ENV{'QTEST_EXTRA_MARGIN'} || 0; + +my $ncols = 80; + +my $color_reset = ""; +my $color_green = ""; +my $color_yellow = ""; +my $color_red = ""; +my $color_magenta = ""; +my $color_emph = ""; + +sub get_tty_features +{ + my $got_size = 0; + eval + { + require Term::ReadKey; + ($ncols, undef, undef, undef) = Term::ReadKey::GetTerminalSize(); + $got_size = 1; + }; + if (! $got_size) + { + eval + { + # Get screen columns if possible + no strict; + local $^W = 0; + local *X; + require 'sys/ioctl.ph'; + if ((defined &TIOCGWINSZ) && open(X, "+ {} }; + + if (@_ != 1) + { + croak "Usage: ", __PACKAGE__, "->new(\"test-suite name\")\n"; + } + my $suitename = shift; + + if (! ((@ARGV == 11) && + (($ARGV[0] eq '-fd') || ($ARGV[0] eq '-port')) && + ($ARGV[2] eq '-origdir') && + ($ARGV[4] eq '-tempdir') && + ($ARGV[6] eq '-testlog') && + ($ARGV[8] eq '-testxml') && + ($ARGV[10] =~ m/^-stdout-tty=([01])$/) && + (-d $ARGV[5]))) + { + die +__PACKAGE__, ": improper invocation of test driver $0\n"; + } + my $fd = ($ARGV[0] eq '-fd') ? $ARGV[1] : undef; + my $port = ($ARGV[0] eq '-port') ? $ARGV[1] : undef; + my $origdir = $ARGV[3]; + my $tempdir = $ARGV[5]; + my $testlogfile = $ARGV[7]; + my $testxmlfile = $ARGV[9]; + my $testlog = new IO::File(">>$testlogfile"); + binmode $testlog; + my $testxml = new IO::File(">>$testxmlfile"); + binmode $testxml; + $ARGV[10] =~ m/=([01])/ or die +__PACKAGE__, ": INTERNAL ERROR in ARGV[10]"; + my $stdout_is_tty = $1; + if ($stdout_is_tty) + { + get_tty_features(); + } + + my $socket; + if (defined $fd) + { + $socket = new IO::Handle; + if (! $socket->fdopen($fd, "w+")) + { + warn +__PACKAGE__, ": unable to open file descriptor $fd.\n"; + warn +__PACKAGE__, " must be created from a program invoked by" . + " the test driver system\n"; + die +__PACKAGE__, ": initialization failed"; + } + } + else + { + $socket = IO::Socket::INET->new( + PeerAddr => '127.0.0.1', PeerPort => $port) or + die "unable to connect to port $port: $!\n"; + } + $socket->autoflush(); + binmode $socket; + + # Do some setup that would ordinarily be reserved for a main + # program. We want test suites to behave in a certain way so tha + # the overall system works as desired. + + # Killing the driver should cause to to exit. Without this, it + # may cause whatever subsidiary program is being run to exit and + # the driver to continue to the next test case. + $SIG{'INT'} = $SIG{'HUP'} = $SIG{'TERM'} = $SIG{'QUIT'} = sub { exit 2 }; + + # Unbuffer our output. + $| = 1; + + $rep->{+__PACKAGE__}{$f_socket} = $socket; + $rep->{+__PACKAGE__}{$f_origdir} = $origdir; + $rep->{+__PACKAGE__}{$f_tempdir} = $tempdir; + $rep->{+__PACKAGE__}{$f_testlog} = $testlog; + $rep->{+__PACKAGE__}{$f_testxml} = $testxml; + $rep->{+__PACKAGE__}{$f_suitename} = $suitename; + $rep->{+__PACKAGE__}{$f_passes} = 0; + $rep->{+__PACKAGE__}{$f_fails} = 0; + $rep->{+__PACKAGE__}{$f_xpasses} = 0; + $rep->{+__PACKAGE__}{$f_xfails} = 0; + $rep->{+__PACKAGE__}{$f_testnum} = 1; + + # Do protocol handshaking with the test driver system + my $init = scalar(<$socket>); + if ($init !~ m/^TEST_DRIVER 1$/) + { + die +__PACKAGE__, ": incorrect protocol with test driver system\n"; + } + $socket->print("TEST_DRIVER_CLIENT 1\n"); + + bless $rep, $class; +} + +sub _socket +{ + my $rep = shift; + $rep->{+__PACKAGE__}{$f_socket}; +} + +sub _tempdir +{ + my $rep = shift; + $rep->{+__PACKAGE__}{$f_tempdir}; +} + +sub _testlog +{ + my $rep = shift; + $rep->{+__PACKAGE__}{$f_testlog}; +} + +sub _testxml +{ + my $rep = shift; + $rep->{+__PACKAGE__}{$f_testxml}; +} + +sub _suitename +{ + my $rep = shift; + $rep->{+__PACKAGE__}{$f_suitename}; +} + +sub _testnum +{ + my $rep = shift; + $rep->{+__PACKAGE__}{$f_testnum} = $_[0] if @_; + $rep->{+__PACKAGE__}{$f_testnum}; +} + +# PUBLIC METHODS + +# Usage: report(n) +# Specify the number of tests that are expected to have been run. +# Please note: the purpose of reporting the number of test cases with +# "report" is as an extra check to make sure that the test suite +# itself didn't have a logic error that caused some test cases to be +# skipped. The argument to "report" should therefore be a hard-coded +# number or a number computed only from static features in the test +# suite. It should not be a number that is counted up during the +# process of running the test suite. Computing this number as a side +# effect of running test cases would defeat the purpose of the number. +# For example, if the test suite consists of an array of test cases, +# and the test suite code iterates through that loop and calls +# "runtest" twice for each element, it would be reasonable to pass an +# expression that includes the size of the array as an argument to +# "report", but it would not be appropriate to have a variable called +# "$ntests" that is incremented each time "runtest" is called and then +# passed to "report". +sub report +{ + my $rep = shift; + croak "Usage: ", __PACKAGE__, "->report(num-tests-expected)\n" + unless @_ && $_[0] =~ m/^\d+$/; + + # Message to test driver system: + # n-expected-tests passes fails unexpected-passes expected-fails + + my @vals = (shift); + push(@vals, map { $rep->{+__PACKAGE__}{$_} } ($f_passes, $f_fails, + $f_xpasses, $f_xfails)); + my $socket = $rep->_socket(); + $socket->print(join(' ', @vals)), "\n"; +} + +# Usage: notify(string) +# Prints the string followed by a newline to standard output of the +# test suite. +sub notify +{ + my $rep = shift; + my $msg = shift; + &QTC::TC("testdriver", "TestDriver notify"); + print $msg, "\n"; +} + +# Usage: emphasize(string) +# Prints the string followed by a newline to standard output of the +# test suite. The string is printed with emphasis if the terminal +# supports color. +sub emphasize +{ + my $rep = shift; + my $msg = shift; + &QTC::TC("testdriver", "TestDriver emphasize"); + print $color_emph, $msg, $color_reset, "\n"; +} + +# Usage: prompt(msg, env, default) +# If the environment variable "env" is set, its value is returned. +# Otherwise, if STDIN is a tty, the user is prompted for an answer +# using msg as the prompt, or if STDIN is not a tty, the value +# specified in "default" is returned. Note that careless use of +# prompt in test suites may make the test suites unable to be run in +# batch mode. +sub prompt +{ + my $rep = shift; + my ($msg, $env, $default) = @_; + &QTC::TC("testdriver", "TestDriver prompt"); + my $answer = $ENV{$env}; + if (defined $answer) + { + print "$msg\n"; + print "[Question answered from environment variable \$$env: $answer]\n"; + } + else + { + print "To avoid question, place answer in" . + " environment variable \$$env\n"; + if (-t STDIN) + { + print "$msg "; + chop($answer = ); + if ($answer eq '') + { + print "[Using default answer for question: $default]\n"; + $answer = $default; + } + } + else + { + print "$msg\n"; + print "[Using default answer for question: $default]\n"; + $answer = $default; + } + } + $answer; +} + +# Usage: get_start_dir() +# Returns the name of the directory from which the test driver was +# originally invoked. This can be useful for test suites that are +# designed to be run from read-only areas or from multiple locations +# simultaneously: they can get the original invocation directory and +# use it as a place to write temporary files. +sub get_start_dir +{ + my $rep = shift; + $rep->{+__PACKAGE__}{$f_origdir}; +} + +# Usage: runtest description input output [ flags ] +# Returns true iff test passes; i.e., input matches output + +# Parameters: + +# description: a short textual description of the test case + +# input: a hash reference that defines the input to the test case +# input keys and associated values: + +# STRING: a string that is used verbatim as the test input + +# FILE: a file whose contents are used as the test input + +# COMMAND: an array reference containing a command and arguments +# or a string representing the command. This is passed to exec, +# so the rules that exec uses to determine whether to pass this +# to a shell are followed. The command is run with STDIN set to +# /dev/null, STDOUT redirected to an internal file, and STDERR +# copied to STDOUT. + +# Note that exactly one of STRING, FILE, or COMMAND must appear. + +# FILTER: if specified, it is a program that is run on the test +# input specified above to generate the true test input. + +# output: a hash reference that defines the expected output of the +# test case + +# STRING: a string that contains the expected test output + +# FILE: a file that contains the expected test output + +# REGEXP: a regular expression that must match the test output + +# Note that exactly one of STRING, FILE, or REGEXP must appear. + +# 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. + +# THREAD_DATA: If specified, the test output is expected to +# contain multithreaded output with output lines marked by thread +# and sequence group identifiers. The value must be a hash that +# contains required key TD_THREADS and optional key TD_SEQGROUPS. +# The value of each key is an array reference containing a list +# of threads or sequence groups as appropriate. When THREAD_DATA +# is specified, the single call to runtest actually generates t + +# s + 3 tests where "t" is the number of threads and "s" is the +# number of sequence groups specified. See the documentation for +# full details on how multithreaded output is handled by the test +# driver. + +# flags: additional flags to control the test case; should be +# logically orred together (e.g. NORMALIZE_WHITESPACE | EXPECT_FAILURE) + +# NORMALIZE_NEWLINES: If specified, all newlines or carriage +# return/newline combinations in the input are translated to +# straight UNIX-style newlines. This is done before writing +# through any filter. Newlines are also normalized in the +# expected output. + +# NORMALIZE_WHITESPACE: If specified, all carriage returns are +# removed, and all strings of one or more space or tab characters +# are replaced by a single space character in the input. This is +# done before writing through any filter. The expected output +# must be normalized in this way as well in order for the test to +# pass. + +# EXPECT_FAILURE: If specified, the test case is expected to +# fail. In this case, a test case failure will not generate +# verbose output or cause overall test suite failure, and a pass +# will generate test suite failure. This should be used for +# place-holder test cases that exercise a known bug that cannot +# yet be fixed. + +sub runtest +{ + my $rep = shift; + + if (! ((@_ == 3) || (@_ == 4))) + { + croak +("Usage: ", +__PACKAGE__, + "->runtest(description, input, output[, flags])\n"); + } + + my ($description, $input, $output, $flags) = @_; + $flags = 0 unless defined $flags; + + my $tempdir = $rep->_tempdir(); + + if (ref($description) ne '') + { + &QTC::TC("testdriver", "TestDriver description not string"); + croak +__PACKAGE__, "->runtest: description must be a string\n"; + } + if (ref($input) ne 'HASH') + { + &QTC::TC("testdriver", "TestDriver input not hash"); + croak +__PACKAGE__, "->runtest: input must be a hash reference\n"; + } + if (ref($output) ne 'HASH') + { + &QTC::TC("testdriver", "TestDriver output not hash"); + croak +__PACKAGE__, "->runtest: output must be a hash reference\n"; + } + if ((ref($flags) ne '') || ($flags !~ m/^\d+$/)) + { + &QTC::TC("testdriver", "TestDriver flags not integer"); + croak +__PACKAGE__, "->runtest: flags must be an integer\n"; + } + + my ($extra_in_keys, $in_string, $in_file, $in_command, $in_filter) = + check_hash_keys($input, $rep->STRING, + $rep->FILE, $rep->COMMAND, $rep->FILTER); + if ($extra_in_keys) + { + &QTC::TC("testdriver", "TestDriver extraneous input keys"); + croak +(+__PACKAGE__, + "->runtest: extraneous keys in intput hash: $extra_in_keys\n"); + } + my ($extra_out_keys, $out_string, $out_file, $out_regexp, + $out_exit_status, $thread_data) = + check_hash_keys($output, $rep->STRING, + $rep->FILE, $rep->REGEXP, $rep->EXIT_STATUS, + $rep->THREAD_DATA); + if ($extra_out_keys) + { + &QTC::TC("testdriver", "TestDriver extraneous output keys"); + croak +(+__PACKAGE__, + "->runtest: extraneous keys in output hash: $extra_out_keys\n"); + } + + if ((((defined $in_string) ? 1 : 0) + + ((defined $in_file) ? 1 : 0) + + ((defined $in_command) ? 1 : 0)) != 1) + { + &QTC::TC("testdriver", "TestDriver invalid input"); + croak +__PACKAGE__, "->runtest: exactly one of" . + " STRING, FILE, or COMMAND must be present for input\n"; + } + if ((((defined $out_string) ? 1 : 0) + + ((defined $out_file) ? 1 : 0) + + ((defined $out_regexp) ? 1 : 0)) != 1) + { + &QTC::TC("testdriver", "TestDriver invalid output"); + croak +__PACKAGE__, "->runtest: exactly one of" . + " STRING, FILE, or REGEXP must be present for output\n"; + } + if ((defined $in_command) != (exists $output->{$rep->EXIT_STATUS})) + { + &QTC::TC("testdriver", "TestDriver invalid status"); + croak +__PACKAGE__, "->runtest: input COMMAND and output EXIT_STATUS" + . " must either both appear both not appear\n"; + } + + my ($threads, $seqgroups) = (undef, undef); + if (defined $thread_data) + { + if (ref($thread_data) ne 'HASH') + { + &QTC::TC("testdriver", "TestDriver thread_data not hash"); + croak +__PACKAGE__, "->runtest: THREAD_DATA" . + " must be a hash reference\n"; + } + my $extra_thread_keys; + ($extra_thread_keys, $threads, $seqgroups) = + check_hash_keys($thread_data, $rep->TD_THREADS, $rep->TD_SEQGROUPS); + if ($extra_thread_keys) + { + &QTC::TC("testdriver", "TestDriver extraneous thread_data keys"); + croak +(+__PACKAGE__, + "->runtest: extraneous keys in THREAD_DATA hash:" . + " $extra_thread_keys\n"); + } + if (! defined $threads) + { + &QTC::TC("testdriver", "TestDriver thread_data no threads"); + croak +__PACKAGE__, "->runtest: THREAD_DATA" . + " must contain TD_THREADS\n"; + } + elsif (ref($threads) ne 'ARRAY') + { + &QTC::TC("testdriver", "TestDriver threads not array ref"); + croak +__PACKAGE__, "->runtest: TD_THREADS" . + " must be an array reference\n"; + } + if ((defined $seqgroups) && (ref($seqgroups) ne 'ARRAY')) + { + &QTC::TC("testdriver", "TestDriver seqgroups not array ref"); + croak +__PACKAGE__, "->runtest: TD_SEQGROUPS" . + " must be an array reference\n"; + } + } + + # testnum is incremented by print_testid + my $testnum = $rep->_testnum(); + my $category = $rep->_suitename(); + $rep->print_testid($description); + + # Open a file handle to read the raw (unfiltered) test input + my $pid = undef; + my $pid_killer = new TestDriver::PidKiller(\$pid); + my $in = new IO::Handle; + if (defined $in_string) + { + &QTC::TC("testdriver", "TestDriver input string"); + open($in, '<', \$in_string) or + die +(+__PACKAGE__, + "->runtest: unable to read from input string: $!\n"); + } + elsif (defined $in_file) + { + &QTC::TC("testdriver", "TestDriver input file"); + open($in, '<', $in_file) or + croak +(+__PACKAGE__, + "->runtest: unable to read from input file $in_file: $!\n"); + } + elsif (defined $in_command) + { + $pid = open($in, "-|"); + croak +__PACKAGE__, "->runtest: fork failed: $!\n" unless defined $pid; + if ($pid == 0) + { + # child + 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"); + } + } + } + else + { + die +__PACKAGE__, ": INTERNAL ERROR: invalid test input"; + } + binmode $in; + + # 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"); + # Write through filter to actual file + open($actual, "| $in_filter > $actual_file") or + croak +(+__PACKAGE__, ": pipe to filter $in_filter failed: $!\n"); + binmode $actual; + } + else + { + &QTC::TC("testdriver", "TestDriver filter not defined"); + open($actual, ">$actual_file") or + die +(+__PACKAGE__, ": write to $actual_file failed: $!\n"); + binmode $actual; + } + + # Write from input to actual output, normalizing spaces and + # newlines if needed + my $exit_status = undef; + while (1) + { + my ($line, $status) = read_line($in, $pid); + $exit_status = $status if defined $status; + last unless defined $line; + if ($flags & $rep->NORMALIZE_WHITESPACE) + { + &QTC::TC("testdriver", "TestDriver normalize whitespace"); + $line =~ s/[ \t]+/ /g; + } + else + { + &QTC::TC("testdriver", "TestDriver no normalize whitespace"); + } + if ($flags & $rep->NORMALIZE_NEWLINES) + { + &QTC::TC("testdriver", "TestDriver normalize newlines"); + $line =~ s/\r$//; + } + else + { + &QTC::TC("testdriver", "TestDriver no normalize newlines"); + } + $actual->print($line); + $actual->flush(); + last if defined $exit_status; + } + $in->close(); + if (defined $in_command) + { + if (! defined $exit_status) + { + $exit_status = $?; + } + if (($exit_status > 0) && ($exit_status < 256)) + { + &QTC::TC("testdriver", "TestDriver exit status signal"); + $exit_status &= 127; # clear core dump flag + $exit_status = "SIG:$exit_status"; + } + else + { + &QTC::TC("testdriver", "TestDriver exit status number"); + $exit_status >>= 8; + } + } + $? = 0; + $actual->close(); + $pid = undef; + if ($?) + { + die +(+__PACKAGE__, + "->runtest: failure closing actual output; status = $?\n"); + } + + # 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))); + + # Compare actual output with expected output. + my $expected_file = undef; + my $output_match = undef; + if (defined $out_string) + { + &QTC::TC("testdriver", "TestDriver output string"); + # Write output string to a file so we can run diff + $expected_file = "$tempdir/expected"; + my $e = new IO::File; + open($e, ">$expected_file") or + die +(__PACKAGE__, + "->runtest: unable to write to $expected_file: $!\n"); + binmode $e; + $e->print($out_string); + $e->close(); + } + elsif (defined $out_file) + { + &QTC::TC("testdriver", "TestDriver output file"); + if ($flags & $rep->NORMALIZE_NEWLINES) + { + # Normalize newlines in expected output file + $expected_file = "$tempdir/expected"; + unlink $expected_file; + my $in = new IO::File; + if (open($in, "<$out_file")) + { + binmode $in; + my $e = new IO::File; + open($e, ">$expected_file") or + die +(__PACKAGE__, + "->runtest: unable to write to $expected_file: $!\n"); + binmode $e; + while (<$in>) + { + s/\r?$//; + $e->print($_); + } + $e->close(); + $in->close(); + } + } + else + { + $expected_file = $out_file; + } + } + elsif (defined $out_regexp) + { + &QTC::TC("testdriver", "TestDriver output regexp"); + # No expected file; do regexp test to determine whether output + # matches + $actual = new IO::File; + open($actual, "<$actual_file") or + die +(__PACKAGE__, + "->runtest: unable to read $actual_file: $!\n"); + binmode $actual; + local $/ = undef; + my $actual_output = <$actual>; + $actual->close(); + $output_match = ($actual_output =~ m/$out_regexp/); + } + else + { + die +__PACKAGE__, ": INTERNAL ERROR: invalid test output"; + } + + my $output_diff = undef; + if (! defined $output_match) + { + if (! defined $expected_file) + { + die +__PACKAGE__, ": INTERNAL ERROR: expected_file not defined"; + } + if (defined $threads) + { + # Real output comparisons are done later. + $output_match = 1; + } + else + { + $output_diff = "$tempdir/difference"; + my $r = safe_pipe(['diff', '-a', '-u', + $expected_file, $actual_file], + $output_diff); + $output_match = ($r == 0); + } + } + + my $outcome = ($output_match && $status_match) ? PASS : FAIL; + my $exp_outcome = (($flags & $rep->EXPECT_FAILURE) ? FAIL : PASS); + my $outcome_text = print_results($outcome, $exp_outcome); + my $passed = $rep->update_counters($outcome, $exp_outcome); + + my $testxml = $rep->_testxml(); + my $testlog = $rep->_testlog(); + # $outcome_text is for the human-readable. We need something + # different for the xml file. + $testxml->print(" print(" >\n"); + $testlog->printf("$category test %d (%s) FAILED\n", + $testnum, $description); + my $cwd = getcwd(); + $testlog->print("cwd: $cwd\n"); + $testxml->print(" $cwd\n"); + my $cmd = $in_command; + if ((defined $cmd) && (ref($cmd) eq 'ARRAY')) + { + $cmd = join(' ', @$cmd); + } + if (defined $cmd) + { + $testlog->print("command: $cmd\n"); + $testxml->print(" $cmd\n"); + } + if (defined $out_file) + { + # Use $out_file, not $expected_file -- we are only + # interested in dispaying this information if the user's + # real output was original in a file. + $testlog->print("expected output in $out_file\n"); + $testxml->print( + " $out_file\n"); + } + + # It would be nice if we could filter out internal calls for + # times when runtest is called inside of the module for + # multithreaded testing. + $testlog->print(Carp::longmess()); + + $testxml->print(" test failure" . + Carp::longmess() . + "\n"); + + if (! $status_match) + { + &QTC::TC("testdriver", "TestDriver status mismatch"); + $testlog->printf("\tExpected status: %s\n", $out_exit_status); + $testlog->printf("\tActual status: %s\n", $exit_status); + $testxml->print( + " $out_exit_status\n"); + $testxml->print( + " $exit_status\n"); + } + if (! $output_match) + { + &QTC::TC("testdriver", "TestDriver output mismatch"); + $testlog->print("--> BEGIN EXPECTED OUTPUT <--\n"); + $testxml->print(" "); + if (defined $expected_file) + { + write_file_to_fh($expected_file, $testlog); + xml_write_file_to_fh($expected_file, $testxml); + } + elsif (defined $out_regexp) + { + $testlog->print("regexp: " . $out_regexp); + if ($out_regexp !~ m/\n$/s) + { + $testlog->print("\n"); + } + $testxml->print("regexp: " . $out_regexp); + } + else + { + die +(+__PACKAGE__, + "->runtest: INTERNAL ERROR: no expected output\n"); + } + $testlog->print("--> END EXPECTED OUTPUT <--\n" . + "--> BEGIN ACTUAL OUTPUT <--\n"); + $testxml->print("\n" . + " "); + write_file_to_fh($actual_file, $testlog); + xml_write_file_to_fh($actual_file, $testxml); + $testlog->print("--> END ACTUAL OUTPUT <--\n"); + $testxml->print("\n"); + if (defined $output_diff) + { + &QTC::TC("testdriver", "TestDriver display diff"); + $testlog->print("--> DIFF EXPECTED ACTUAL <--\n"); + $testxml->print(" "); + write_file_to_fh($output_diff, $testlog); + xml_write_file_to_fh($output_diff, $testxml); + $testlog->print("--> END DIFFERENCES <--\n"); + $testxml->print("\n"); + } + else + { + &QTC::TC("testdriver", "TestDriver display no diff"); + } + } + $testxml->print(" \n"); + } + else + { + $testxml->print(" />\n"); + } + + if (defined $threads) + { + if (! defined $expected_file) + { + &QTC::TC("testdriver", "TestDriver thread data but no exp output"); + croak +(+__PACKAGE__, + "->runtest: thread data invalid". + " without fixed test output\n"); + } + + my $thread_expected = "$tempdir/thread-expected"; + my $thread_actual = "$tempdir/thread-actual"; + copy($actual_file, $thread_actual); + filter_seqgroups($expected_file, $thread_expected); + + $passed = + $rep->analyze_thread_data($description, + $expected_file, $actual_file, + $threads, $seqgroups) + && $passed; + + if ($passed) + { + $rep->runtest($description . ": all subcases passed", + {$rep->STRING => ""}, + {$rep->STRING => ""}); + } + else + { + $rep->runtest($description . ": original output", + {$rep->FILE => $thread_actual}, + {$rep->FILE => $thread_expected}); + } + + unlink $thread_expected, $thread_actual; + } + + $passed; +} + +sub read_line +{ + my ($fh, $pid) = @_; + my $line = undef; + my $status = undef; + + if (defined $pid) + { + # It doesn't work to just call <$fh> in this case. For some + # unknown reason, some programs occasionally exit and cause an + # interrupted system call return from read which perl just + # ignores, making the call to <$fh> hang. To protect + # ourselves, we explicitly check for the program having exited + # periodically if read hasn't returned anything. + + while (1) + { + my $s = new IO::Select(); + $s->add($fh); + my @ready = $s->can_read(1); + if (@ready == 0) + { + if (waitpid($pid, WNOHANG) > 0) + { + $status = $?; + last; + } + next; + } + else + { + my $buf = ""; + my $status = sysread($fh, $buf, 1); + if ((defined $status) && ($status == 1)) + { + $line = "" unless defined $line; + $line .= $buf; + last if $buf eq "\n"; + } + else + { + last; + } + } + } + } + else + { + $line = <$fh>; + } + ($line, $status); +} + +sub write_file_to_fh +{ + my ($file, $out) = @_; + my $in = new IO::File("<$file"); + if (defined $in) + { + binmode $in; + my $ended_with_newline = 1; + while (<$in>) + { + $out->print($_); + $ended_with_newline = m/\n$/s; + } + if (! $ended_with_newline) + { + $out->print("[no newline at end of data]\n"); + } + $in->close(); + } + else + { + $out->print("[unable to open $file: $!]\n"); + } +} + +sub xml_write_file_to_fh +{ + my ($file, $out) = @_; + my $in = new IO::File("<$file"); + if (defined $in) + { + binmode $in; + while (defined ($_ = <$in>)) + { + s/\&/\&/g; + s//>/g; + s/([\000-\011\013-\037\177-\377])/sprintf("&#x%02x;", ord($1))/ge; + $out->print($_); + } + $in->close(); + } + else + { + $out->print("[unable to open $file: $!]"); + } +} + +sub check_hash_keys +{ + my ($hash, @keys) = @_; + my %actual_keys = (); + foreach my $k (keys %$hash) + { + $actual_keys{$k} = 1; + } + foreach my $k (@keys) + { + delete $actual_keys{$k}; + } + my $extra_keys = join(', ', sort (keys %actual_keys)); + ($extra_keys, (map { $hash->{$_} } @keys)); +} + +sub print_testid +{ + my $rep = shift; + my ($description) = @_; + + my $testnum = $rep->_testnum(); + my $category = $rep->_suitename(); + print_and_pad(sprintf("$category %2d (%s)", $testnum, $description)); + my $tc_filename = $ENV{'TC_FILENAME'} || ""; + if ($tc_filename && open(F, ">>$tc_filename")) + { + printf F "# $category %2d (%s)\n", $testnum, $description; + close(F); + } + $rep->_testnum(++$testnum); +} + +sub update_counters +{ + my $rep = shift; + my ($outcome, $exp_outcome) = @_; + + (($outcome eq PASS) && ($exp_outcome eq PASS)) && + $rep->{+__PACKAGE__}{$f_passes}++; + (($outcome eq PASS) && ($exp_outcome eq FAIL)) && + $rep->{+__PACKAGE__}{$f_xpasses}++; + (($outcome eq FAIL) && ($exp_outcome eq PASS)) && + $rep->{+__PACKAGE__}{$f_fails}++; + (($outcome eq FAIL) && ($exp_outcome eq FAIL)) && + $rep->{+__PACKAGE__}{$f_xfails}++; + + ($outcome eq PASS); +} + +sub analyze_thread_data +{ + my $rep = shift; + my ($description, $expected, $actual, + $expected_threads, $expected_seqgroups) = @_; + + my $tempdir = $rep->_tempdir(); + + my %actual_threads = (); + my %actual_seqgroups = (); + my @errors = (); + + $rep->thread_cleanup(); + $rep->split_combined($expected); + $rep->analyze_threaded_output + ($actual, \%actual_threads, \%actual_seqgroups, \@errors); + + # Make sure we saw the right threads and sequences + + my $desired = "threads:\n"; + $desired .= join('', map { " $_\n" } (sort @$expected_threads)); + $desired .= "sequence groups:\n"; + if (defined $expected_seqgroups) + { + $desired .= join('', map { " $_\n" } (sort @$expected_seqgroups)); + } + + my $observed = "threads:\n"; + $observed .= join('', map { " $_\n" } (sort keys %actual_threads)); + $observed .= "sequence groups:\n"; + $observed .= join('', map { " $_\n" } (sort keys %actual_seqgroups)); + + if (@errors) + { + $observed .= join('', @errors); + } + + my $passed = + $rep->runtest("$description: multithreaded data", + {$rep->STRING => $observed}, + {$rep->STRING => $desired}); + + + foreach my $th (@{$expected_threads}) + { + create_if_missing("$tempdir/$th.thread-actual", + "[no actual output]\n"); + filter_seqgroups("$tempdir/$th.thread-expected", + "$tempdir/$th.thread-filtered"); + $passed = + $rep->runtest($description . ": thread $th", + {$rep->FILE => "$tempdir/$th.thread-actual"}, + {$rep->FILE => "$tempdir/$th.thread-filtered"}) + && $passed; + } + if (defined $expected_seqgroups) + { + foreach my $sg (@{$expected_seqgroups}) + { + create_if_missing("$tempdir/$sg.seq-actual", + "[no actual output]\n"); + $passed = + $rep->runtest($description . ": seqgroup $sg", + {$rep->FILE => "$tempdir/$sg.seq-actual"}, + {$rep->FILE => "$tempdir/$sg.seq-expected"}) + && $passed; + } + } + + $rep->thread_cleanup(); + + $passed; +} + +sub analyze_threaded_output +{ + my $rep = shift; + my ($file, $threads, $seqgroups, $errors) = @_; + my $sequence_checking = 1; + open(F, "<$file") or die +__PACKAGE__, ": can't open $file: $!\n"; + my $cur_thread = undef; + while () + { + if (m/^(\[\[(.+?)\]\]:)/) + { + my $tag = $1; + my $thread = $2; + my $rest = $'; #' [unconfuse emacs font lock mode] + + $rep->handle_line($file, $., $tag, $thread, $rest, + \$sequence_checking, $threads, $seqgroups, + $errors); + + $cur_thread = $thread; + } + else + { + $rep->handle_line($file, $., "", $cur_thread, $_, + \$sequence_checking, $threads, $seqgroups, + $errors); + } + } + close(F); +} + +sub handle_line +{ + my $rep = shift; + my ($file, $lineno, $tag, $thread, $rest, + $sequence_checking, $threads, $seqgroups, $errors) = @_; + + my $tempdir = $rep->_tempdir(); + + if (! exists $threads->{$thread}) + { + my $fh = new IO::File("<$tempdir/$thread.thread-expected"); + if (! $fh) + { + &QTC::TC("testdriver", "TestDriver no input file for thread"); + $fh = undef; + $$sequence_checking = 0; + push(@$errors, + "$file:$.: no input file for thread $thread; " . + "sequence checking abandoned\n"); + } + $threads->{$thread} = $fh; + } + my $known = defined($threads->{$thread}); + + my $seqs = ""; + if ($$sequence_checking) + { + my $fh = $threads->{$thread}; + my $next_input_line = scalar(<$fh>); + if (! defined $next_input_line) + { + $next_input_line = "[EOF]\n"; + } + $seqs = $rep->strip_seqs(\$next_input_line); + if ($next_input_line eq $rest) + { + if ($seqs ne "") + { + $rep->handle_seqs($seqs, $tag . $rest, $seqgroups); + } + } + else + { + &QTC::TC("testdriver", "TestDriver thread mismatch"); + $$sequence_checking = 0; + push(@$errors, + "$file:$.: thread $thread mismatch; " . + "sequencing checking abandoned\n" . + "actual $rest" . + "expected $next_input_line"); + } + } + output_line("$tempdir/$thread.thread-actual", $rest); + if (! $known) + { + &QTC::TC("testdriver", "TestDriver output from unknown thread"); + push(@$errors, "[[$thread]]:$rest"); + } +} + +sub strip_seqs +{ + my $rep = shift; + my $linep = shift; + my $seqs = ""; + if ($$linep =~ s/^\(\(.*?\)\)//) + { + $seqs = $&; + } + $seqs; +} + +sub handle_seqs +{ + my $rep = shift; + my ($seqs, $line, $seqgroups) = @_; + my $tempdir = $rep->_tempdir(); + $seqs =~ s/^\(\((.*?)\)\)/$1/; + foreach my $seq (split(',', $seqs)) + { + $seqgroups->{$seq} = 1; + output_line("$tempdir/$seq.seq-actual", $line); + } +} + +sub filter_seqgroups +{ + my ($infile, $outfile) = @_; + open(F, "<$infile") or + die +__PACKAGE__, ": can't open $infile: $!\n"; + binmode F; + open(O, ">$outfile") or + die +__PACKAGE__, ": can't create $outfile: $!\n"; + binmode O; + while () + { + s/^((?:\[\[.+?\]\]:)?)\(\(.+?\)\)/$1/; + print O; + } + close(O); + close(F); +} + +sub output_line +{ + my ($file, $line) = @_; + open(O, ">>$file") or die +__PACKAGE__, ": can't open $file: $!\n"; + print O $line or die +__PACKAGE__, ": can't append to $file: $!\n"; + close(O) or die +__PACKAGE__, ": close $file failed: $!\n"; +} + +sub create_if_missing +{ + my ($file, $line) = @_; + if (! -e $file) + { + open(O, ">$file") or die +__PACKAGE__, ": can't create $file: $!\n"; + print O $line; + close(O); + } +} + +sub split_combined +{ + my $rep = shift; + my $combined = shift; + my $tempdir = $rep->_tempdir(); + + open(C, "<$combined") or die +__PACKAGE__, ": can't open $combined: $!\n"; + my %files = (); + my $last_thread_fh = undef; + while () + { + my $thread_fh = $last_thread_fh; + my $thread_out = undef; + if (m/^(\[\[(.+?)\]\]:)(\(\((.+?)\)\))?(.*\n?)$/) + { + my $thread_full = $1; + my $thread = $2; + my $seq_full = $3; + my $seq = $4; + my $rest = $5; + my $seq_out = undef; + $thread_out = $rest; + + my @seq_files = (); + my $thread_file = "$tempdir/$thread.thread-expected"; + if (defined $seq_full) + { + $thread_out = $seq_full . $thread_out; + $seq_out = $thread_full . $rest; + foreach my $s (split(/,/, $seq)) + { + my $f = "$tempdir/$s.seq-expected"; + my $fh = cache_open(\%files, $f); + $fh->print($seq_out); + } + } + + $thread_fh = cache_open(\%files, $thread_file); + } + else + { + $thread_out = $_; + } + if ((defined $thread_out) && (! defined $thread_fh)) + { + die +__PACKAGE__, ": no place to put output lines\n"; + } + $thread_fh->print($thread_out) if defined $thread_out; + $last_thread_fh = $thread_fh; + } + close(C); + map { $_->close() } (values %files); +} + +sub cache_open +{ + my ($cache, $file) = @_; + if (! defined $file) + { + return undef; + } + if (! exists $cache->{$file}) + { + unlink $file; + my $fh = new IO::File(">$file") or + die +__PACKAGE__, ": can't open $file: $!\n"; + $cache->{$file} = $fh; + } + $cache->{$file}; +} + +sub thread_cleanup +{ + my $rep = shift; + my $dir = $rep->_tempdir(); + my @files = +(grep { m/\.(thread|seq)-(actual|expected|filtered)$/ } + (glob("$dir/*"))); + if (@files) + { + unlink @files; + } +} + +sub rmrf +{ + my $path = shift; + return unless -e $path; + my $wanted = sub + { + if ((-d $_) && (! -l $_)) + { + rmdir $_ or die "rmdir $_ failed: $!\n"; + } + else + { + unlink $_ or die "unlink $_ failed: $!\n"; + } + }; + finddepth({wanted => $wanted, no_chdir => 1}, $path); +} + +sub safe_pipe +{ + my ($cmd, $outfile) = @_; + my $pid = open(C, "-|"); + my $result = 0; + + if ($pid) + { + # parent + my $out = new IO::File(">$outfile") or + die +__PACKAGE__, ": can't open $outfile: $!\n"; + binmode C; + while () + { + $out->print($_); + } + close(C); + $result = $?; + $out->close(); + } + else + { + # child + open(STDERR, ">&STDOUT"); + exec(@$cmd) || die +__PACKAGE__, ": $cmd->[0] failed: $!\n"; + } + + $result; +} +1; + +# +# END OF TestDriver +# -- cgit v1.2.3-54-g00ecf