1#line 1 2use strict; 3 4package Test::Tester; 5 6BEGIN 7{ 8 if (*Test::Builder::new{CODE}) 9 { 10 warn "You should load Test::Tester before Test::Builder (or anything that loads Test::Builder)" 11 } 12} 13 14use Test::Builder; 15use Test::Tester::CaptureRunner; 16use Test::Tester::Delegate; 17 18require Exporter; 19 20use vars qw( @ISA @EXPORT $VERSION ); 21 22$VERSION = "0.107"; 23@EXPORT = qw( run_tests check_tests check_test cmp_results show_space ); 24@ISA = qw( Exporter ); 25 26my $Test = Test::Builder->new; 27my $Capture = Test::Tester::Capture->new; 28my $Delegator = Test::Tester::Delegate->new; 29$Delegator->{Object} = $Test; 30 31my $runner = Test::Tester::CaptureRunner->new; 32 33my $want_space = $ENV{TESTTESTERSPACE}; 34 35sub show_space 36{ 37 $want_space = 1; 38} 39 40my $colour = ''; 41my $reset = ''; 42 43if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOUR}) 44{ 45 if (eval "require Term::ANSIColor") 46 { 47 my ($f, $b) = split(",", $want_colour); 48 $colour = Term::ANSIColor::color($f).Term::ANSIColor::color("on_$b"); 49 $reset = Term::ANSIColor::color("reset"); 50 } 51 52} 53 54sub new_new 55{ 56 return $Delegator; 57} 58 59sub capture 60{ 61 return Test::Tester::Capture->new; 62} 63 64sub fh 65{ 66 # experiment with capturing output, I don't like it 67 $runner = Test::Tester::FHRunner->new; 68 69 return $Test; 70} 71 72sub find_run_tests 73{ 74 my $d = 1; 75 my $found = 0; 76 while ((not $found) and (my ($sub) = (caller($d))[3]) ) 77 { 78# print "$d: $sub\n"; 79 $found = ($sub eq "Test::Tester::run_tests"); 80 $d++; 81 } 82 83# die "Didn't find 'run_tests' in caller stack" unless $found; 84 return $d; 85} 86 87sub run_tests 88{ 89 local($Delegator->{Object}) = $Capture; 90 91 $runner->run_tests(@_); 92 93 return ($runner->get_premature, $runner->get_results); 94} 95 96sub check_test 97{ 98 my $test = shift; 99 my $expect = shift; 100 my $name = shift; 101 $name = "" unless defined($name); 102 103 @_ = ($test, [$expect], $name); 104 goto &check_tests; 105} 106 107sub check_tests 108{ 109 my $test = shift; 110 my $expects = shift; 111 my $name = shift; 112 $name = "" unless defined($name); 113 114 my ($prem, @results) = eval { run_tests($test, $name) }; 115 116 $Test->ok(! $@, "Test '$name' completed") || $Test->diag($@); 117 $Test->ok(! length($prem), "Test '$name' no premature diagnostication") || 118 $Test->diag("Before any testing anything, your tests said\n$prem"); 119 120 local $Test::Builder::Level = $Test::Builder::Level + 1; 121 cmp_results(\@results, $expects, $name); 122 return ($prem, @results); 123} 124 125sub cmp_field 126{ 127 my ($result, $expect, $field, $desc) = @_; 128 129 if (defined $expect->{$field}) 130 { 131 $Test->is_eq($result->{$field}, $expect->{$field}, 132 "$desc compare $field"); 133 } 134} 135 136sub cmp_result 137{ 138 my ($result, $expect, $name) = @_; 139 140 my $sub_name = $result->{name}; 141 $sub_name = "" unless defined($name); 142 143 my $desc = "subtest '$sub_name' of '$name'"; 144 145 { 146 local $Test::Builder::Level = $Test::Builder::Level + 1; 147 148 cmp_field($result, $expect, "ok", $desc); 149 150 cmp_field($result, $expect, "actual_ok", $desc); 151 152 cmp_field($result, $expect, "type", $desc); 153 154 cmp_field($result, $expect, "reason", $desc); 155 156 cmp_field($result, $expect, "name", $desc); 157 } 158 159 # if we got no depth then default to 1 160 my $depth = 1; 161 if (exists $expect->{depth}) 162 { 163 $depth = $expect->{depth}; 164 } 165 166 # if depth was explicitly undef then don't test it 167 if (defined $depth) 168 { 169 $Test->is_eq($result->{depth}, $depth, "checking depth") || 170 $Test->diag('You need to change $Test::Builder::Level'); 171 } 172 173 if (defined(my $exp = $expect->{diag})) 174 { 175 # if there actually is some diag then put a \n on the end if it's not 176 # there already 177 178 $exp .= "\n" if (length($exp) and $exp !~ /\n$/); 179 if (not $Test->ok($result->{diag} eq $exp, 180 "subtest '$sub_name' of '$name' compare diag") 181 ) 182 { 183 my $got = $result->{diag}; 184 my $glen = length($got); 185 my $elen = length($exp); 186 for ($got, $exp) 187 { 188 my @lines = split("\n", $_); 189 $_ = join("\n", map { 190 if ($want_space) 191 { 192 $_ = $colour.escape($_).$reset; 193 } 194 else 195 { 196 "'$colour$_$reset'" 197 } 198 } @lines); 199 } 200 201 $Test->diag(<<EOM); 202Got diag ($glen bytes): 203$got 204Expected diag ($elen bytes): 205$exp 206EOM 207 208 } 209 } 210} 211 212sub escape 213{ 214 my $str = shift; 215 my $res = ''; 216 for my $char (split("", $str)) 217 { 218 my $c = ord($char); 219 if(($c>32 and $c<125) or $c == 10) 220 { 221 $res .= $char; 222 } 223 else 224 { 225 $res .= sprintf('\x{%x}', $c) 226 } 227 } 228 return $res; 229} 230 231sub cmp_results 232{ 233 my ($results, $expects, $name) = @_; 234 235 $Test->is_num(scalar @$results, scalar @$expects, "Test '$name' result count"); 236 237 for (my $i = 0; $i < @$expects; $i++) 238 { 239 my $expect = $expects->[$i]; 240 my $result = $results->[$i]; 241 242 local $Test::Builder::Level = $Test::Builder::Level + 1; 243 cmp_result($result, $expect, $name); 244 } 245} 246 247######## nicked from Test::More 248sub plan { 249 my(@plan) = @_; 250 251 my $caller = caller; 252 253 $Test->exported_to($caller); 254 255 my @imports = (); 256 foreach my $idx (0..$#plan) { 257 if( $plan[$idx] eq 'import' ) { 258 my($tag, $imports) = splice @plan, $idx, 2; 259 @imports = @$imports; 260 last; 261 } 262 } 263 264 $Test->plan(@plan); 265 266 __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); 267} 268 269sub import { 270 my($class) = shift; 271 { 272 no warnings 'redefine'; 273 *Test::Builder::new = \&new_new; 274 } 275 goto &plan; 276} 277 278sub _export_to_level 279{ 280 my $pkg = shift; 281 my $level = shift; 282 (undef) = shift; # redundant arg 283 my $callpkg = caller($level); 284 $pkg->export($callpkg, @_); 285} 286 287 288############ 289 2901; 291 292__END__ 293 294#line 645 295