OpenSystemsDevelopment / qpdf

Commit 3334cdf38719ad3fc45d6d311931b5b545a270db

Authored by Jay Berkenbilt
1 parent 9f45538c

update qtest to 1.4 

git-svn-id: svn+q:///qpdf/trunk@800 71b93d88-0707-0410-a8cf-f5a4172ac649
Inline Side-by-side
Showing 2 changed files with 265 additions and 100 deletions
qtest/bin/qtest-driver
  View file @3334cdf
... ... @@ -33,7 +33,7 @@ require TestDriver;
33 33  
34 34 if ((@ARGV == 1) && ($ARGV[0] eq '--version'))
35 35 {
36   - print "$whoami version 1.3\n";
  36 + print "$whoami version 1.4\n";
37 37 exit 0;
38 38 }
39 39 if ((@ARGV == 1) && ($ARGV[0] eq '--print-path'))
... ... @@ -84,7 +84,8 @@ if (@bindirs)
84 84 fatal("can't canonicalize path to bindir $d: $!");
85 85 push(@path, $abs);
86 86 }
87   - my $path = join(':', @path) . ':' . $ENV{'PATH'};
  87 + my $sep = ($^O eq 'MSWin32' ? ';' : ':');
  88 + my $path = join($sep, @path) . $sep . $ENV{'PATH'};
88 89 # Delete and explicitly recreate the PATH environment variable.
89 90 # This seems to be more reliable. If we just reassign, in some
90 91 # cases, the modified environment is not inherited by the child
... ... @@ -112,8 +113,18 @@ $ENV{'IN_TESTSUITE'} = 1;
112 113 # be inspected by impatient test suite runners. It is not intended to
113 114 # be a "secure" (unpredictable) path.
114 115 my $tempdir = File::Spec->tmpdir() . "/testtemp.$$";
  116 +my $thispid = $$;
115 117  
116   -my $file_cleanup = new TestDriver::TmpFileDeleter([$tempdir]);
  118 +END
  119 +{
  120 + # We have to make sure we don't call this from the child
  121 + # qtest-driver when fork is called.
  122 + if ((defined $thispid) && ($$ == $thispid) && (defined $tempdir))
  123 + {
  124 + local $?;
  125 + TestDriver::rmrf($tempdir) if -d $tempdir;
  126 + }
  127 +}
117 128  
118 129 $| = 1;
119 130 $SIG{'PIPE'} = 'IGNORE';
... ... @@ -471,6 +482,7 @@ sub parse_tc_file
471 482 return unless defined $tc_input;
472 483  
473 484 my $tc = new IO::File("<$tc_input") or fatal("can't read $tc_input: $!");
  485 + binmode $tc;
