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