1#line 1 "inc/Test/More.pm - /usr/local/lib/perl5/site_perl/5.8.4/Test/More.pm" 2package Test::More; 3 4use 5.004; 5 6use strict; 7use Test::Builder; 8 9 10# Can't use Carp because it might cause use_ok() to accidentally succeed 11# even though the module being used forgot to use Carp. Yes, this 12# actually happened. 13sub _carp { 14 my($file, $line) = (caller(1))[1,2]; 15 warn @_, " at $file line $line\n"; 16} 17 18 19 20require Exporter; 21use vars qw($VERSION @ISA @EXPORT %EXPORT_TAGS $TODO); 22$VERSION = '0.47'; 23@ISA = qw(Exporter); 24@EXPORT = qw(ok use_ok require_ok 25 is isnt like unlike is_deeply 26 cmp_ok 27 skip todo todo_skip 28 pass fail 29 eq_array eq_hash eq_set 30 $TODO 31 plan 32 can_ok isa_ok 33 diag 34 ); 35 36my $Test = Test::Builder->new; 37 38 39# 5.004's Exporter doesn't have export_to_level. 40sub _export_to_level 41{ 42 my $pkg = shift; 43 my $level = shift; 44 (undef) = shift; # redundant arg 45 my $callpkg = caller($level); 46 $pkg->export($callpkg, @_); 47} 48 49 50#line 172 51 52sub plan { 53 my(@plan) = @_; 54 55 my $caller = caller; 56 57 $Test->exported_to($caller); 58 59 my @imports = (); 60 foreach my $idx (0..$#plan) { 61 if( $plan[$idx] eq 'import' ) { 62 my($tag, $imports) = splice @plan, $idx, 2; 63 @imports = @$imports; 64 last; 65 } 66 } 67 68 $Test->plan(@plan); 69 70 __PACKAGE__->_export_to_level(1, __PACKAGE__, @imports); 71} 72 73sub import { 74 my($class) = shift; 75 goto &plan; 76} 77 78 79#line 266 80 81sub ok ($;$) { 82 my($test, $name) = @_; 83 $Test->ok($test, $name); 84} 85 86#line 330 87 88sub is ($$;$) { 89 $Test->is_eq(@_); 90} 91 92sub isnt ($$;$) { 93 $Test->isnt_eq(@_); 94} 95 96*isn't = \&isnt; 97 98 99#line 371 100 101sub like ($$;$) { 102 $Test->like(@_); 103} 104 105 106#line 385 107 108sub unlike { 109 $Test->unlike(@_); 110} 111 112 113#line 423 114 115sub cmp_ok($$$;$) { 116 $Test->cmp_ok(@_); 117} 118 119 120#line 457 121 122sub can_ok ($@) { 123 my($proto, @methods) = @_; 124 my $class = ref $proto || $proto; 125 126 unless( @methods ) { 127 my $ok = $Test->ok( 0, "$class->can(...)" ); 128 $Test->diag(' can_ok() called with no methods'); 129 return $ok; 130 } 131 132 my @nok = (); 133 foreach my $method (@methods) { 134 local($!, $@); # don't interfere with caller's $@ 135 # eval sometimes resets $! 136 eval { $proto->can($method) } || push @nok, $method; 137 } 138 139 my $name; 140 $name = @methods == 1 ? "$class->can('$methods[0]')" 141 : "$class->can(...)"; 142 143 my $ok = $Test->ok( !@nok, $name ); 144 145 $Test->diag(map " $class->can('$_') failed\n", @nok); 146 147 return $ok; 148} 149 150#line 514 151 152sub isa_ok ($$;$) { 153 my($object, $class, $obj_name) = @_; 154 155 my $diag; 156 $obj_name = 'The object' unless defined $obj_name; 157 my $name = "$obj_name isa $class"; 158 if( !defined $object ) { 159 $diag = "$obj_name isn't defined"; 160 } 161 elsif( !ref $object ) { 162 $diag = "$obj_name isn't a reference"; 163 } 164 else { 165 # We can't use UNIVERSAL::isa because we want to honor isa() overrides 166 local($@, $!); # eval sometimes resets $! 167 my $rslt = eval { $object->isa($class) }; 168 if( $@ ) { 169 if( $@ =~ /^Can't call method "isa" on unblessed reference/ ) { 170 if( !UNIVERSAL::isa($object, $class) ) { 171 my $ref = ref $object; 172 $diag = "$obj_name isn't a '$class' it's a '$ref'"; 173 } 174 } else { 175 die <<WHOA; 176WHOA! I tried to call ->isa on your object and got some weird error. 177This should never happen. Please contact the author immediately. 178Here's the error. 179$@ 180WHOA 181 } 182 } 183 elsif( !$rslt ) { 184 my $ref = ref $object; 185 $diag = "$obj_name isn't a '$class' it's a '$ref'"; 186 } 187 } 188 189 190 191 my $ok; 192 if( $diag ) { 193 $ok = $Test->ok( 0, $name ); 194 $Test->diag(" $diag\n"); 195 } 196 else { 197 $ok = $Test->ok( 1, $name ); 198 } 199 200 return $ok; 201} 202 203 204#line 583 205 206sub pass (;$) { 207 $Test->ok(1, @_); 208} 209 210sub fail (;$) { 211 $Test->ok(0, @_); 212} 213 214#line 627 215 216sub diag { 217 $Test->diag(@_); 218} 219 220 221#line 677 222 223sub use_ok ($;@) { 224 my($module, @imports) = @_; 225 @imports = () unless @imports; 226 227 my $pack = caller; 228 229 local($@,$!); # eval sometimes interferes with $! 230 eval <<USE; 231package $pack; 232require $module; 233'$module'->import(\@imports); 234USE 235 236 my $ok = $Test->ok( !$@, "use $module;" ); 237 238 unless( $ok ) { 239 chomp $@; 240 $Test->diag(<<DIAGNOSTIC); 241 Tried to use '$module'. 242 Error: $@ 243DIAGNOSTIC 244 245 } 246 247 return $ok; 248} 249 250#line 712 251 252sub require_ok ($) { 253 my($module) = shift; 254 255 my $pack = caller; 256 257 local($!, $@); # eval sometimes interferes with $! 258 eval <<REQUIRE; 259package $pack; 260require $module; 261REQUIRE 262 263 my $ok = $Test->ok( !$@, "require $module;" ); 264 265 unless( $ok ) { 266 chomp $@; 267 $Test->diag(<<DIAGNOSTIC); 268 Tried to require '$module'. 269 Error: $@ 270DIAGNOSTIC 271 272 } 273 274 return $ok; 275} 276 277#line 796 278 279#'# 280sub skip { 281 my($why, $how_many) = @_; 282 283 unless( defined $how_many ) { 284 # $how_many can only be avoided when no_plan is in use. 285 _carp "skip() needs to know \$how_many tests are in the block" 286 unless $Test::Builder::No_Plan; 287 $how_many = 1; 288 } 289 290 for( 1..$how_many ) { 291 $Test->skip($why); 292 } 293 294 local $^W = 0; 295 last SKIP; 296} 297 298 299#line 874 300 301sub todo_skip { 302 my($why, $how_many) = @_; 303 304 unless( defined $how_many ) { 305 # $how_many can only be avoided when no_plan is in use. 306 _carp "todo_skip() needs to know \$how_many tests are in the block" 307 unless $Test::Builder::No_Plan; 308 $how_many = 1; 309 } 310 311 for( 1..$how_many ) { 312 $Test->todo_skip($why); 313 } 314 315 local $^W = 0; 316 last TODO; 317} 318 319#line 933 320 321use vars qw(@Data_Stack); 322my $DNE = bless [], 'Does::Not::Exist'; 323sub is_deeply { 324 my($this, $that, $name) = @_; 325 326 my $ok; 327 if( !ref $this || !ref $that ) { 328 $ok = $Test->is_eq($this, $that, $name); 329 } 330 else { 331 local @Data_Stack = (); 332 if( _deep_check($this, $that) ) { 333 $ok = $Test->ok(1, $name); 334 } 335 else { 336 $ok = $Test->ok(0, $name); 337 $ok = $Test->diag(_format_stack(@Data_Stack)); 338 } 339 } 340 341 return $ok; 342} 343 344sub _format_stack { 345 my(@Stack) = @_; 346 347 my $var = '$FOO'; 348 my $did_arrow = 0; 349 foreach my $entry (@Stack) { 350 my $type = $entry->{type} || ''; 351 my $idx = $entry->{'idx'}; 352 if( $type eq 'HASH' ) { 353 $var .= "->" unless $did_arrow++; 354 $var .= "{$idx}"; 355 } 356 elsif( $type eq 'ARRAY' ) { 357 $var .= "->" unless $did_arrow++; 358 $var .= "[$idx]"; 359 } 360 elsif( $type eq 'REF' ) { 361 $var = "\${$var}"; 362 } 363 } 364 365 my @vals = @{$Stack[-1]{vals}}[0,1]; 366 my @vars = (); 367 ($vars[0] = $var) =~ s/\$FOO/ \$got/; 368 ($vars[1] = $var) =~ s/\$FOO/\$expected/; 369 370 my $out = "Structures begin differing at:\n"; 371 foreach my $idx (0..$#vals) { 372 my $val = $vals[$idx]; 373 $vals[$idx] = !defined $val ? 'undef' : 374 $val eq $DNE ? "Does not exist" 375 : "'$val'"; 376 } 377 378 $out .= "$vars[0] = $vals[0]\n"; 379 $out .= "$vars[1] = $vals[1]\n"; 380 381 $out =~ s/^/ /msg; 382 return $out; 383} 384 385 386#line 1007 387 388#'# 389sub eq_array { 390 my($a1, $a2) = @_; 391 return 1 if $a1 eq $a2; 392 393 my $ok = 1; 394 my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2; 395 for (0..$max) { 396 my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_]; 397 my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_]; 398 399 push @Data_Stack, { type => 'ARRAY', idx => $_, vals => [$e1, $e2] }; 400 $ok = _deep_check($e1,$e2); 401 pop @Data_Stack if $ok; 402 403 last unless $ok; 404 } 405 return $ok; 406} 407 408sub _deep_check { 409 my($e1, $e2) = @_; 410 my $ok = 0; 411 412 my $eq; 413 { 414 # Quiet uninitialized value warnings when comparing undefs. 415 local $^W = 0; 416 417 if( $e1 eq $e2 ) { 418 $ok = 1; 419 } 420 else { 421 if( UNIVERSAL::isa($e1, 'ARRAY') and 422 UNIVERSAL::isa($e2, 'ARRAY') ) 423 { 424 $ok = eq_array($e1, $e2); 425 } 426 elsif( UNIVERSAL::isa($e1, 'HASH') and 427 UNIVERSAL::isa($e2, 'HASH') ) 428 { 429 $ok = eq_hash($e1, $e2); 430 } 431 elsif( UNIVERSAL::isa($e1, 'REF') and 432 UNIVERSAL::isa($e2, 'REF') ) 433 { 434 push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; 435 $ok = _deep_check($$e1, $$e2); 436 pop @Data_Stack if $ok; 437 } 438 elsif( UNIVERSAL::isa($e1, 'SCALAR') and 439 UNIVERSAL::isa($e2, 'SCALAR') ) 440 { 441 push @Data_Stack, { type => 'REF', vals => [$e1, $e2] }; 442 $ok = _deep_check($$e1, $$e2); 443 } 444 else { 445 push @Data_Stack, { vals => [$e1, $e2] }; 446 $ok = 0; 447 } 448 } 449 } 450 451 return $ok; 452} 453 454 455#line 1083 456 457sub eq_hash { 458 my($a1, $a2) = @_; 459 return 1 if $a1 eq $a2; 460 461 my $ok = 1; 462 my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2; 463 foreach my $k (keys %$bigger) { 464 my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE; 465 my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE; 466 467 push @Data_Stack, { type => 'HASH', idx => $k, vals => [$e1, $e2] }; 468 $ok = _deep_check($e1, $e2); 469 pop @Data_Stack if $ok; 470 471 last unless $ok; 472 } 473 474 return $ok; 475} 476 477#line 1116 478 479# We must make sure that references are treated neutrally. It really 480# doesn't matter how we sort them, as long as both arrays are sorted 481# with the same algorithm. 482sub _bogus_sort { local $^W = 0; ref $a ? 0 : $a cmp $b } 483 484sub eq_set { 485 my($a1, $a2) = @_; 486 return 0 unless @$a1 == @$a2; 487 488 # There's faster ways to do this, but this is easiest. 489 return eq_array( [sort _bogus_sort @$a1], [sort _bogus_sort @$a2] ); 490} 491 492#line 1154 493 494sub builder { 495 return Test::Builder->new; 496} 497 498#line 1247 499 5001; 501