474 486 while (<$tc>)
475 487 {
476 488 s/\r?\n$//s;
... ... @@ -480,7 +492,7 @@ sub parse_tc_file
480 492 {
481 493 $tc_ignored_scopes{$1} = 1;
482 494 }
483   - elsif (m/^\s*?(\S.+?)\s+(\d+)$/)
  495 + elsif (m/^\s*?(\S.+?)\s+(\d+)\s*$/)
484 496 {
485 497 my ($case, $n) = ($1, $2);
486 498 if (exists $tc_cases{$case})
... ... @@ -602,6 +614,7 @@ sub tc_do_final_checks
602 614  
603 615 my %seen_cases = ();
604 616 my $tc = new IO::File("<$tc_log");
  617 + binmode $tc;
605 618 if ($tc)
606 619 {
607 620 binmode $tc;
... ... @@ -610,7 +623,7 @@ sub tc_do_final_checks
610 623 s/\r?\n$//s;
611 624 next if m/^\#/;
612 625 next if m/^\s*$/;
613   - if (m/^(.+) (\d+)$/)
  626 + if (m/^(.+) (\d+)\s*$/)
614 627 {
615 628 $seen_cases{$1}{$2} = 1;
616 629 }
... ...
qtest/module/TestDriver.pm
  View file @3334cdf
... ... @@ -34,27 +34,6 @@ sub DESTROY
34 34 defined($$pid) && $$pid && kill 15, $$pid;
35 35 }
36 36  
37   -package TestDriver::TmpFileDeleter;
38   -
39   -use vars qw($f_files);
40   -$f_files = 'files';
41   -
42   -sub new
43   -{
44   - my $class = shift;
45   - my $rep = +{+__PACKAGE__ => {} };
46   - $rep->{+__PACKAGE__}{$f_files} = shift;
47   - bless $rep, $class;
48   -}
49   -
50   -sub DESTROY
51   -{
52   - local $?;
53   - my $rep = shift;
54   - my $files = ($rep->{+__PACKAGE__}{$f_files});
55   - map { TestDriver::rmrf($_) } @$files;
56   -}
57   -
58 37 package TestDriver;
59 38  
60 39 use IO::Handle;
... ... @@ -122,6 +101,14 @@ my $color_red = &quot;&quot;;
122 101 my $color_magenta = "";
123 102 my $color_emph = "";
124 103  
  104 +# MSWin32 support
  105 +my $in_windows = 0;
  106 +my $winbin = undef;
  107 +if ($^O eq 'MSWin32')
  108 +{
  109 + $in_windows = 1;
  110 +}
  111 +
125 112 sub get_tty_features
126 113 {
127 114 my $got_size = 0;
... ... @@ -157,6 +144,17 @@ sub get_tty_features
157 144 }
158 145 eval
159 146 {
  147 + if ($in_windows)
  148 + {
  149 + eval
  150 + {
  151 + # If you don't have this module, you may want to set
  152 + # the environment variable ANSI_COLORS_DISABLED to 1
  153 + # to avoid "garbage" output around PASSED, FAILED,
  154 + # etc.
  155 + require Win32::Console::ANSI;
  156 + }
  157 + }
160 158 require Term::ANSIColor;
161 159 $color_reset = Term::ANSIColor::RESET();
162 160 $color_green = Term::ANSIColor::GREEN();
... ... @@ -243,7 +241,8 @@ sub new
243 241 ($ARGV[10] =~ m/^-stdout-tty=([01])$/) &&
244 242 (-d $ARGV[5])))
245 243 {
246   - die +__PACKAGE__, ": improper invocation of test driver $0\n";
  244 + die +__PACKAGE__, ": improper invocation of test driver $0 (" .
  245 + join(' ', @ARGV) . ")\n";
247 246 }
248 247 my $fd = ($ARGV[0] eq '-fd') ? $ARGV[1] : undef;
249 248 my $port = ($ARGV[0] eq '-port') ? $ARGV[1] : undef;
... ... @@ -435,7 +434,9 @@ sub prompt
435 434 {
436 435 print "To avoid question, place answer in" .
437 436 " environment variable \$$env\n";
438   - if (-t STDIN)
  437 + # Note: ActiveState perl 5.10.1 gives the wrong answer for -t
  438 + # STDIN.
  439 + if ((-t STDIN) && (-t STDOUT))
439 440 {
440 441 print "$msg ";
441 442 chop($answer = <STDIN>);
... ... @@ -506,10 +507,13 @@ sub get_start_dir
506 507  
507 508 # EXIT_STATUS: the exit status of the command. Required iff the
508 509 # intput is specified by COMMAND. A value of undef means that we
509   -# don't care about the exit status of a command. An integer
510   -# value is the ordinary exit status of a command. A string of
511   -# the form SIG:n indicates that the program has exited with
512   -# signal n.
  510 +# don't care about the exit status of a command. The special
  511 +# value of '!0' means we allow any abnormal exit status but we
  512 +# don't care what the specific exit status is. An integer value
  513 +# is the ordinary exit status of a command. A string of the form
  514 +# SIG:n indicates that the program has exited with signal n.
  515 +# Note that SIG:n is not reliable in a Windows (non-Cygwin)
  516 +# environment.
513 517  
514 518 # THREAD_DATA: If specified, the test output is expected to
515 519 # contain multithreaded output with output lines marked by thread
... ... @@ -674,7 +678,7 @@ sub runtest
674 678 my $pid = undef;
675 679 my $pid_killer = new TestDriver::PidKiller(\$pid);
676 680 my $in = new IO::Handle;
677   - my $use_tempfile = ($^O eq 'MSWin32');
  681 + my $use_tempfile = $in_windows;
678 682 my $tempout_status = undef;
679 683 if (defined $in_string)
680 684 {
... ... @@ -692,60 +696,48 @@ sub runtest
692 696 }
693 697 elsif (defined $in_command)
694 698 {
695   - my $tempfilename = "$tempdir/tempout";
696   - my $tempfile = undef;
697   - if ($use_tempfile)
  699 + if (ref($in_command) eq 'ARRAY')
698 700 {
699   - $tempfile = new IO::File(">$tempfilename") or
700   - die +(+__PACKAGE__,
701   - "->runtest: unable to create $tempfilename: $!\n");
702   - $pid = fork;
703   - croak +__PACKAGE__, "->runtest: fork failed: $!\n"
704   - unless defined $pid;
  701 + &QTC::TC("testdriver", "TestDriver input command array");
705 702 }
706   - else
  703 + elsif (ref($in_command) eq '')
707 704 {
708   - $pid = open($in, "-|");
709   - croak +__PACKAGE__, "->runtest: fork failed: $!\n"
710   - unless defined $pid;
  705 + &QTC::TC("testdriver", "TestDriver input command string");
711 706 }
712   - if ($pid == 0)
  707 +
  708 + if ($use_tempfile)
713 709 {
714   - # child
715   - if (defined $tempfile)
716   - {
717   - open(STDOUT, ">&", $tempfile);
718   - }
719   - open(STDERR, ">&STDOUT");
720   - open(STDIN, '<', \ "");
721   - if (ref($in_command) eq 'ARRAY')
722   - {
723   - &QTC::TC("testdriver", "TestDriver input command array");
724   - exec @$in_command or
725   - croak+(+__PACKAGE__,
726   - "->runtest: unable to run command ",
727   - join(' ', @$in_command), "\n");
728   - }
729   - else
730   - {
731   - &QTC::TC("testdriver", "TestDriver input command string");
732   - exec $in_command or
733   - croak+(+__PACKAGE__,
734   - "->runtest: unable to run command ",
735   - $in_command, "\n");
736   - }
  710 + my $tempout = "$tempdir/tempout";
  711 + $tempout_status = $rep->winrun(
  712 + $in_command, File::Spec->devnull(), $tempout);
  713 + open($in, "<$tempout") or
  714 + croak +(+__PACKAGE__,
  715 + "->runtest: unable to read from" .
  716 + " input file $tempout: $!\n");
737 717 }
738 718 else
739 719 {
740   - if (defined $tempfile)
  720 + $pid = open($in, "-|");
  721 + croak +__PACKAGE__, "->runtest: fork failed: $!\n"
  722 + unless defined $pid;
  723 + if ($pid == 0)
741 724 {
742   - waitpid($pid, 0);
743   - $tempout_status = $?;
744   - $pid = undef;
745   - open($in, "<$tempfilename") or
746   - croak +(+__PACKAGE__,
747   - "->runtest: unable to read from" .
748   - " input file $tempfilename: $!\n");
  725 + open(STDERR, ">&STDOUT");
  726 + open(STDIN, '<', \ "");
  727 + if (ref($in_command) eq 'ARRAY')
  728 + {
  729 + exec @$in_command or
  730 + croak+(+__PACKAGE__,
  731 + "->runtest: unable to run command ",
  732 + join(' ', @$in_command), "\n");
  733 + }
  734 + else
  735 + {
  736 + exec $in_command or
  737 + croak+(+__PACKAGE__,
  738 + "->runtest: unable to run command ",
  739 + $in_command, "\n");
  740 + }
749 741 }
750 742 }
751 743 }
... ... @@ -758,21 +750,46 @@ sub runtest
758 750 # Open file handle into which to write the actual output
759 751 my $actual = new IO::File;
760 752 my $actual_file = "$tempdir/actual";
  753 +
761 754 if (defined $in_filter)
762 755 {
763 756 &QTC::TC("testdriver", "TestDriver filter defined");
  757 + if ($use_tempfile)
  758 + {
  759 + my $filter_file = "$tempdir/filter";
  760 + open(F, ">$filter_file.1") or
  761 + croak+(+__PACKAGE__,
  762 + "->runtest: unable to create $filter_file.1: $!\n");
  763 + binmode F;
  764 + while (<$in>)
  765 + {
  766 + print F;
  767 + }
  768 + $in->close();
  769 + close(F);
  770 + $rep->winrun($in_filter, "$filter_file.1", $filter_file);
  771 + open($in, "<$filter_file") or
  772 + croak +(+__PACKAGE__,
  773 + "->runtest: unable to read from" .
  774 + " input file $filter_file: $!\n");
  775 + binmode $in;
  776 + $in_filter = undef;
  777 + }
  778 + }
  779 + if (defined $in_filter)
  780 + {
764 781 # Write through filter to actual file
765 782 open($actual, "| $in_filter > $actual_file") or
766   - croak +(+__PACKAGE__, ": pipe to filter $in_filter failed: $!\n");
767   - binmode $actual;
  783 + croak +(+__PACKAGE__,
  784 + ": pipe to filter $in_filter failed: $!\n");
768 785 }
769 786 else
770 787 {
771 788 &QTC::TC("testdriver", "TestDriver filter not defined");
772 789 open($actual, ">$actual_file") or
773 790 die +(+__PACKAGE__, ": write to $actual_file failed: $!\n");
774   - binmode $actual;
775 791 }
  792 + binmode $actual;
776 793  
777 794 # Write from input to actual output, normalizing spaces and
778 795 # newlines if needed
... ... @@ -815,16 +832,43 @@ sub runtest
815 832 {
816 833 $exit_status = $?;
817 834 }
818   - if (WIFSIGNALED($exit_status))
  835 + my $exit_status_number = 0;
  836 + my $exit_status_signal = 0;
  837 + if ($in_windows)
819 838 {
820   - &QTC::TC("testdriver", "TestDriver exit status signal");
  839 + # WIFSIGNALED et al are not defined. This is emperically
  840 + # what happens with MSYS 1.0.11 and ActiveState Perl
  841 + # 5.10.1.
  842 + if ($exit_status & 0x8000)
  843 + {
  844 + $exit_status_signal = 1;
  845 + $exit_status = ($exit_status & 0xfff) >> 8;
  846 + $exit_status = "SIG:$exit_status";
  847 + }
  848 + elsif ($exit_status >= 256)
  849 + {
  850 + $exit_status_number = 1;
  851 + $exit_status = $exit_status >> 8;
  852 + }
  853 + }
  854 + elsif (WIFSIGNALED($exit_status))
  855 + {
  856 + $exit_status_signal = 1;
821 857 $exit_status = "SIG:" . WTERMSIG($exit_status);
822 858 }
823 859 elsif (WIFEXITED($exit_status))
824 860 {
825   - &QTC::TC("testdriver", "TestDriver exit status number");
  861 + $exit_status_number = 1;
826 862 $exit_status = WEXITSTATUS($exit_status);
827 863 }
  864 + if ($exit_status_number)
  865 + {
  866 + &QTC::TC("testdriver", "TestDriver exit status number");
  867 + }
  868 + if ($exit_status_signal)
  869 + {
  870 + &QTC::TC("testdriver", "TestDriver exit status signal");
  871 + }
828 872 }
829 873 $? = 0;
830 874 $actual->close();
... ... @@ -837,9 +881,15 @@ sub runtest
837 881  
838 882 # Compare exit statuses. This expression is always true when the
839 883 # input was not from a command.
840   - my $status_match = ((! defined $out_exit_status) ||
841   - ((defined $exit_status) &&
842   - ($exit_status eq $out_exit_status)));
  884 + if ((defined $out_exit_status) && ($out_exit_status eq '!0'))
  885 + {
  886 + &QTC::TC("testdriver", "TestDriver non-zero exit status");
  887 + }
  888 + my $status_match =
  889 + ((! defined $out_exit_status) ||
  890 + ((defined $exit_status) &&
  891 + ( (($out_exit_status eq '!0') && ($exit_status ne 0)) ||
  892 + ($exit_status eq $out_exit_status) )));
843 893  
844 894 # Compare actual output with expected output.
845 895 my $expected_file = undef;
... ... @@ -923,9 +973,9 @@ sub runtest
923 973 else
924 974 {
925 975 $output_diff = "$tempdir/difference";
926   - my $r = safe_pipe(['diff', '-a', '-u',
927   - $expected_file, $actual_file],
928   - $output_diff);
  976 + my $r = $rep->safe_pipe(['diff', '-a', '-u',
  977 + $expected_file, $actual_file],
  978 + $output_diff);
929 979 $output_match = ($r == 0);
930 980 }
931 981 }
... ... @@ -1228,6 +1278,7 @@ sub print_testid
1228 1278 my $tc_filename = $ENV{'TC_FILENAME'} || "";
1229 1279 if ($tc_filename && open(F, ">>$tc_filename"))
1230 1280 {
  1281 + binmode F;
1231 1282 printf F "# $category %2d (%s)\n", $testnum, $description;
1232 1283 close(F);
1233 1284 }
... ... @@ -1331,6 +1382,7 @@ sub analyze_threaded_output
1331 1382 my ($file, $threads, $seqgroups, $errors) = @_;
1332 1383 my $sequence_checking = 1;
1333 1384 open(F, "<$file") or die +__PACKAGE__, ": can't open $file: $!\n";
  1385 + binmode F;
1334 1386 my $cur_thread = undef;
1335 1387 while (<F>)
1336 1388 {
... ... @@ -1376,6 +1428,10 @@ sub handle_line
1376 1428 "$file:$.: no input file for thread $thread; " .
1377 1429 "sequence checking abandoned\n");
1378 1430 }
  1431 + else
  1432 + {
  1433 + binmode $fh;
  1434 + }
