1# Tester.pm module 2 3# $Id$ 4# 5# This package is designed to run tests on modules which 6# perform interactively. 7 8package Tester; 9 10@ISA = qw( Exporter ); 11@EXPORT = qw( run_test_with_input run_class_test ); 12 13# run_test_with_input $class, $testno, $input, 14# \&testsub, $testargsref, $condition. 15 16sub run_test_with_input { 17 my $class = shift; 18 my $test = shift; 19 my $inputstring = shift; 20 my $testsub = shift; 21 my $testargs = shift; 22 my $condition = shift; 23 24 if (!ref($testsub) and $testsub !~ /::/) { 25 my $pkg = (caller)[0]; 26 my $i; 27 for ($i = 1; $pkg = (caller)[0]; $i++) { 28 last unless $pkg eq 'Tester'; 29 } 30 $testsub =~ s/^/$pkg::/; # qualify the sub 31 } 32 33 select(STDOUT); $| = 1; 34 printf STDOUT "%d.......", $test; 35 36 $SIG{'PIPE'} = 'IGNORE'; # don't let pipe errors hurt us 37 pipe(TESTREAD, CHILDWRITE); 38 pipe(CHILDREAD, TESTWRITE); 39 if (!fork) { 40 open(STDIN, "<&CHILDREAD"); 41 open(STDOUT, ">&CHILDWRITE"); select(STDOUT); $| = 1; 42 open(STDERR, ">&STDOUT"); select(STDERR); $| = 1; 43 close CHILDREAD; 44 close CHILDWRITE; 45 select(STDOUT); $| = 1; 46 47 # Finally, after all that -- run the actual test subroutine 48 my $sub = eval 'sub { package main; &{$_[0]}(@{$_[1]}); }'; 49 $_ = &$sub($testsub, $testargs); 50 51 # The condition must be evaluated here, in the child 52 # process -- since it may involve variables which have 53 # been set in the child (but not the parent) 54 if ($condition) { 55 my $sub = eval 56 'sub { package main; 57 ref($_[0]) eq "CODE" ? &{$_[0]} : eval $_[0]; }'; 58 &$sub($condition) or print "Condition failed\n"; 59 } 60 close STDOUT; 61 close STDIN; 62 exit; 63 } 64 close CHILDREAD; 65 close CHILDWRITE; 66 67 # Generate the output 68 print TESTWRITE $inputstring."\n"; 69 close TESTWRITE; # will cause an EOF 70 71 my @output; 72 while (<TESTREAD>) { # Now get the results 73 push(@output, $_); 74 print if $Details > 1; 75 } 76 close TESTREAD; 77 $SIG{'PIPE'} = 'DEFAULT'; # normal pipe stuff 78 79 # If reference output doesn't exist, generate it from our 80 # current input 81 my $testdir = -d "t" ? "t" : 82 -d "../t" ? "../t" : 83 -d "../../t" ? "../../t" : 84 die "Can't find 't'!\n"; 85 my $testref = "$testdir/$class.$test.ref"; 86 my $testout = "$testdir/$class.$test.out"; 87 my @Details = (); 88 89 if (! -f $testref) { 90 push(@Details,"Generated reference output.") if $Details > 1; 91 open(NEWREF,">$testref"); 92 print NEWREF @output; 93 close NEWREF; 94 } 95 96 if (open(OUT,">$testout")) { 97 print OUT @output; 98 close OUT; 99 } else { 100 die "Cannot open output file: $testout: $!\n"; 101 } 102 103 open(REF,$testref) or die "Can't open '$testref': $!\n"; 104 105 my $notok = ''; 106 my $refout; 107 108 for ($i = 0; $i <= $#output; $i++) { 109 length($refout = <REF>) || last; 110 $notok++ if $output[$i] =~ /condition failed/i; 111 next if $output[$i] eq $refout; 112 $notok++; 113 if ($Details) { 114 push(@Details, sprintf("line %d: \"%s\"", $i, $output[$i])); 115 push(@Details, sprintf("should be: \"%s\"", $refout)); 116 } 117 last; 118 } 119 if ( $i <= $#output) { 120 $notok++; 121 push(@Details, "reference output has less lines.") if $Details; 122 } elsif ( !eof(REF) ) { 123 $notok++; 124 push(@Details, "reference output has more lines.") if $Details; 125 } 126 close REF; 127 if ($notok) { 128 print "not ok\n"; 129 } else { 130 print "ok\n"; 131 unlink $testout; 132 } 133 print "\t".join("\n\t", @Details)."\n" if @Details; 134 undef @Details; 135} 136 137# Run a class of tests 138# Just like the Perl tests 139 140# run_test_class class_name; 141# 142# * The file testdir/$class.pl must exist 143# * The subroutine &$class_Tests will be invoked. 144 145sub run_class_test { 146 my $class = shift; 147 my $testdir = -d "t" ? "t" : 148 -d "../t" ? "../t" : 149 -d "../../t" ? "../../t" : 150 die "Can't find 't'!\n"; 151 my $testmodule = "$testdir/$class.pl"; 152 my $failed; 153 154 if ( ! -f $testmodule ) { 155 print STDERR "No such test for class: $class.\n"; 156 return; 157 } 158 159 select(STDOUT); $| = 1; 160 print substr($class.('.' x 15),0,15); 161 if (!(open(STDIN,"-|"))) { 162 open(STDIN,"/dev/null"); 163 open(STDERR,">&STDOUT"); 164 select(STDERR); $| = 1; 165 select(STDOUT); $| = 1; 166 167 do $testmodule; # execute the test code 168 169 exit; 170 } 171 172 my( $range, $begin, $end ); 173 my( $test, $status ); 174 175 $range = <STDIN>; # get the test range 176 if ($range =~ /^(\d+)\.\.(\d+)/) { 177 ($begin, $end) = ($1, $2); 178 } else { 179 # Non-standard test output -- print it, and exit. 180 do { print "! $_\n"; } while ($_ = <STDIN>); 181 return; 182 } 183 @Test{$begin .. $end} = ($begin .. $end); 184 while (<STDIN>) { 185 chomp; 186 if (s/^(\d+)\.+((?:not )?ok)\s*//) { 187 ($test, $status) = ($1, $2); 188 $Test{$test} = $status; 189 if ($status eq 'not ok') { 190 $Test{$test} .= ": ".$_ if length; 191 $failed++; 192 } 193 } elsif ($test) { 194 $Test{$test} .= "\n".$_; 195 } else { 196 print "! $_\n"; 197 } 198 } 199 close STDIN; 200 if ($failed) { 201 my @failed = grep($Test{$_} =~ /not/, keys %Test); 202 my @msgs = @Test{@failed}; 203 if ($#failed == $[) { 204 printf "Test %s failed %s", $failed[0], $Test{$failed[0]}; 205 } else { 206 my $last = pop @failed; 207 printf "Tests %s and %s failed", join(", ", @failed), $last; 208 push(@failed, $last); 209 } 210 foreach (@msgs) { s/not ok[:,\s;]*//; } 211 @msgs = grep(/./,@msgs); 212 if (@msgs) { 213 printf ":\n\t".join("\n\t", @msgs)."\n" if @msgs; 214 } else { 215 print ".\n"; 216 } 217 foreach $test (@failed) { 218 $testout = "$testdir/$class.$test.out"; 219 next unless -f $testout; 220 open(OUT,$testout) or next; 221 print "Test $test results:\n"; 222 while (<OUT>) { print "\t".$_; } 223 close OUT; 224 } 225 exit unless $KeepGoing; 226 } else { 227 print "ok\n"; 228 } 229} 230 2311; 232