1*0Sstevel@tonic-gatepackage Test::Builder; 2*0Sstevel@tonic-gate 3*0Sstevel@tonic-gateuse 5.004; 4*0Sstevel@tonic-gate 5*0Sstevel@tonic-gate# $^C was only introduced in 5.005-ish. We do this to prevent 6*0Sstevel@tonic-gate# use of uninitialized value warnings in older perls. 7*0Sstevel@tonic-gate$^C ||= 0; 8*0Sstevel@tonic-gate 9*0Sstevel@tonic-gateuse strict; 10*0Sstevel@tonic-gateuse vars qw($VERSION $CLASS); 11*0Sstevel@tonic-gate$VERSION = '0.17'; 12*0Sstevel@tonic-gate$CLASS = __PACKAGE__; 13*0Sstevel@tonic-gate 14*0Sstevel@tonic-gatemy $IsVMS = $^O eq 'VMS'; 15*0Sstevel@tonic-gate 16*0Sstevel@tonic-gate# Make Test::Builder thread-safe for ithreads. 17*0Sstevel@tonic-gateBEGIN { 18*0Sstevel@tonic-gate use Config; 19*0Sstevel@tonic-gate if( $] >= 5.008 && $Config{useithreads} ) { 20*0Sstevel@tonic-gate require threads; 21*0Sstevel@tonic-gate require threads::shared; 22*0Sstevel@tonic-gate threads::shared->import; 23*0Sstevel@tonic-gate } 24*0Sstevel@tonic-gate else { 25*0Sstevel@tonic-gate *share = sub { 0 }; 26*0Sstevel@tonic-gate *lock = sub { 0 }; 27*0Sstevel@tonic-gate } 28*0Sstevel@tonic-gate} 29*0Sstevel@tonic-gate 30*0Sstevel@tonic-gateuse vars qw($Level); 31*0Sstevel@tonic-gatemy($Test_Died) = 0; 32*0Sstevel@tonic-gatemy($Have_Plan) = 0; 33*0Sstevel@tonic-gatemy $Original_Pid = $$; 34*0Sstevel@tonic-gatemy $Curr_Test = 0; share($Curr_Test); 35*0Sstevel@tonic-gatemy @Test_Results = (); share(@Test_Results); 36*0Sstevel@tonic-gatemy @Test_Details = (); share(@Test_Details); 37*0Sstevel@tonic-gate 38*0Sstevel@tonic-gate 39*0Sstevel@tonic-gate=head1 NAME 40*0Sstevel@tonic-gate 41*0Sstevel@tonic-gateTest::Builder - Backend for building test libraries 42*0Sstevel@tonic-gate 43*0Sstevel@tonic-gate=head1 SYNOPSIS 44*0Sstevel@tonic-gate 45*0Sstevel@tonic-gate package My::Test::Module; 46*0Sstevel@tonic-gate use Test::Builder; 47*0Sstevel@tonic-gate require Exporter; 48*0Sstevel@tonic-gate @ISA = qw(Exporter); 49*0Sstevel@tonic-gate @EXPORT = qw(ok); 50*0Sstevel@tonic-gate 51*0Sstevel@tonic-gate my $Test = Test::Builder->new; 52*0Sstevel@tonic-gate $Test->output('my_logfile'); 53*0Sstevel@tonic-gate 54*0Sstevel@tonic-gate sub import { 55*0Sstevel@tonic-gate my($self) = shift; 56*0Sstevel@tonic-gate my $pack = caller; 57*0Sstevel@tonic-gate 58*0Sstevel@tonic-gate $Test->exported_to($pack); 59*0Sstevel@tonic-gate $Test->plan(@_); 60*0Sstevel@tonic-gate 61*0Sstevel@tonic-gate $self->export_to_level(1, $self, 'ok'); 62*0Sstevel@tonic-gate } 63*0Sstevel@tonic-gate 64*0Sstevel@tonic-gate sub ok { 65*0Sstevel@tonic-gate my($test, $name) = @_; 66*0Sstevel@tonic-gate 67*0Sstevel@tonic-gate $Test->ok($test, $name); 68*0Sstevel@tonic-gate } 69*0Sstevel@tonic-gate 70*0Sstevel@tonic-gate 71*0Sstevel@tonic-gate=head1 DESCRIPTION 72*0Sstevel@tonic-gate 73*0Sstevel@tonic-gateTest::Simple and Test::More have proven to be popular testing modules, 74*0Sstevel@tonic-gatebut they're not always flexible enough. Test::Builder provides the a 75*0Sstevel@tonic-gatebuilding block upon which to write your own test libraries I<which can 76*0Sstevel@tonic-gatework together>. 77*0Sstevel@tonic-gate 78*0Sstevel@tonic-gate=head2 Construction 79*0Sstevel@tonic-gate 80*0Sstevel@tonic-gate=over 4 81*0Sstevel@tonic-gate 82*0Sstevel@tonic-gate=item B<new> 83*0Sstevel@tonic-gate 84*0Sstevel@tonic-gate my $Test = Test::Builder->new; 85*0Sstevel@tonic-gate 86*0Sstevel@tonic-gateReturns a Test::Builder object representing the current state of the 87*0Sstevel@tonic-gatetest. 88*0Sstevel@tonic-gate 89*0Sstevel@tonic-gateSince you only run one test per program, there is B<one and only one> 90*0Sstevel@tonic-gateTest::Builder object. No matter how many times you call new(), you're 91*0Sstevel@tonic-gategetting the same object. (This is called a singleton). 92*0Sstevel@tonic-gate 93*0Sstevel@tonic-gate=cut 94*0Sstevel@tonic-gate 95*0Sstevel@tonic-gatemy $Test; 96*0Sstevel@tonic-gatesub new { 97*0Sstevel@tonic-gate my($class) = shift; 98*0Sstevel@tonic-gate $Test ||= bless ['Move along, nothing to see here'], $class; 99*0Sstevel@tonic-gate return $Test; 100*0Sstevel@tonic-gate} 101*0Sstevel@tonic-gate 102*0Sstevel@tonic-gate=back 103*0Sstevel@tonic-gate 104*0Sstevel@tonic-gate=head2 Setting up tests 105*0Sstevel@tonic-gate 106*0Sstevel@tonic-gateThese methods are for setting up tests and declaring how many there 107*0Sstevel@tonic-gateare. You usually only want to call one of these methods. 108*0Sstevel@tonic-gate 109*0Sstevel@tonic-gate=over 4 110*0Sstevel@tonic-gate 111*0Sstevel@tonic-gate=item B<exported_to> 112*0Sstevel@tonic-gate 113*0Sstevel@tonic-gate my $pack = $Test->exported_to; 114*0Sstevel@tonic-gate $Test->exported_to($pack); 115*0Sstevel@tonic-gate 116*0Sstevel@tonic-gateTells Test::Builder what package you exported your functions to. 117*0Sstevel@tonic-gateThis is important for getting TODO tests right. 118*0Sstevel@tonic-gate 119*0Sstevel@tonic-gate=cut 120*0Sstevel@tonic-gate 121*0Sstevel@tonic-gatemy $Exported_To; 122*0Sstevel@tonic-gatesub exported_to { 123*0Sstevel@tonic-gate my($self, $pack) = @_; 124*0Sstevel@tonic-gate 125*0Sstevel@tonic-gate if( defined $pack ) { 126*0Sstevel@tonic-gate $Exported_To = $pack; 127*0Sstevel@tonic-gate } 128*0Sstevel@tonic-gate return $Exported_To; 129*0Sstevel@tonic-gate} 130*0Sstevel@tonic-gate 131*0Sstevel@tonic-gate=item B<plan> 132*0Sstevel@tonic-gate 133*0Sstevel@tonic-gate $Test->plan('no_plan'); 134*0Sstevel@tonic-gate $Test->plan( skip_all => $reason ); 135*0Sstevel@tonic-gate $Test->plan( tests => $num_tests ); 136*0Sstevel@tonic-gate 137*0Sstevel@tonic-gateA convenient way to set up your tests. Call this and Test::Builder 138*0Sstevel@tonic-gatewill print the appropriate headers and take the appropriate actions. 139*0Sstevel@tonic-gate 140*0Sstevel@tonic-gateIf you call plan(), don't call any of the other methods below. 141*0Sstevel@tonic-gate 142*0Sstevel@tonic-gate=cut 143*0Sstevel@tonic-gate 144*0Sstevel@tonic-gatesub plan { 145*0Sstevel@tonic-gate my($self, $cmd, $arg) = @_; 146*0Sstevel@tonic-gate 147*0Sstevel@tonic-gate return unless $cmd; 148*0Sstevel@tonic-gate 149*0Sstevel@tonic-gate if( $Have_Plan ) { 150*0Sstevel@tonic-gate die sprintf "You tried to plan twice! Second plan at %s line %d\n", 151*0Sstevel@tonic-gate ($self->caller)[1,2]; 152*0Sstevel@tonic-gate } 153*0Sstevel@tonic-gate 154*0Sstevel@tonic-gate if( $cmd eq 'no_plan' ) { 155*0Sstevel@tonic-gate $self->no_plan; 156*0Sstevel@tonic-gate } 157*0Sstevel@tonic-gate elsif( $cmd eq 'skip_all' ) { 158*0Sstevel@tonic-gate return $self->skip_all($arg); 159*0Sstevel@tonic-gate } 160*0Sstevel@tonic-gate elsif( $cmd eq 'tests' ) { 161*0Sstevel@tonic-gate if( $arg ) { 162*0Sstevel@tonic-gate return $self->expected_tests($arg); 163*0Sstevel@tonic-gate } 164*0Sstevel@tonic-gate elsif( !defined $arg ) { 165*0Sstevel@tonic-gate die "Got an undefined number of tests. Looks like you tried to ". 166*0Sstevel@tonic-gate "say how many tests you plan to run but made a mistake.\n"; 167*0Sstevel@tonic-gate } 168*0Sstevel@tonic-gate elsif( !$arg ) { 169*0Sstevel@tonic-gate die "You said to run 0 tests! You've got to run something.\n"; 170*0Sstevel@tonic-gate } 171*0Sstevel@tonic-gate } 172*0Sstevel@tonic-gate else { 173*0Sstevel@tonic-gate require Carp; 174*0Sstevel@tonic-gate my @args = grep { defined } ($cmd, $arg); 175*0Sstevel@tonic-gate Carp::croak("plan() doesn't understand @args"); 176*0Sstevel@tonic-gate } 177*0Sstevel@tonic-gate 178*0Sstevel@tonic-gate return 1; 179*0Sstevel@tonic-gate} 180*0Sstevel@tonic-gate 181*0Sstevel@tonic-gate=item B<expected_tests> 182*0Sstevel@tonic-gate 183*0Sstevel@tonic-gate my $max = $Test->expected_tests; 184*0Sstevel@tonic-gate $Test->expected_tests($max); 185*0Sstevel@tonic-gate 186*0Sstevel@tonic-gateGets/sets the # of tests we expect this test to run and prints out 187*0Sstevel@tonic-gatethe appropriate headers. 188*0Sstevel@tonic-gate 189*0Sstevel@tonic-gate=cut 190*0Sstevel@tonic-gate 191*0Sstevel@tonic-gatemy $Expected_Tests = 0; 192*0Sstevel@tonic-gatesub expected_tests { 193*0Sstevel@tonic-gate my($self, $max) = @_; 194*0Sstevel@tonic-gate 195*0Sstevel@tonic-gate if( defined $max ) { 196*0Sstevel@tonic-gate $Expected_Tests = $max; 197*0Sstevel@tonic-gate $Have_Plan = 1; 198*0Sstevel@tonic-gate 199*0Sstevel@tonic-gate $self->_print("1..$max\n") unless $self->no_header; 200*0Sstevel@tonic-gate } 201*0Sstevel@tonic-gate return $Expected_Tests; 202*0Sstevel@tonic-gate} 203*0Sstevel@tonic-gate 204*0Sstevel@tonic-gate 205*0Sstevel@tonic-gate=item B<no_plan> 206*0Sstevel@tonic-gate 207*0Sstevel@tonic-gate $Test->no_plan; 208*0Sstevel@tonic-gate 209*0Sstevel@tonic-gateDeclares that this test will run an indeterminate # of tests. 210*0Sstevel@tonic-gate 211*0Sstevel@tonic-gate=cut 212*0Sstevel@tonic-gate 213*0Sstevel@tonic-gatemy($No_Plan) = 0; 214*0Sstevel@tonic-gatesub no_plan { 215*0Sstevel@tonic-gate $No_Plan = 1; 216*0Sstevel@tonic-gate $Have_Plan = 1; 217*0Sstevel@tonic-gate} 218*0Sstevel@tonic-gate 219*0Sstevel@tonic-gate=item B<has_plan> 220*0Sstevel@tonic-gate 221*0Sstevel@tonic-gate $plan = $Test->has_plan 222*0Sstevel@tonic-gate 223*0Sstevel@tonic-gateFind out whether a plan has been defined. $plan is either C<undef> (no plan has been set), C<no_plan> (indeterminate # of tests) or an integer (the number of expected tests). 224*0Sstevel@tonic-gate 225*0Sstevel@tonic-gate=cut 226*0Sstevel@tonic-gate 227*0Sstevel@tonic-gatesub has_plan { 228*0Sstevel@tonic-gate return($Expected_Tests) if $Expected_Tests; 229*0Sstevel@tonic-gate return('no_plan') if $No_Plan; 230*0Sstevel@tonic-gate return(undef); 231*0Sstevel@tonic-gate}; 232*0Sstevel@tonic-gate 233*0Sstevel@tonic-gate 234*0Sstevel@tonic-gate=item B<skip_all> 235*0Sstevel@tonic-gate 236*0Sstevel@tonic-gate $Test->skip_all; 237*0Sstevel@tonic-gate $Test->skip_all($reason); 238*0Sstevel@tonic-gate 239*0Sstevel@tonic-gateSkips all the tests, using the given $reason. Exits immediately with 0. 240*0Sstevel@tonic-gate 241*0Sstevel@tonic-gate=cut 242*0Sstevel@tonic-gate 243*0Sstevel@tonic-gatemy $Skip_All = 0; 244*0Sstevel@tonic-gatesub skip_all { 245*0Sstevel@tonic-gate my($self, $reason) = @_; 246*0Sstevel@tonic-gate 247*0Sstevel@tonic-gate my $out = "1..0"; 248*0Sstevel@tonic-gate $out .= " # Skip $reason" if $reason; 249*0Sstevel@tonic-gate $out .= "\n"; 250*0Sstevel@tonic-gate 251*0Sstevel@tonic-gate $Skip_All = 1; 252*0Sstevel@tonic-gate 253*0Sstevel@tonic-gate $self->_print($out) unless $self->no_header; 254*0Sstevel@tonic-gate exit(0); 255*0Sstevel@tonic-gate} 256*0Sstevel@tonic-gate 257*0Sstevel@tonic-gate=back 258*0Sstevel@tonic-gate 259*0Sstevel@tonic-gate=head2 Running tests 260*0Sstevel@tonic-gate 261*0Sstevel@tonic-gateThese actually run the tests, analogous to the functions in 262*0Sstevel@tonic-gateTest::More. 263*0Sstevel@tonic-gate 264*0Sstevel@tonic-gate$name is always optional. 265*0Sstevel@tonic-gate 266*0Sstevel@tonic-gate=over 4 267*0Sstevel@tonic-gate 268*0Sstevel@tonic-gate=item B<ok> 269*0Sstevel@tonic-gate 270*0Sstevel@tonic-gate $Test->ok($test, $name); 271*0Sstevel@tonic-gate 272*0Sstevel@tonic-gateYour basic test. Pass if $test is true, fail if $test is false. Just 273*0Sstevel@tonic-gatelike Test::Simple's ok(). 274*0Sstevel@tonic-gate 275*0Sstevel@tonic-gate=cut 276*0Sstevel@tonic-gate 277*0Sstevel@tonic-gatesub ok { 278*0Sstevel@tonic-gate my($self, $test, $name) = @_; 279*0Sstevel@tonic-gate 280*0Sstevel@tonic-gate # $test might contain an object which we don't want to accidentally 281*0Sstevel@tonic-gate # store, so we turn it into a boolean. 282*0Sstevel@tonic-gate $test = $test ? 1 : 0; 283*0Sstevel@tonic-gate 284*0Sstevel@tonic-gate unless( $Have_Plan ) { 285*0Sstevel@tonic-gate require Carp; 286*0Sstevel@tonic-gate Carp::croak("You tried to run a test without a plan! Gotta have a plan."); 287*0Sstevel@tonic-gate } 288*0Sstevel@tonic-gate 289*0Sstevel@tonic-gate lock $Curr_Test; 290*0Sstevel@tonic-gate $Curr_Test++; 291*0Sstevel@tonic-gate 292*0Sstevel@tonic-gate $self->diag(<<ERR) if defined $name and $name =~ /^[\d\s]+$/; 293*0Sstevel@tonic-gate You named your test '$name'. You shouldn't use numbers for your test names. 294*0Sstevel@tonic-gate Very confusing. 295*0Sstevel@tonic-gateERR 296*0Sstevel@tonic-gate 297*0Sstevel@tonic-gate my($pack, $file, $line) = $self->caller; 298*0Sstevel@tonic-gate 299*0Sstevel@tonic-gate my $todo = $self->todo($pack); 300*0Sstevel@tonic-gate 301*0Sstevel@tonic-gate my $out; 302*0Sstevel@tonic-gate my $result = {}; 303*0Sstevel@tonic-gate share($result); 304*0Sstevel@tonic-gate 305*0Sstevel@tonic-gate unless( $test ) { 306*0Sstevel@tonic-gate $out .= "not "; 307*0Sstevel@tonic-gate @$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 ); 308*0Sstevel@tonic-gate } 309*0Sstevel@tonic-gate else { 310*0Sstevel@tonic-gate @$result{ 'ok', 'actual_ok' } = ( 1, $test ); 311*0Sstevel@tonic-gate } 312*0Sstevel@tonic-gate 313*0Sstevel@tonic-gate $out .= "ok"; 314*0Sstevel@tonic-gate $out .= " $Curr_Test" if $self->use_numbers; 315*0Sstevel@tonic-gate 316*0Sstevel@tonic-gate if( defined $name ) { 317*0Sstevel@tonic-gate $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness. 318*0Sstevel@tonic-gate $out .= " - $name"; 319*0Sstevel@tonic-gate $result->{name} = $name; 320*0Sstevel@tonic-gate } 321*0Sstevel@tonic-gate else { 322*0Sstevel@tonic-gate $result->{name} = ''; 323*0Sstevel@tonic-gate } 324*0Sstevel@tonic-gate 325*0Sstevel@tonic-gate if( $todo ) { 326*0Sstevel@tonic-gate my $what_todo = $todo; 327*0Sstevel@tonic-gate $out .= " # TODO $what_todo"; 328*0Sstevel@tonic-gate $result->{reason} = $what_todo; 329*0Sstevel@tonic-gate $result->{type} = 'todo'; 330*0Sstevel@tonic-gate } 331*0Sstevel@tonic-gate else { 332*0Sstevel@tonic-gate $result->{reason} = ''; 333*0Sstevel@tonic-gate $result->{type} = ''; 334*0Sstevel@tonic-gate } 335*0Sstevel@tonic-gate 336*0Sstevel@tonic-gate $Test_Results[$Curr_Test-1] = $result; 337*0Sstevel@tonic-gate $out .= "\n"; 338*0Sstevel@tonic-gate 339*0Sstevel@tonic-gate $self->_print($out); 340*0Sstevel@tonic-gate 341*0Sstevel@tonic-gate unless( $test ) { 342*0Sstevel@tonic-gate my $msg = $todo ? "Failed (TODO)" : "Failed"; 343*0Sstevel@tonic-gate $self->diag(" $msg test ($file at line $line)\n"); 344*0Sstevel@tonic-gate } 345*0Sstevel@tonic-gate 346*0Sstevel@tonic-gate return $test ? 1 : 0; 347*0Sstevel@tonic-gate} 348*0Sstevel@tonic-gate 349*0Sstevel@tonic-gate=item B<is_eq> 350*0Sstevel@tonic-gate 351*0Sstevel@tonic-gate $Test->is_eq($got, $expected, $name); 352*0Sstevel@tonic-gate 353*0Sstevel@tonic-gateLike Test::More's is(). Checks if $got eq $expected. This is the 354*0Sstevel@tonic-gatestring version. 355*0Sstevel@tonic-gate 356*0Sstevel@tonic-gate=item B<is_num> 357*0Sstevel@tonic-gate 358*0Sstevel@tonic-gate $Test->is_num($got, $expected, $name); 359*0Sstevel@tonic-gate 360*0Sstevel@tonic-gateLike Test::More's is(). Checks if $got == $expected. This is the 361*0Sstevel@tonic-gatenumeric version. 362*0Sstevel@tonic-gate 363*0Sstevel@tonic-gate=cut 364*0Sstevel@tonic-gate 365*0Sstevel@tonic-gatesub is_eq { 366*0Sstevel@tonic-gate my($self, $got, $expect, $name) = @_; 367*0Sstevel@tonic-gate local $Level = $Level + 1; 368*0Sstevel@tonic-gate 369*0Sstevel@tonic-gate if( !defined $got || !defined $expect ) { 370*0Sstevel@tonic-gate # undef only matches undef and nothing else 371*0Sstevel@tonic-gate my $test = !defined $got && !defined $expect; 372*0Sstevel@tonic-gate 373*0Sstevel@tonic-gate $self->ok($test, $name); 374*0Sstevel@tonic-gate $self->_is_diag($got, 'eq', $expect) unless $test; 375*0Sstevel@tonic-gate return $test; 376*0Sstevel@tonic-gate } 377*0Sstevel@tonic-gate 378*0Sstevel@tonic-gate return $self->cmp_ok($got, 'eq', $expect, $name); 379*0Sstevel@tonic-gate} 380*0Sstevel@tonic-gate 381*0Sstevel@tonic-gatesub is_num { 382*0Sstevel@tonic-gate my($self, $got, $expect, $name) = @_; 383*0Sstevel@tonic-gate local $Level = $Level + 1; 384*0Sstevel@tonic-gate 385*0Sstevel@tonic-gate if( !defined $got || !defined $expect ) { 386*0Sstevel@tonic-gate # undef only matches undef and nothing else 387*0Sstevel@tonic-gate my $test = !defined $got && !defined $expect; 388*0Sstevel@tonic-gate 389*0Sstevel@tonic-gate $self->ok($test, $name); 390*0Sstevel@tonic-gate $self->_is_diag($got, '==', $expect) unless $test; 391*0Sstevel@tonic-gate return $test; 392*0Sstevel@tonic-gate } 393*0Sstevel@tonic-gate 394*0Sstevel@tonic-gate return $self->cmp_ok($got, '==', $expect, $name); 395*0Sstevel@tonic-gate} 396*0Sstevel@tonic-gate 397*0Sstevel@tonic-gatesub _is_diag { 398*0Sstevel@tonic-gate my($self, $got, $type, $expect) = @_; 399*0Sstevel@tonic-gate 400*0Sstevel@tonic-gate foreach my $val (\$got, \$expect) { 401*0Sstevel@tonic-gate if( defined $$val ) { 402*0Sstevel@tonic-gate if( $type eq 'eq' ) { 403*0Sstevel@tonic-gate # quote and force string context 404*0Sstevel@tonic-gate $$val = "'$$val'" 405*0Sstevel@tonic-gate } 406*0Sstevel@tonic-gate else { 407*0Sstevel@tonic-gate # force numeric context 408*0Sstevel@tonic-gate $$val = $$val+0; 409*0Sstevel@tonic-gate } 410*0Sstevel@tonic-gate } 411*0Sstevel@tonic-gate else { 412*0Sstevel@tonic-gate $$val = 'undef'; 413*0Sstevel@tonic-gate } 414*0Sstevel@tonic-gate } 415*0Sstevel@tonic-gate 416*0Sstevel@tonic-gate return $self->diag(sprintf <<DIAGNOSTIC, $got, $expect); 417*0Sstevel@tonic-gate got: %s 418*0Sstevel@tonic-gate expected: %s 419*0Sstevel@tonic-gateDIAGNOSTIC 420*0Sstevel@tonic-gate 421*0Sstevel@tonic-gate} 422*0Sstevel@tonic-gate 423*0Sstevel@tonic-gate=item B<isnt_eq> 424*0Sstevel@tonic-gate 425*0Sstevel@tonic-gate $Test->isnt_eq($got, $dont_expect, $name); 426*0Sstevel@tonic-gate 427*0Sstevel@tonic-gateLike Test::More's isnt(). Checks if $got ne $dont_expect. This is 428*0Sstevel@tonic-gatethe string version. 429*0Sstevel@tonic-gate 430*0Sstevel@tonic-gate=item B<isnt_num> 431*0Sstevel@tonic-gate 432*0Sstevel@tonic-gate $Test->is_num($got, $dont_expect, $name); 433*0Sstevel@tonic-gate 434*0Sstevel@tonic-gateLike Test::More's isnt(). Checks if $got ne $dont_expect. This is 435*0Sstevel@tonic-gatethe numeric version. 436*0Sstevel@tonic-gate 437*0Sstevel@tonic-gate=cut 438*0Sstevel@tonic-gate 439*0Sstevel@tonic-gatesub isnt_eq { 440*0Sstevel@tonic-gate my($self, $got, $dont_expect, $name) = @_; 441*0Sstevel@tonic-gate local $Level = $Level + 1; 442*0Sstevel@tonic-gate 443*0Sstevel@tonic-gate if( !defined $got || !defined $dont_expect ) { 444*0Sstevel@tonic-gate # undef only matches undef and nothing else 445*0Sstevel@tonic-gate my $test = defined $got || defined $dont_expect; 446*0Sstevel@tonic-gate 447*0Sstevel@tonic-gate $self->ok($test, $name); 448*0Sstevel@tonic-gate $self->_cmp_diag('ne', $got, $dont_expect) unless $test; 449*0Sstevel@tonic-gate return $test; 450*0Sstevel@tonic-gate } 451*0Sstevel@tonic-gate 452*0Sstevel@tonic-gate return $self->cmp_ok($got, 'ne', $dont_expect, $name); 453*0Sstevel@tonic-gate} 454*0Sstevel@tonic-gate 455*0Sstevel@tonic-gatesub isnt_num { 456*0Sstevel@tonic-gate my($self, $got, $dont_expect, $name) = @_; 457*0Sstevel@tonic-gate local $Level = $Level + 1; 458*0Sstevel@tonic-gate 459*0Sstevel@tonic-gate if( !defined $got || !defined $dont_expect ) { 460*0Sstevel@tonic-gate # undef only matches undef and nothing else 461*0Sstevel@tonic-gate my $test = defined $got || defined $dont_expect; 462*0Sstevel@tonic-gate 463*0Sstevel@tonic-gate $self->ok($test, $name); 464*0Sstevel@tonic-gate $self->_cmp_diag('!=', $got, $dont_expect) unless $test; 465*0Sstevel@tonic-gate return $test; 466*0Sstevel@tonic-gate } 467*0Sstevel@tonic-gate 468*0Sstevel@tonic-gate return $self->cmp_ok($got, '!=', $dont_expect, $name); 469*0Sstevel@tonic-gate} 470*0Sstevel@tonic-gate 471*0Sstevel@tonic-gate 472*0Sstevel@tonic-gate=item B<like> 473*0Sstevel@tonic-gate 474*0Sstevel@tonic-gate $Test->like($this, qr/$regex/, $name); 475*0Sstevel@tonic-gate $Test->like($this, '/$regex/', $name); 476*0Sstevel@tonic-gate 477*0Sstevel@tonic-gateLike Test::More's like(). Checks if $this matches the given $regex. 478*0Sstevel@tonic-gate 479*0Sstevel@tonic-gateYou'll want to avoid qr// if you want your tests to work before 5.005. 480*0Sstevel@tonic-gate 481*0Sstevel@tonic-gate=item B<unlike> 482*0Sstevel@tonic-gate 483*0Sstevel@tonic-gate $Test->unlike($this, qr/$regex/, $name); 484*0Sstevel@tonic-gate $Test->unlike($this, '/$regex/', $name); 485*0Sstevel@tonic-gate 486*0Sstevel@tonic-gateLike Test::More's unlike(). Checks if $this B<does not match> the 487*0Sstevel@tonic-gategiven $regex. 488*0Sstevel@tonic-gate 489*0Sstevel@tonic-gate=cut 490*0Sstevel@tonic-gate 491*0Sstevel@tonic-gatesub like { 492*0Sstevel@tonic-gate my($self, $this, $regex, $name) = @_; 493*0Sstevel@tonic-gate 494*0Sstevel@tonic-gate local $Level = $Level + 1; 495*0Sstevel@tonic-gate $self->_regex_ok($this, $regex, '=~', $name); 496*0Sstevel@tonic-gate} 497*0Sstevel@tonic-gate 498*0Sstevel@tonic-gatesub unlike { 499*0Sstevel@tonic-gate my($self, $this, $regex, $name) = @_; 500*0Sstevel@tonic-gate 501*0Sstevel@tonic-gate local $Level = $Level + 1; 502*0Sstevel@tonic-gate $self->_regex_ok($this, $regex, '!~', $name); 503*0Sstevel@tonic-gate} 504*0Sstevel@tonic-gate 505*0Sstevel@tonic-gate=item B<maybe_regex> 506*0Sstevel@tonic-gate 507*0Sstevel@tonic-gate $Test->maybe_regex(qr/$regex/); 508*0Sstevel@tonic-gate $Test->maybe_regex('/$regex/'); 509*0Sstevel@tonic-gate 510*0Sstevel@tonic-gateConvenience method for building testing functions that take regular 511*0Sstevel@tonic-gateexpressions as arguments, but need to work before perl 5.005. 512*0Sstevel@tonic-gate 513*0Sstevel@tonic-gateTakes a quoted regular expression produced by qr//, or a string 514*0Sstevel@tonic-gaterepresenting a regular expression. 515*0Sstevel@tonic-gate 516*0Sstevel@tonic-gateReturns a Perl value which may be used instead of the corresponding 517*0Sstevel@tonic-gateregular expression, or undef if it's argument is not recognised. 518*0Sstevel@tonic-gate 519*0Sstevel@tonic-gateFor example, a version of like(), sans the useful diagnostic messages, 520*0Sstevel@tonic-gatecould be written as: 521*0Sstevel@tonic-gate 522*0Sstevel@tonic-gate sub laconic_like { 523*0Sstevel@tonic-gate my ($self, $this, $regex, $name) = @_; 524*0Sstevel@tonic-gate my $usable_regex = $self->maybe_regex($regex); 525*0Sstevel@tonic-gate die "expecting regex, found '$regex'\n" 526*0Sstevel@tonic-gate unless $usable_regex; 527*0Sstevel@tonic-gate $self->ok($this =~ m/$usable_regex/, $name); 528*0Sstevel@tonic-gate } 529*0Sstevel@tonic-gate 530*0Sstevel@tonic-gate=cut 531*0Sstevel@tonic-gate 532*0Sstevel@tonic-gate 533*0Sstevel@tonic-gatesub maybe_regex { 534*0Sstevel@tonic-gate my ($self, $regex) = @_; 535*0Sstevel@tonic-gate my $usable_regex = undef; 536*0Sstevel@tonic-gate if( ref $regex eq 'Regexp' ) { 537*0Sstevel@tonic-gate $usable_regex = $regex; 538*0Sstevel@tonic-gate } 539*0Sstevel@tonic-gate # Check if it looks like '/foo/' 540*0Sstevel@tonic-gate elsif( my($re, $opts) = $regex =~ m{^ /(.*)/ (\w*) $ }sx ) { 541*0Sstevel@tonic-gate $usable_regex = length $opts ? "(?$opts)$re" : $re; 542*0Sstevel@tonic-gate }; 543*0Sstevel@tonic-gate return($usable_regex) 544*0Sstevel@tonic-gate}; 545*0Sstevel@tonic-gate 546*0Sstevel@tonic-gatesub _regex_ok { 547*0Sstevel@tonic-gate my($self, $this, $regex, $cmp, $name) = @_; 548*0Sstevel@tonic-gate 549*0Sstevel@tonic-gate local $Level = $Level + 1; 550*0Sstevel@tonic-gate 551*0Sstevel@tonic-gate my $ok = 0; 552*0Sstevel@tonic-gate my $usable_regex = $self->maybe_regex($regex); 553*0Sstevel@tonic-gate unless (defined $usable_regex) { 554*0Sstevel@tonic-gate $ok = $self->ok( 0, $name ); 555*0Sstevel@tonic-gate $self->diag(" '$regex' doesn't look much like a regex to me."); 556*0Sstevel@tonic-gate return $ok; 557*0Sstevel@tonic-gate } 558*0Sstevel@tonic-gate 559*0Sstevel@tonic-gate { 560*0Sstevel@tonic-gate local $^W = 0; 561*0Sstevel@tonic-gate my $test = $this =~ /$usable_regex/ ? 1 : 0; 562*0Sstevel@tonic-gate $test = !$test if $cmp eq '!~'; 563*0Sstevel@tonic-gate $ok = $self->ok( $test, $name ); 564*0Sstevel@tonic-gate } 565*0Sstevel@tonic-gate 566*0Sstevel@tonic-gate unless( $ok ) { 567*0Sstevel@tonic-gate $this = defined $this ? "'$this'" : 'undef'; 568*0Sstevel@tonic-gate my $match = $cmp eq '=~' ? "doesn't match" : "matches"; 569*0Sstevel@tonic-gate $self->diag(sprintf <<DIAGNOSTIC, $this, $match, $regex); 570*0Sstevel@tonic-gate %s 571*0Sstevel@tonic-gate %13s '%s' 572*0Sstevel@tonic-gateDIAGNOSTIC 573*0Sstevel@tonic-gate 574*0Sstevel@tonic-gate } 575*0Sstevel@tonic-gate 576*0Sstevel@tonic-gate return $ok; 577*0Sstevel@tonic-gate} 578*0Sstevel@tonic-gate 579*0Sstevel@tonic-gate=item B<cmp_ok> 580*0Sstevel@tonic-gate 581*0Sstevel@tonic-gate $Test->cmp_ok($this, $type, $that, $name); 582*0Sstevel@tonic-gate 583*0Sstevel@tonic-gateWorks just like Test::More's cmp_ok(). 584*0Sstevel@tonic-gate 585*0Sstevel@tonic-gate $Test->cmp_ok($big_num, '!=', $other_big_num); 586*0Sstevel@tonic-gate 587*0Sstevel@tonic-gate=cut 588*0Sstevel@tonic-gate 589*0Sstevel@tonic-gatesub cmp_ok { 590*0Sstevel@tonic-gate my($self, $got, $type, $expect, $name) = @_; 591*0Sstevel@tonic-gate 592*0Sstevel@tonic-gate my $test; 593*0Sstevel@tonic-gate { 594*0Sstevel@tonic-gate local $^W = 0; 595*0Sstevel@tonic-gate local($@,$!); # don't interfere with $@ 596*0Sstevel@tonic-gate # eval() sometimes resets $! 597*0Sstevel@tonic-gate $test = eval "\$got $type \$expect"; 598*0Sstevel@tonic-gate } 599*0Sstevel@tonic-gate local $Level = $Level + 1; 600*0Sstevel@tonic-gate my $ok = $self->ok($test, $name); 601*0Sstevel@tonic-gate 602*0Sstevel@tonic-gate unless( $ok ) { 603*0Sstevel@tonic-gate if( $type =~ /^(eq|==)$/ ) { 604*0Sstevel@tonic-gate $self->_is_diag($got, $type, $expect); 605*0Sstevel@tonic-gate } 606*0Sstevel@tonic-gate else { 607*0Sstevel@tonic-gate $self->_cmp_diag($got, $type, $expect); 608*0Sstevel@tonic-gate } 609*0Sstevel@tonic-gate } 610*0Sstevel@tonic-gate return $ok; 611*0Sstevel@tonic-gate} 612*0Sstevel@tonic-gate 613*0Sstevel@tonic-gatesub _cmp_diag { 614*0Sstevel@tonic-gate my($self, $got, $type, $expect) = @_; 615*0Sstevel@tonic-gate 616*0Sstevel@tonic-gate $got = defined $got ? "'$got'" : 'undef'; 617*0Sstevel@tonic-gate $expect = defined $expect ? "'$expect'" : 'undef'; 618*0Sstevel@tonic-gate return $self->diag(sprintf <<DIAGNOSTIC, $got, $type, $expect); 619*0Sstevel@tonic-gate %s 620*0Sstevel@tonic-gate %s 621*0Sstevel@tonic-gate %s 622*0Sstevel@tonic-gateDIAGNOSTIC 623*0Sstevel@tonic-gate} 624*0Sstevel@tonic-gate 625*0Sstevel@tonic-gate=item B<BAILOUT> 626*0Sstevel@tonic-gate 627*0Sstevel@tonic-gate $Test->BAILOUT($reason); 628*0Sstevel@tonic-gate 629*0Sstevel@tonic-gateIndicates to the Test::Harness that things are going so badly all 630*0Sstevel@tonic-gatetesting should terminate. This includes running any additional test 631*0Sstevel@tonic-gatescripts. 632*0Sstevel@tonic-gate 633*0Sstevel@tonic-gateIt will exit with 255. 634*0Sstevel@tonic-gate 635*0Sstevel@tonic-gate=cut 636*0Sstevel@tonic-gate 637*0Sstevel@tonic-gatesub BAILOUT { 638*0Sstevel@tonic-gate my($self, $reason) = @_; 639*0Sstevel@tonic-gate 640*0Sstevel@tonic-gate $self->_print("Bail out! $reason"); 641*0Sstevel@tonic-gate exit 255; 642*0Sstevel@tonic-gate} 643*0Sstevel@tonic-gate 644*0Sstevel@tonic-gate=item B<skip> 645*0Sstevel@tonic-gate 646*0Sstevel@tonic-gate $Test->skip; 647*0Sstevel@tonic-gate $Test->skip($why); 648*0Sstevel@tonic-gate 649*0Sstevel@tonic-gateSkips the current test, reporting $why. 650*0Sstevel@tonic-gate 651*0Sstevel@tonic-gate=cut 652*0Sstevel@tonic-gate 653*0Sstevel@tonic-gatesub skip { 654*0Sstevel@tonic-gate my($self, $why) = @_; 655*0Sstevel@tonic-gate $why ||= ''; 656*0Sstevel@tonic-gate 657*0Sstevel@tonic-gate unless( $Have_Plan ) { 658*0Sstevel@tonic-gate require Carp; 659*0Sstevel@tonic-gate Carp::croak("You tried to run tests without a plan! Gotta have a plan."); 660*0Sstevel@tonic-gate } 661*0Sstevel@tonic-gate 662*0Sstevel@tonic-gate lock($Curr_Test); 663*0Sstevel@tonic-gate $Curr_Test++; 664*0Sstevel@tonic-gate 665*0Sstevel@tonic-gate my %result; 666*0Sstevel@tonic-gate share(%result); 667*0Sstevel@tonic-gate %result = ( 668*0Sstevel@tonic-gate 'ok' => 1, 669*0Sstevel@tonic-gate actual_ok => 1, 670*0Sstevel@tonic-gate name => '', 671*0Sstevel@tonic-gate type => 'skip', 672*0Sstevel@tonic-gate reason => $why, 673*0Sstevel@tonic-gate ); 674*0Sstevel@tonic-gate $Test_Results[$Curr_Test-1] = \%result; 675*0Sstevel@tonic-gate 676*0Sstevel@tonic-gate my $out = "ok"; 677*0Sstevel@tonic-gate $out .= " $Curr_Test" if $self->use_numbers; 678*0Sstevel@tonic-gate $out .= " # skip $why\n"; 679*0Sstevel@tonic-gate 680*0Sstevel@tonic-gate $Test->_print($out); 681*0Sstevel@tonic-gate 682*0Sstevel@tonic-gate return 1; 683*0Sstevel@tonic-gate} 684*0Sstevel@tonic-gate 685*0Sstevel@tonic-gate 686*0Sstevel@tonic-gate=item B<todo_skip> 687*0Sstevel@tonic-gate 688*0Sstevel@tonic-gate $Test->todo_skip; 689*0Sstevel@tonic-gate $Test->todo_skip($why); 690*0Sstevel@tonic-gate 691*0Sstevel@tonic-gateLike skip(), only it will declare the test as failing and TODO. Similar 692*0Sstevel@tonic-gateto 693*0Sstevel@tonic-gate 694*0Sstevel@tonic-gate print "not ok $tnum # TODO $why\n"; 695*0Sstevel@tonic-gate 696*0Sstevel@tonic-gate=cut 697*0Sstevel@tonic-gate 698*0Sstevel@tonic-gatesub todo_skip { 699*0Sstevel@tonic-gate my($self, $why) = @_; 700*0Sstevel@tonic-gate $why ||= ''; 701*0Sstevel@tonic-gate 702*0Sstevel@tonic-gate unless( $Have_Plan ) { 703*0Sstevel@tonic-gate require Carp; 704*0Sstevel@tonic-gate Carp::croak("You tried to run tests without a plan! Gotta have a plan."); 705*0Sstevel@tonic-gate } 706*0Sstevel@tonic-gate 707*0Sstevel@tonic-gate lock($Curr_Test); 708*0Sstevel@tonic-gate $Curr_Test++; 709*0Sstevel@tonic-gate 710*0Sstevel@tonic-gate my %result; 711*0Sstevel@tonic-gate share(%result); 712*0Sstevel@tonic-gate %result = ( 713*0Sstevel@tonic-gate 'ok' => 1, 714*0Sstevel@tonic-gate actual_ok => 0, 715*0Sstevel@tonic-gate name => '', 716*0Sstevel@tonic-gate type => 'todo_skip', 717*0Sstevel@tonic-gate reason => $why, 718*0Sstevel@tonic-gate ); 719*0Sstevel@tonic-gate 720*0Sstevel@tonic-gate $Test_Results[$Curr_Test-1] = \%result; 721*0Sstevel@tonic-gate 722*0Sstevel@tonic-gate my $out = "not ok"; 723*0Sstevel@tonic-gate $out .= " $Curr_Test" if $self->use_numbers; 724*0Sstevel@tonic-gate $out .= " # TODO & SKIP $why\n"; 725*0Sstevel@tonic-gate 726*0Sstevel@tonic-gate $Test->_print($out); 727*0Sstevel@tonic-gate 728*0Sstevel@tonic-gate return 1; 729*0Sstevel@tonic-gate} 730*0Sstevel@tonic-gate 731*0Sstevel@tonic-gate 732*0Sstevel@tonic-gate=begin _unimplemented 733*0Sstevel@tonic-gate 734*0Sstevel@tonic-gate=item B<skip_rest> 735*0Sstevel@tonic-gate 736*0Sstevel@tonic-gate $Test->skip_rest; 737*0Sstevel@tonic-gate $Test->skip_rest($reason); 738*0Sstevel@tonic-gate 739*0Sstevel@tonic-gateLike skip(), only it skips all the rest of the tests you plan to run 740*0Sstevel@tonic-gateand terminates the test. 741*0Sstevel@tonic-gate 742*0Sstevel@tonic-gateIf you're running under no_plan, it skips once and terminates the 743*0Sstevel@tonic-gatetest. 744*0Sstevel@tonic-gate 745*0Sstevel@tonic-gate=end _unimplemented 746*0Sstevel@tonic-gate 747*0Sstevel@tonic-gate=back 748*0Sstevel@tonic-gate 749*0Sstevel@tonic-gate 750*0Sstevel@tonic-gate=head2 Test style 751*0Sstevel@tonic-gate 752*0Sstevel@tonic-gate=over 4 753*0Sstevel@tonic-gate 754*0Sstevel@tonic-gate=item B<level> 755*0Sstevel@tonic-gate 756*0Sstevel@tonic-gate $Test->level($how_high); 757*0Sstevel@tonic-gate 758*0Sstevel@tonic-gateHow far up the call stack should $Test look when reporting where the 759*0Sstevel@tonic-gatetest failed. 760*0Sstevel@tonic-gate 761*0Sstevel@tonic-gateDefaults to 1. 762*0Sstevel@tonic-gate 763*0Sstevel@tonic-gateSetting $Test::Builder::Level overrides. This is typically useful 764*0Sstevel@tonic-gatelocalized: 765*0Sstevel@tonic-gate 766*0Sstevel@tonic-gate { 767*0Sstevel@tonic-gate local $Test::Builder::Level = 2; 768*0Sstevel@tonic-gate $Test->ok($test); 769*0Sstevel@tonic-gate } 770*0Sstevel@tonic-gate 771*0Sstevel@tonic-gate=cut 772*0Sstevel@tonic-gate 773*0Sstevel@tonic-gatesub level { 774*0Sstevel@tonic-gate my($self, $level) = @_; 775*0Sstevel@tonic-gate 776*0Sstevel@tonic-gate if( defined $level ) { 777*0Sstevel@tonic-gate $Level = $level; 778*0Sstevel@tonic-gate } 779*0Sstevel@tonic-gate return $Level; 780*0Sstevel@tonic-gate} 781*0Sstevel@tonic-gate 782*0Sstevel@tonic-gate$CLASS->level(1); 783*0Sstevel@tonic-gate 784*0Sstevel@tonic-gate 785*0Sstevel@tonic-gate=item B<use_numbers> 786*0Sstevel@tonic-gate 787*0Sstevel@tonic-gate $Test->use_numbers($on_or_off); 788*0Sstevel@tonic-gate 789*0Sstevel@tonic-gateWhether or not the test should output numbers. That is, this if true: 790*0Sstevel@tonic-gate 791*0Sstevel@tonic-gate ok 1 792*0Sstevel@tonic-gate ok 2 793*0Sstevel@tonic-gate ok 3 794*0Sstevel@tonic-gate 795*0Sstevel@tonic-gateor this if false 796*0Sstevel@tonic-gate 797*0Sstevel@tonic-gate ok 798*0Sstevel@tonic-gate ok 799*0Sstevel@tonic-gate ok 800*0Sstevel@tonic-gate 801*0Sstevel@tonic-gateMost useful when you can't depend on the test output order, such as 802*0Sstevel@tonic-gatewhen threads or forking is involved. 803*0Sstevel@tonic-gate 804*0Sstevel@tonic-gateTest::Harness will accept either, but avoid mixing the two styles. 805*0Sstevel@tonic-gate 806*0Sstevel@tonic-gateDefaults to on. 807*0Sstevel@tonic-gate 808*0Sstevel@tonic-gate=cut 809*0Sstevel@tonic-gate 810*0Sstevel@tonic-gatemy $Use_Nums = 1; 811*0Sstevel@tonic-gatesub use_numbers { 812*0Sstevel@tonic-gate my($self, $use_nums) = @_; 813*0Sstevel@tonic-gate 814*0Sstevel@tonic-gate if( defined $use_nums ) { 815*0Sstevel@tonic-gate $Use_Nums = $use_nums; 816*0Sstevel@tonic-gate } 817*0Sstevel@tonic-gate return $Use_Nums; 818*0Sstevel@tonic-gate} 819*0Sstevel@tonic-gate 820*0Sstevel@tonic-gate=item B<no_header> 821*0Sstevel@tonic-gate 822*0Sstevel@tonic-gate $Test->no_header($no_header); 823*0Sstevel@tonic-gate 824*0Sstevel@tonic-gateIf set to true, no "1..N" header will be printed. 825*0Sstevel@tonic-gate 826*0Sstevel@tonic-gate=item B<no_ending> 827*0Sstevel@tonic-gate 828*0Sstevel@tonic-gate $Test->no_ending($no_ending); 829*0Sstevel@tonic-gate 830*0Sstevel@tonic-gateNormally, Test::Builder does some extra diagnostics when the test 831*0Sstevel@tonic-gateends. It also changes the exit code as described in Test::Simple. 832*0Sstevel@tonic-gate 833*0Sstevel@tonic-gateIf this is true, none of that will be done. 834*0Sstevel@tonic-gate 835*0Sstevel@tonic-gate=cut 836*0Sstevel@tonic-gate 837*0Sstevel@tonic-gatemy($No_Header, $No_Ending) = (0,0); 838*0Sstevel@tonic-gatesub no_header { 839*0Sstevel@tonic-gate my($self, $no_header) = @_; 840*0Sstevel@tonic-gate 841*0Sstevel@tonic-gate if( defined $no_header ) { 842*0Sstevel@tonic-gate $No_Header = $no_header; 843*0Sstevel@tonic-gate } 844*0Sstevel@tonic-gate return $No_Header; 845*0Sstevel@tonic-gate} 846*0Sstevel@tonic-gate 847*0Sstevel@tonic-gatesub no_ending { 848*0Sstevel@tonic-gate my($self, $no_ending) = @_; 849*0Sstevel@tonic-gate 850*0Sstevel@tonic-gate if( defined $no_ending ) { 851*0Sstevel@tonic-gate $No_Ending = $no_ending; 852*0Sstevel@tonic-gate } 853*0Sstevel@tonic-gate return $No_Ending; 854*0Sstevel@tonic-gate} 855*0Sstevel@tonic-gate 856*0Sstevel@tonic-gate 857*0Sstevel@tonic-gate=back 858*0Sstevel@tonic-gate 859*0Sstevel@tonic-gate=head2 Output 860*0Sstevel@tonic-gate 861*0Sstevel@tonic-gateControlling where the test output goes. 862*0Sstevel@tonic-gate 863*0Sstevel@tonic-gateIt's ok for your test to change where STDOUT and STDERR point to, 864*0Sstevel@tonic-gateTest::Builder's default output settings will not be affected. 865*0Sstevel@tonic-gate 866*0Sstevel@tonic-gate=over 4 867*0Sstevel@tonic-gate 868*0Sstevel@tonic-gate=item B<diag> 869*0Sstevel@tonic-gate 870*0Sstevel@tonic-gate $Test->diag(@msgs); 871*0Sstevel@tonic-gate 872*0Sstevel@tonic-gatePrints out the given $message. Normally, it uses the failure_output() 873*0Sstevel@tonic-gatehandle, but if this is for a TODO test, the todo_output() handle is 874*0Sstevel@tonic-gateused. 875*0Sstevel@tonic-gate 876*0Sstevel@tonic-gateOutput will be indented and marked with a # so as not to interfere 877*0Sstevel@tonic-gatewith test output. A newline will be put on the end if there isn't one 878*0Sstevel@tonic-gatealready. 879*0Sstevel@tonic-gate 880*0Sstevel@tonic-gateWe encourage using this rather than calling print directly. 881*0Sstevel@tonic-gate 882*0Sstevel@tonic-gateReturns false. Why? Because diag() is often used in conjunction with 883*0Sstevel@tonic-gatea failing test (C<ok() || diag()>) it "passes through" the failure. 884*0Sstevel@tonic-gate 885*0Sstevel@tonic-gate return ok(...) || diag(...); 886*0Sstevel@tonic-gate 887*0Sstevel@tonic-gate=for blame transfer 888*0Sstevel@tonic-gateMark Fowler <mark@twoshortplanks.com> 889*0Sstevel@tonic-gate 890*0Sstevel@tonic-gate=cut 891*0Sstevel@tonic-gate 892*0Sstevel@tonic-gatesub diag { 893*0Sstevel@tonic-gate my($self, @msgs) = @_; 894*0Sstevel@tonic-gate return unless @msgs; 895*0Sstevel@tonic-gate 896*0Sstevel@tonic-gate # Prevent printing headers when compiling (i.e. -c) 897*0Sstevel@tonic-gate return if $^C; 898*0Sstevel@tonic-gate 899*0Sstevel@tonic-gate # Escape each line with a #. 900*0Sstevel@tonic-gate foreach (@msgs) { 901*0Sstevel@tonic-gate $_ = 'undef' unless defined; 902*0Sstevel@tonic-gate s/^/# /gms; 903*0Sstevel@tonic-gate } 904*0Sstevel@tonic-gate 905*0Sstevel@tonic-gate push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; 906*0Sstevel@tonic-gate 907*0Sstevel@tonic-gate local $Level = $Level + 1; 908*0Sstevel@tonic-gate my $fh = $self->todo ? $self->todo_output : $self->failure_output; 909*0Sstevel@tonic-gate local($\, $", $,) = (undef, ' ', ''); 910*0Sstevel@tonic-gate print $fh @msgs; 911*0Sstevel@tonic-gate 912*0Sstevel@tonic-gate return 0; 913*0Sstevel@tonic-gate} 914*0Sstevel@tonic-gate 915*0Sstevel@tonic-gate=begin _private 916*0Sstevel@tonic-gate 917*0Sstevel@tonic-gate=item B<_print> 918*0Sstevel@tonic-gate 919*0Sstevel@tonic-gate $Test->_print(@msgs); 920*0Sstevel@tonic-gate 921*0Sstevel@tonic-gatePrints to the output() filehandle. 922*0Sstevel@tonic-gate 923*0Sstevel@tonic-gate=end _private 924*0Sstevel@tonic-gate 925*0Sstevel@tonic-gate=cut 926*0Sstevel@tonic-gate 927*0Sstevel@tonic-gatesub _print { 928*0Sstevel@tonic-gate my($self, @msgs) = @_; 929*0Sstevel@tonic-gate 930*0Sstevel@tonic-gate # Prevent printing headers when only compiling. Mostly for when 931*0Sstevel@tonic-gate # tests are deparsed with B::Deparse 932*0Sstevel@tonic-gate return if $^C; 933*0Sstevel@tonic-gate 934*0Sstevel@tonic-gate local($\, $", $,) = (undef, ' ', ''); 935*0Sstevel@tonic-gate my $fh = $self->output; 936*0Sstevel@tonic-gate 937*0Sstevel@tonic-gate # Escape each line after the first with a # so we don't 938*0Sstevel@tonic-gate # confuse Test::Harness. 939*0Sstevel@tonic-gate foreach (@msgs) { 940*0Sstevel@tonic-gate s/\n(.)/\n# $1/sg; 941*0Sstevel@tonic-gate } 942*0Sstevel@tonic-gate 943*0Sstevel@tonic-gate push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/; 944*0Sstevel@tonic-gate 945*0Sstevel@tonic-gate print $fh @msgs; 946*0Sstevel@tonic-gate} 947*0Sstevel@tonic-gate 948*0Sstevel@tonic-gate 949*0Sstevel@tonic-gate=item B<output> 950*0Sstevel@tonic-gate 951*0Sstevel@tonic-gate $Test->output($fh); 952*0Sstevel@tonic-gate $Test->output($file); 953*0Sstevel@tonic-gate 954*0Sstevel@tonic-gateWhere normal "ok/not ok" test output should go. 955*0Sstevel@tonic-gate 956*0Sstevel@tonic-gateDefaults to STDOUT. 957*0Sstevel@tonic-gate 958*0Sstevel@tonic-gate=item B<failure_output> 959*0Sstevel@tonic-gate 960*0Sstevel@tonic-gate $Test->failure_output($fh); 961*0Sstevel@tonic-gate $Test->failure_output($file); 962*0Sstevel@tonic-gate 963*0Sstevel@tonic-gateWhere diagnostic output on test failures and diag() should go. 964*0Sstevel@tonic-gate 965*0Sstevel@tonic-gateDefaults to STDERR. 966*0Sstevel@tonic-gate 967*0Sstevel@tonic-gate=item B<todo_output> 968*0Sstevel@tonic-gate 969*0Sstevel@tonic-gate $Test->todo_output($fh); 970*0Sstevel@tonic-gate $Test->todo_output($file); 971*0Sstevel@tonic-gate 972*0Sstevel@tonic-gateWhere diagnostics about todo test failures and diag() should go. 973*0Sstevel@tonic-gate 974*0Sstevel@tonic-gateDefaults to STDOUT. 975*0Sstevel@tonic-gate 976*0Sstevel@tonic-gate=cut 977*0Sstevel@tonic-gate 978*0Sstevel@tonic-gatemy($Out_FH, $Fail_FH, $Todo_FH); 979*0Sstevel@tonic-gatesub output { 980*0Sstevel@tonic-gate my($self, $fh) = @_; 981*0Sstevel@tonic-gate 982*0Sstevel@tonic-gate if( defined $fh ) { 983*0Sstevel@tonic-gate $Out_FH = _new_fh($fh); 984*0Sstevel@tonic-gate } 985*0Sstevel@tonic-gate return $Out_FH; 986*0Sstevel@tonic-gate} 987*0Sstevel@tonic-gate 988*0Sstevel@tonic-gatesub failure_output { 989*0Sstevel@tonic-gate my($self, $fh) = @_; 990*0Sstevel@tonic-gate 991*0Sstevel@tonic-gate if( defined $fh ) { 992*0Sstevel@tonic-gate $Fail_FH = _new_fh($fh); 993*0Sstevel@tonic-gate } 994*0Sstevel@tonic-gate return $Fail_FH; 995*0Sstevel@tonic-gate} 996*0Sstevel@tonic-gate 997*0Sstevel@tonic-gatesub todo_output { 998*0Sstevel@tonic-gate my($self, $fh) = @_; 999*0Sstevel@tonic-gate 1000*0Sstevel@tonic-gate if( defined $fh ) { 1001*0Sstevel@tonic-gate $Todo_FH = _new_fh($fh); 1002*0Sstevel@tonic-gate } 1003*0Sstevel@tonic-gate return $Todo_FH; 1004*0Sstevel@tonic-gate} 1005*0Sstevel@tonic-gate 1006*0Sstevel@tonic-gatesub _new_fh { 1007*0Sstevel@tonic-gate my($file_or_fh) = shift; 1008*0Sstevel@tonic-gate 1009*0Sstevel@tonic-gate my $fh; 1010*0Sstevel@tonic-gate unless( UNIVERSAL::isa($file_or_fh, 'GLOB') ) { 1011*0Sstevel@tonic-gate $fh = do { local *FH }; 1012*0Sstevel@tonic-gate open $fh, ">$file_or_fh" or 1013*0Sstevel@tonic-gate die "Can't open test output log $file_or_fh: $!"; 1014*0Sstevel@tonic-gate } 1015*0Sstevel@tonic-gate else { 1016*0Sstevel@tonic-gate $fh = $file_or_fh; 1017*0Sstevel@tonic-gate } 1018*0Sstevel@tonic-gate 1019*0Sstevel@tonic-gate return $fh; 1020*0Sstevel@tonic-gate} 1021*0Sstevel@tonic-gate 1022*0Sstevel@tonic-gateunless( $^C ) { 1023*0Sstevel@tonic-gate # We dup STDOUT and STDERR so people can change them in their 1024*0Sstevel@tonic-gate # test suites while still getting normal test output. 1025*0Sstevel@tonic-gate open(TESTOUT, ">&STDOUT") or die "Can't dup STDOUT: $!"; 1026*0Sstevel@tonic-gate open(TESTERR, ">&STDERR") or die "Can't dup STDERR: $!"; 1027*0Sstevel@tonic-gate 1028*0Sstevel@tonic-gate # Set everything to unbuffered else plain prints to STDOUT will 1029*0Sstevel@tonic-gate # come out in the wrong order from our own prints. 1030*0Sstevel@tonic-gate _autoflush(\*TESTOUT); 1031*0Sstevel@tonic-gate _autoflush(\*STDOUT); 1032*0Sstevel@tonic-gate _autoflush(\*TESTERR); 1033*0Sstevel@tonic-gate _autoflush(\*STDERR); 1034*0Sstevel@tonic-gate 1035*0Sstevel@tonic-gate $CLASS->output(\*TESTOUT); 1036*0Sstevel@tonic-gate $CLASS->failure_output(\*TESTERR); 1037*0Sstevel@tonic-gate $CLASS->todo_output(\*TESTOUT); 1038*0Sstevel@tonic-gate} 1039*0Sstevel@tonic-gate 1040*0Sstevel@tonic-gatesub _autoflush { 1041*0Sstevel@tonic-gate my($fh) = shift; 1042*0Sstevel@tonic-gate my $old_fh = select $fh; 1043*0Sstevel@tonic-gate $| = 1; 1044*0Sstevel@tonic-gate select $old_fh; 1045*0Sstevel@tonic-gate} 1046*0Sstevel@tonic-gate 1047*0Sstevel@tonic-gate 1048*0Sstevel@tonic-gate=back 1049*0Sstevel@tonic-gate 1050*0Sstevel@tonic-gate 1051*0Sstevel@tonic-gate=head2 Test Status and Info 1052*0Sstevel@tonic-gate 1053*0Sstevel@tonic-gate=over 4 1054*0Sstevel@tonic-gate 1055*0Sstevel@tonic-gate=item B<current_test> 1056*0Sstevel@tonic-gate 1057*0Sstevel@tonic-gate my $curr_test = $Test->current_test; 1058*0Sstevel@tonic-gate $Test->current_test($num); 1059*0Sstevel@tonic-gate 1060*0Sstevel@tonic-gateGets/sets the current test # we're on. 1061*0Sstevel@tonic-gate 1062*0Sstevel@tonic-gateYou usually shouldn't have to set this. 1063*0Sstevel@tonic-gate 1064*0Sstevel@tonic-gate=cut 1065*0Sstevel@tonic-gate 1066*0Sstevel@tonic-gatesub current_test { 1067*0Sstevel@tonic-gate my($self, $num) = @_; 1068*0Sstevel@tonic-gate 1069*0Sstevel@tonic-gate lock($Curr_Test); 1070*0Sstevel@tonic-gate if( defined $num ) { 1071*0Sstevel@tonic-gate unless( $Have_Plan ) { 1072*0Sstevel@tonic-gate require Carp; 1073*0Sstevel@tonic-gate Carp::croak("Can't change the current test number without a plan!"); 1074*0Sstevel@tonic-gate } 1075*0Sstevel@tonic-gate 1076*0Sstevel@tonic-gate $Curr_Test = $num; 1077*0Sstevel@tonic-gate if( $num > @Test_Results ) { 1078*0Sstevel@tonic-gate my $start = @Test_Results ? $#Test_Results + 1 : 0; 1079*0Sstevel@tonic-gate for ($start..$num-1) { 1080*0Sstevel@tonic-gate my %result; 1081*0Sstevel@tonic-gate share(%result); 1082*0Sstevel@tonic-gate %result = ( ok => 1, 1083*0Sstevel@tonic-gate actual_ok => undef, 1084*0Sstevel@tonic-gate reason => 'incrementing test number', 1085*0Sstevel@tonic-gate type => 'unknown', 1086*0Sstevel@tonic-gate name => undef 1087*0Sstevel@tonic-gate ); 1088*0Sstevel@tonic-gate $Test_Results[$_] = \%result; 1089*0Sstevel@tonic-gate } 1090*0Sstevel@tonic-gate } 1091*0Sstevel@tonic-gate } 1092*0Sstevel@tonic-gate return $Curr_Test; 1093*0Sstevel@tonic-gate} 1094*0Sstevel@tonic-gate 1095*0Sstevel@tonic-gate 1096*0Sstevel@tonic-gate=item B<summary> 1097*0Sstevel@tonic-gate 1098*0Sstevel@tonic-gate my @tests = $Test->summary; 1099*0Sstevel@tonic-gate 1100*0Sstevel@tonic-gateA simple summary of the tests so far. True for pass, false for fail. 1101*0Sstevel@tonic-gateThis is a logical pass/fail, so todos are passes. 1102*0Sstevel@tonic-gate 1103*0Sstevel@tonic-gateOf course, test #1 is $tests[0], etc... 1104*0Sstevel@tonic-gate 1105*0Sstevel@tonic-gate=cut 1106*0Sstevel@tonic-gate 1107*0Sstevel@tonic-gatesub summary { 1108*0Sstevel@tonic-gate my($self) = shift; 1109*0Sstevel@tonic-gate 1110*0Sstevel@tonic-gate return map { $_->{'ok'} } @Test_Results; 1111*0Sstevel@tonic-gate} 1112*0Sstevel@tonic-gate 1113*0Sstevel@tonic-gate=item B<details> 1114*0Sstevel@tonic-gate 1115*0Sstevel@tonic-gate my @tests = $Test->details; 1116*0Sstevel@tonic-gate 1117*0Sstevel@tonic-gateLike summary(), but with a lot more detail. 1118*0Sstevel@tonic-gate 1119*0Sstevel@tonic-gate $tests[$test_num - 1] = 1120*0Sstevel@tonic-gate { 'ok' => is the test considered a pass? 1121*0Sstevel@tonic-gate actual_ok => did it literally say 'ok'? 1122*0Sstevel@tonic-gate name => name of the test (if any) 1123*0Sstevel@tonic-gate type => type of test (if any, see below). 1124*0Sstevel@tonic-gate reason => reason for the above (if any) 1125*0Sstevel@tonic-gate }; 1126*0Sstevel@tonic-gate 1127*0Sstevel@tonic-gate'ok' is true if Test::Harness will consider the test to be a pass. 1128*0Sstevel@tonic-gate 1129*0Sstevel@tonic-gate'actual_ok' is a reflection of whether or not the test literally 1130*0Sstevel@tonic-gateprinted 'ok' or 'not ok'. This is for examining the result of 'todo' 1131*0Sstevel@tonic-gatetests. 1132*0Sstevel@tonic-gate 1133*0Sstevel@tonic-gate'name' is the name of the test. 1134*0Sstevel@tonic-gate 1135*0Sstevel@tonic-gate'type' indicates if it was a special test. Normal tests have a type 1136*0Sstevel@tonic-gateof ''. Type can be one of the following: 1137*0Sstevel@tonic-gate 1138*0Sstevel@tonic-gate skip see skip() 1139*0Sstevel@tonic-gate todo see todo() 1140*0Sstevel@tonic-gate todo_skip see todo_skip() 1141*0Sstevel@tonic-gate unknown see below 1142*0Sstevel@tonic-gate 1143*0Sstevel@tonic-gateSometimes the Test::Builder test counter is incremented without it 1144*0Sstevel@tonic-gateprinting any test output, for example, when current_test() is changed. 1145*0Sstevel@tonic-gateIn these cases, Test::Builder doesn't know the result of the test, so 1146*0Sstevel@tonic-gateit's type is 'unkown'. These details for these tests are filled in. 1147*0Sstevel@tonic-gateThey are considered ok, but the name and actual_ok is left undef. 1148*0Sstevel@tonic-gate 1149*0Sstevel@tonic-gateFor example "not ok 23 - hole count # TODO insufficient donuts" would 1150*0Sstevel@tonic-gateresult in this structure: 1151*0Sstevel@tonic-gate 1152*0Sstevel@tonic-gate $tests[22] = # 23 - 1, since arrays start from 0. 1153*0Sstevel@tonic-gate { ok => 1, # logically, the test passed since it's todo 1154*0Sstevel@tonic-gate actual_ok => 0, # in absolute terms, it failed 1155*0Sstevel@tonic-gate name => 'hole count', 1156*0Sstevel@tonic-gate type => 'todo', 1157*0Sstevel@tonic-gate reason => 'insufficient donuts' 1158*0Sstevel@tonic-gate }; 1159*0Sstevel@tonic-gate 1160*0Sstevel@tonic-gate=cut 1161*0Sstevel@tonic-gate 1162*0Sstevel@tonic-gatesub details { 1163*0Sstevel@tonic-gate return @Test_Results; 1164*0Sstevel@tonic-gate} 1165*0Sstevel@tonic-gate 1166*0Sstevel@tonic-gate=item B<todo> 1167*0Sstevel@tonic-gate 1168*0Sstevel@tonic-gate my $todo_reason = $Test->todo; 1169*0Sstevel@tonic-gate my $todo_reason = $Test->todo($pack); 1170*0Sstevel@tonic-gate 1171*0Sstevel@tonic-gatetodo() looks for a $TODO variable in your tests. If set, all tests 1172*0Sstevel@tonic-gatewill be considered 'todo' (see Test::More and Test::Harness for 1173*0Sstevel@tonic-gatedetails). Returns the reason (ie. the value of $TODO) if running as 1174*0Sstevel@tonic-gatetodo tests, false otherwise. 1175*0Sstevel@tonic-gate 1176*0Sstevel@tonic-gatetodo() is pretty part about finding the right package to look for 1177*0Sstevel@tonic-gate$TODO in. It uses the exported_to() package to find it. If that's 1178*0Sstevel@tonic-gatenot set, it's pretty good at guessing the right package to look at. 1179*0Sstevel@tonic-gate 1180*0Sstevel@tonic-gateSometimes there is some confusion about where todo() should be looking 1181*0Sstevel@tonic-gatefor the $TODO variable. If you want to be sure, tell it explicitly 1182*0Sstevel@tonic-gatewhat $pack to use. 1183*0Sstevel@tonic-gate 1184*0Sstevel@tonic-gate=cut 1185*0Sstevel@tonic-gate 1186*0Sstevel@tonic-gatesub todo { 1187*0Sstevel@tonic-gate my($self, $pack) = @_; 1188*0Sstevel@tonic-gate 1189*0Sstevel@tonic-gate $pack = $pack || $self->exported_to || $self->caller(1); 1190*0Sstevel@tonic-gate 1191*0Sstevel@tonic-gate no strict 'refs'; 1192*0Sstevel@tonic-gate return defined ${$pack.'::TODO'} ? ${$pack.'::TODO'} 1193*0Sstevel@tonic-gate : 0; 1194*0Sstevel@tonic-gate} 1195*0Sstevel@tonic-gate 1196*0Sstevel@tonic-gate=item B<caller> 1197*0Sstevel@tonic-gate 1198*0Sstevel@tonic-gate my $package = $Test->caller; 1199*0Sstevel@tonic-gate my($pack, $file, $line) = $Test->caller; 1200*0Sstevel@tonic-gate my($pack, $file, $line) = $Test->caller($height); 1201*0Sstevel@tonic-gate 1202*0Sstevel@tonic-gateLike the normal caller(), except it reports according to your level(). 1203*0Sstevel@tonic-gate 1204*0Sstevel@tonic-gate=cut 1205*0Sstevel@tonic-gate 1206*0Sstevel@tonic-gatesub caller { 1207*0Sstevel@tonic-gate my($self, $height) = @_; 1208*0Sstevel@tonic-gate $height ||= 0; 1209*0Sstevel@tonic-gate 1210*0Sstevel@tonic-gate my @caller = CORE::caller($self->level + $height + 1); 1211*0Sstevel@tonic-gate return wantarray ? @caller : $caller[0]; 1212*0Sstevel@tonic-gate} 1213*0Sstevel@tonic-gate 1214*0Sstevel@tonic-gate=back 1215*0Sstevel@tonic-gate 1216*0Sstevel@tonic-gate=cut 1217*0Sstevel@tonic-gate 1218*0Sstevel@tonic-gate=begin _private 1219*0Sstevel@tonic-gate 1220*0Sstevel@tonic-gate=over 4 1221*0Sstevel@tonic-gate 1222*0Sstevel@tonic-gate=item B<_sanity_check> 1223*0Sstevel@tonic-gate 1224*0Sstevel@tonic-gate _sanity_check(); 1225*0Sstevel@tonic-gate 1226*0Sstevel@tonic-gateRuns a bunch of end of test sanity checks to make sure reality came 1227*0Sstevel@tonic-gatethrough ok. If anything is wrong it will die with a fairly friendly 1228*0Sstevel@tonic-gateerror message. 1229*0Sstevel@tonic-gate 1230*0Sstevel@tonic-gate=cut 1231*0Sstevel@tonic-gate 1232*0Sstevel@tonic-gate#'# 1233*0Sstevel@tonic-gatesub _sanity_check { 1234*0Sstevel@tonic-gate _whoa($Curr_Test < 0, 'Says here you ran a negative number of tests!'); 1235*0Sstevel@tonic-gate _whoa(!$Have_Plan and $Curr_Test, 1236*0Sstevel@tonic-gate 'Somehow your tests ran without a plan!'); 1237*0Sstevel@tonic-gate _whoa($Curr_Test != @Test_Results, 1238*0Sstevel@tonic-gate 'Somehow you got a different number of results than tests ran!'); 1239*0Sstevel@tonic-gate} 1240*0Sstevel@tonic-gate 1241*0Sstevel@tonic-gate=item B<_whoa> 1242*0Sstevel@tonic-gate 1243*0Sstevel@tonic-gate _whoa($check, $description); 1244*0Sstevel@tonic-gate 1245*0Sstevel@tonic-gateA sanity check, similar to assert(). If the $check is true, something 1246*0Sstevel@tonic-gatehas gone horribly wrong. It will die with the given $description and 1247*0Sstevel@tonic-gatea note to contact the author. 1248*0Sstevel@tonic-gate 1249*0Sstevel@tonic-gate=cut 1250*0Sstevel@tonic-gate 1251*0Sstevel@tonic-gatesub _whoa { 1252*0Sstevel@tonic-gate my($check, $desc) = @_; 1253*0Sstevel@tonic-gate if( $check ) { 1254*0Sstevel@tonic-gate die <<WHOA; 1255*0Sstevel@tonic-gateWHOA! $desc 1256*0Sstevel@tonic-gateThis should never happen! Please contact the author immediately! 1257*0Sstevel@tonic-gateWHOA 1258*0Sstevel@tonic-gate } 1259*0Sstevel@tonic-gate} 1260*0Sstevel@tonic-gate 1261*0Sstevel@tonic-gate=item B<_my_exit> 1262*0Sstevel@tonic-gate 1263*0Sstevel@tonic-gate _my_exit($exit_num); 1264*0Sstevel@tonic-gate 1265*0Sstevel@tonic-gatePerl seems to have some trouble with exiting inside an END block. 5.005_03 1266*0Sstevel@tonic-gateand 5.6.1 both seem to do odd things. Instead, this function edits $? 1267*0Sstevel@tonic-gatedirectly. It should ONLY be called from inside an END block. It 1268*0Sstevel@tonic-gatedoesn't actually exit, that's your job. 1269*0Sstevel@tonic-gate 1270*0Sstevel@tonic-gate=cut 1271*0Sstevel@tonic-gate 1272*0Sstevel@tonic-gatesub _my_exit { 1273*0Sstevel@tonic-gate $? = $_[0]; 1274*0Sstevel@tonic-gate 1275*0Sstevel@tonic-gate return 1; 1276*0Sstevel@tonic-gate} 1277*0Sstevel@tonic-gate 1278*0Sstevel@tonic-gate 1279*0Sstevel@tonic-gate=back 1280*0Sstevel@tonic-gate 1281*0Sstevel@tonic-gate=end _private 1282*0Sstevel@tonic-gate 1283*0Sstevel@tonic-gate=cut 1284*0Sstevel@tonic-gate 1285*0Sstevel@tonic-gate$SIG{__DIE__} = sub { 1286*0Sstevel@tonic-gate # We don't want to muck with death in an eval, but $^S isn't 1287*0Sstevel@tonic-gate # totally reliable. 5.005_03 and 5.6.1 both do the wrong thing 1288*0Sstevel@tonic-gate # with it. Instead, we use caller. This also means it runs under 1289*0Sstevel@tonic-gate # 5.004! 1290*0Sstevel@tonic-gate my $in_eval = 0; 1291*0Sstevel@tonic-gate for( my $stack = 1; my $sub = (CORE::caller($stack))[3]; $stack++ ) { 1292*0Sstevel@tonic-gate $in_eval = 1 if $sub =~ /^\(eval\)/; 1293*0Sstevel@tonic-gate } 1294*0Sstevel@tonic-gate $Test_Died = 1 unless $in_eval; 1295*0Sstevel@tonic-gate}; 1296*0Sstevel@tonic-gate 1297*0Sstevel@tonic-gatesub _ending { 1298*0Sstevel@tonic-gate my $self = shift; 1299*0Sstevel@tonic-gate 1300*0Sstevel@tonic-gate _sanity_check(); 1301*0Sstevel@tonic-gate 1302*0Sstevel@tonic-gate # Don't bother with an ending if this is a forked copy. Only the parent 1303*0Sstevel@tonic-gate # should do the ending. 1304*0Sstevel@tonic-gate do{ _my_exit($?) && return } if $Original_Pid != $$; 1305*0Sstevel@tonic-gate 1306*0Sstevel@tonic-gate # Bailout if plan() was never called. This is so 1307*0Sstevel@tonic-gate # "require Test::Simple" doesn't puke. 1308*0Sstevel@tonic-gate do{ _my_exit(0) && return } if !$Have_Plan && !$Test_Died; 1309*0Sstevel@tonic-gate 1310*0Sstevel@tonic-gate # Figure out if we passed or failed and print helpful messages. 1311*0Sstevel@tonic-gate if( @Test_Results ) { 1312*0Sstevel@tonic-gate # The plan? We have no plan. 1313*0Sstevel@tonic-gate if( $No_Plan ) { 1314*0Sstevel@tonic-gate $self->_print("1..$Curr_Test\n") unless $self->no_header; 1315*0Sstevel@tonic-gate $Expected_Tests = $Curr_Test; 1316*0Sstevel@tonic-gate } 1317*0Sstevel@tonic-gate 1318*0Sstevel@tonic-gate # 5.8.0 threads bug. Shared arrays will not be auto-extended 1319*0Sstevel@tonic-gate # by a slice. Worse, we have to fill in every entry else 1320*0Sstevel@tonic-gate # we'll get an "Invalid value for shared scalar" error 1321*0Sstevel@tonic-gate for my $idx ($#Test_Results..$Expected_Tests-1) { 1322*0Sstevel@tonic-gate my %empty_result = (); 1323*0Sstevel@tonic-gate share(%empty_result); 1324*0Sstevel@tonic-gate $Test_Results[$idx] = \%empty_result 1325*0Sstevel@tonic-gate unless defined $Test_Results[$idx]; 1326*0Sstevel@tonic-gate } 1327*0Sstevel@tonic-gate 1328*0Sstevel@tonic-gate my $num_failed = grep !$_->{'ok'}, @Test_Results[0..$Expected_Tests-1]; 1329*0Sstevel@tonic-gate $num_failed += abs($Expected_Tests - @Test_Results); 1330*0Sstevel@tonic-gate 1331*0Sstevel@tonic-gate if( $Curr_Test < $Expected_Tests ) { 1332*0Sstevel@tonic-gate $self->diag(<<"FAIL"); 1333*0Sstevel@tonic-gateLooks like you planned $Expected_Tests tests but only ran $Curr_Test. 1334*0Sstevel@tonic-gateFAIL 1335*0Sstevel@tonic-gate } 1336*0Sstevel@tonic-gate elsif( $Curr_Test > $Expected_Tests ) { 1337*0Sstevel@tonic-gate my $num_extra = $Curr_Test - $Expected_Tests; 1338*0Sstevel@tonic-gate $self->diag(<<"FAIL"); 1339*0Sstevel@tonic-gateLooks like you planned $Expected_Tests tests but ran $num_extra extra. 1340*0Sstevel@tonic-gateFAIL 1341*0Sstevel@tonic-gate } 1342*0Sstevel@tonic-gate elsif ( $num_failed ) { 1343*0Sstevel@tonic-gate $self->diag(<<"FAIL"); 1344*0Sstevel@tonic-gateLooks like you failed $num_failed tests of $Expected_Tests. 1345*0Sstevel@tonic-gateFAIL 1346*0Sstevel@tonic-gate } 1347*0Sstevel@tonic-gate 1348*0Sstevel@tonic-gate if( $Test_Died ) { 1349*0Sstevel@tonic-gate $self->diag(<<"FAIL"); 1350*0Sstevel@tonic-gateLooks like your test died just after $Curr_Test. 1351*0Sstevel@tonic-gateFAIL 1352*0Sstevel@tonic-gate 1353*0Sstevel@tonic-gate _my_exit( 255 ) && return; 1354*0Sstevel@tonic-gate } 1355*0Sstevel@tonic-gate 1356*0Sstevel@tonic-gate _my_exit( $num_failed <= 254 ? $num_failed : 254 ) && return; 1357*0Sstevel@tonic-gate } 1358*0Sstevel@tonic-gate elsif ( $Skip_All ) { 1359*0Sstevel@tonic-gate _my_exit( 0 ) && return; 1360*0Sstevel@tonic-gate } 1361*0Sstevel@tonic-gate elsif ( $Test_Died ) { 1362*0Sstevel@tonic-gate $self->diag(<<'FAIL'); 1363*0Sstevel@tonic-gateLooks like your test died before it could output anything. 1364*0Sstevel@tonic-gateFAIL 1365*0Sstevel@tonic-gate } 1366*0Sstevel@tonic-gate else { 1367*0Sstevel@tonic-gate $self->diag("No tests run!\n"); 1368*0Sstevel@tonic-gate _my_exit( 255 ) && return; 1369*0Sstevel@tonic-gate } 1370*0Sstevel@tonic-gate} 1371*0Sstevel@tonic-gate 1372*0Sstevel@tonic-gateEND { 1373*0Sstevel@tonic-gate $Test->_ending if defined $Test and !$Test->no_ending; 1374*0Sstevel@tonic-gate} 1375*0Sstevel@tonic-gate 1376*0Sstevel@tonic-gate=head1 THREADS 1377*0Sstevel@tonic-gate 1378*0Sstevel@tonic-gateIn perl 5.8.0 and later, Test::Builder is thread-safe. The test 1379*0Sstevel@tonic-gatenumber is shared amongst all threads. This means if one thread sets 1380*0Sstevel@tonic-gatethe test number using current_test() they will all be effected. 1381*0Sstevel@tonic-gate 1382*0Sstevel@tonic-gate=head1 EXAMPLES 1383*0Sstevel@tonic-gate 1384*0Sstevel@tonic-gateCPAN can provide the best examples. Test::Simple, Test::More, 1385*0Sstevel@tonic-gateTest::Exception and Test::Differences all use Test::Builder. 1386*0Sstevel@tonic-gate 1387*0Sstevel@tonic-gate=head1 SEE ALSO 1388*0Sstevel@tonic-gate 1389*0Sstevel@tonic-gateTest::Simple, Test::More, Test::Harness 1390*0Sstevel@tonic-gate 1391*0Sstevel@tonic-gate=head1 AUTHORS 1392*0Sstevel@tonic-gate 1393*0Sstevel@tonic-gateOriginal code by chromatic, maintained by Michael G Schwern 1394*0Sstevel@tonic-gateE<lt>schwern@pobox.comE<gt> 1395*0Sstevel@tonic-gate 1396*0Sstevel@tonic-gate=head1 COPYRIGHT 1397*0Sstevel@tonic-gate 1398*0Sstevel@tonic-gateCopyright 2002 by chromatic E<lt>chromatic@wgz.orgE<gt>, 1399*0Sstevel@tonic-gate Michael G Schwern E<lt>schwern@pobox.comE<gt>. 1400*0Sstevel@tonic-gate 1401*0Sstevel@tonic-gateThis program is free software; you can redistribute it and/or 1402*0Sstevel@tonic-gatemodify it under the same terms as Perl itself. 1403*0Sstevel@tonic-gate 1404*0Sstevel@tonic-gateSee F<http://www.perl.com/perl/misc/Artistic.html> 1405*0Sstevel@tonic-gate 1406*0Sstevel@tonic-gate=cut 1407*0Sstevel@tonic-gate 1408*0Sstevel@tonic-gate1; 1409