1379 1435 $threads->{$thread} = $fh;
1380 1436 }
1381 1437 my $known = defined($threads->{$thread});
... ... @@ -1463,6 +1519,7 @@ sub output_line
1463 1519 {
1464 1520 my ($file, $line) = @_;
1465 1521 open(O, ">>$file") or die +__PACKAGE__, ": can't open $file: $!\n";
  1522 + binmode O;
1466 1523 print O $line or die +__PACKAGE__, ": can't append to $file: $!\n";
1467 1524 close(O) or die +__PACKAGE__, ": close $file failed: $!\n";
1468 1525 }
... ... @@ -1473,6 +1530,7 @@ sub create_if_missing
1473 1530 if (! -e $file)
1474 1531 {
1475 1532 open(O, ">$file") or die +__PACKAGE__, ": can't create $file: $!\n";
  1533 + binmode O;
1476 1534 print O $line;
1477 1535 close(O);
1478 1536 }
... ... @@ -1485,6 +1543,7 @@ sub split_combined
1485 1543 my $tempdir = $rep->_tempdir();
1486 1544  
1487 1545 open(C, "<$combined") or die +__PACKAGE__, ": can't open $combined: $!\n";
  1546 + binmode C;
1488 1547 my %files = ();
1489 1548 my $last_thread_fh = undef;
1490 1549 while (<C>)
... ... @@ -1544,6 +1603,7 @@ sub cache_open
1544 1603 unlink $file;
1545 1604 my $fh = new IO::File(">$file") or
1546 1605 die +__PACKAGE__, ": can't open $file: $!\n";
  1606 + binmode $fh;
1547 1607 $cache->{$file} = $fh;
1548 1608 }
1549 1609 $cache->{$file};
... ... @@ -1581,20 +1641,13 @@ sub rmrf
1581 1641  
1582 1642 sub safe_pipe
1583 1643 {
  1644 + my $rep = shift;
1584 1645 my ($cmd, $outfile) = @_;
1585 1646 my $result = 0;
1586 1647  
1587   - if ($^O eq 'MSWin32')
  1648 + if ($in_windows)
1588 1649 {
1589   - my @cmd = @$cmd;
1590   - my $cmd_str = shift(@cmd);
1591   - while (@cmd)
1592   - {
1593   - my $arg = shift(@cmd);
1594   - $cmd_str .= " \"$arg\"";
1595   - }
1596   - $cmd_str .= " > $outfile 2>&1";
1597   - $result = system($cmd_str);
  1650 + $result = $rep->winrun($cmd, File::Spec->devnull(), $outfile);
1598 1651 }
1599 1652 else
1600 1653 {
... ... @@ -1624,6 +1677,105 @@ sub safe_pipe
1624 1677  
1625 1678 $result;
1626 1679 }
  1680 +
  1681 +sub winrun
  1682 +{
  1683 + # This function does several things to make running stuff on
  1684 + # Windows look sort of like running things on UNIX. It assumes
  1685 + # MinGW perl is running in an MSYS/MinGW environment.
  1686 + #
  1687 + # * When an MSYS/MinGW program is run with system("..."), its
  1688 + # newlines generate \r\n, but when it's run from MSYS sh, its
  1689 + # newlines generate \n. We want \n for UNIX-like programs.
  1690 + #
  1691 + # * system("...") in perl doesn't have any special magic to
  1692 + # handle #! lines in scripts. A lot of test suites will count
  1693 + # on that.
  1694 + #
  1695 + # * There's no Windows equivalent to execve with separate
  1696 + # arguments, so all sorts of fancy quoting is necessary when *
  1697 + # dealing with arguments with spaces, etc.
  1698 + #
  1699 + # * Pipes work unreliably. Fork emulation is very incomplete.
  1700 + #
  1701 + # To work around these issues, we ensure that everything is
  1702 + # actually executed from the MSYS /bin/sh. We find the actual
  1703 + # path of that and then write a shell script which we explicitly
  1704 + # invoke as an argument to /bin/sh. If we have a string that we
  1705 + # want executed with /bin/sh, we include the string in the shell
  1706 + # script. If we have an array, we pass the array on the
  1707 + # commandline to the shell script and let it preserve spacing. We
  1708 + # also do our output redirection in the shell script itself since
  1709 + # redirection of STDOUT and STDERR doesn't carry forward to
  1710 + # programs invoked by programs we invoke. Finally, we filter out
  1711 + # errors generated by the script itself, since it is supposed to
  1712 + # be an invisible buffer for smoother execution of programs.
  1713 + # Experience shows that its output comes from things like printing
  1714 + # the names of signals generated by subsidiary programs.
  1715 +
  1716 + my $rep = shift;
  1717 + my ($in_command, $in, $out) = @_;
  1718 + my $tempdir = $rep->_tempdir();
  1719 + my $tempfilename = "$tempdir/winrun.tmp";
  1720 + if (! defined $winbin)
  1721 + {
  1722 + my $comspec = $ENV{'COMSPEC'};
  1723 + $comspec =~ s,\\,/,g;
  1724 + if ((system("sh -c 'cd /bin; $comspec /c cd'" .
  1725 + " > $tempfilename") == 0) &&
  1726 + open(F, "<$tempfilename"))
  1727 + {
  1728 + $winbin = <F>;
  1729 + close(F);
  1730 + $winbin =~ s,[\r\n],,g;
  1731 + $winbin =~ s,\\,/,g;
  1732 + }
  1733 + if (! defined $winbin)
  1734 + {
  1735 + die +__PACKAGE__, ": unable to find windows path to /bin\n";
  1736 + }
  1737 + }
  1738 + my $script = "$tempdir/tmpscript";
  1739 + open(F, ">$script") or
  1740 + croak +(+__PACKAGE__,
  1741 + "->runtest: unable to open $script to write: $!\n");
  1742 + binmode F;
  1743 + print F "exec >$tempfilename\n";
  1744 + print F "exec 2>&1\n";
  1745 + print F "exec <$in\n";
  1746 + my @cmd = ("$winbin/sh", $script);
  1747 + if (ref($in_command) eq 'ARRAY')
  1748 + {
  1749 + # For debugging, write out the args
  1750 + foreach my $arg (@$in_command)
  1751 + {
  1752 + print F "# $arg\n";
  1753 + }
  1754 + print F '"$@"', "\n";
  1755 + push(@cmd, @$in_command);
  1756 + }
  1757 + else
  1758 + {
  1759 + print F "$in_command\n";
  1760 + }
  1761 + close(F);
  1762 + my $status = system @cmd;
  1763 + if (open(IN, "<$tempfilename") &&
  1764 + open(OUT, ">$out"))
  1765 + {
  1766 + binmode IN;
  1767 + binmode OUT;
  1768 + while (<IN>)
  1769 + {
  1770 + next if m/^$script:/;
  1771 + print OUT;
  1772 + }
  1773 + close(IN);
  1774 + close(OUT);
  1775 + }
  1776 + $status;
  1777 +}
  1778 +
1627 1779 1;
1628 1780  
1629 1781 #
... ...