view release on metacpan or  search on metacpan

src/inc/Test/Builder.pm  view on Meta::CPAN

package Test::Builder;

use 5.004;

# $^C was only introduced in 5.005-ish.  We do this to prevent
# use of uninitialized value warnings in older perls.
$^C ||= 0;

use strict;
use vars qw($VERSION $CLASS);
$VERSION = '0.17';
$CLASS = __PACKAGE__;

my $IsVMS = $^O eq 'VMS';

# Make Test::Builder thread-safe for ithreads.
BEGIN {
    use Config;
    if( $] >= 5.008 && $Config{useithreads} ) {
        require threads;
        require threads::shared;
        threads::shared->import;
    }
    else {
        *share = sub { 0 };
        *lock  = sub { 0 };
    }
}

use vars qw($Level);
my($Test_Died) = 0;
my($Have_Plan) = 0;
my $Original_Pid = $$;
my $Curr_Test = 0;      share($Curr_Test);
my @Test_Results = ();  share(@Test_Results);
my @Test_Details = ();  share(@Test_Details);



my $Test;
sub new {
    my($class) = shift;
    $Test ||= bless ['Move along, nothing to see here'], $class;
    return $Test;
}


my $Exported_To;
sub exported_to {
    my($self, $pack) = @_;

    if( defined $pack ) {
        $Exported_To = $pack;
    }
    return $Exported_To;
}

sub plan {
    my($self, $cmd, $arg) = @_;

    return unless $cmd;

    if( $Have_Plan ) {
        die sprintf "You tried to plan twice!  Second plan at %s line %d\n",
          ($self->caller)[1,2];
    }

    if( $cmd eq 'no_plan' ) {
        $self->no_plan;
    }
    elsif( $cmd eq 'skip_all' ) {
        return $self->skip_all($arg);
    }
    elsif( $cmd eq 'tests' ) {
        if( $arg ) {
            return $self->expected_tests($arg);
        }
        elsif( !defined $arg ) {
            die "Got an undefined number of tests.  Looks like you tried to ".
                "say how many tests you plan to run but made a mistake.\n";
        }
        elsif( !$arg ) {
            die "You said to run 0 tests!  You've got to run something.\n";
        }
    }
    else {
        require Carp;
        my @args = grep { defined } ($cmd, $arg);
        Carp::croak("plan() doesn't understand @args");
    }

    return 1;
}


my $Expected_Tests = 0;
sub expected_tests {
    my($self, $max) = @_;

    if( defined $max ) {
        $Expected_Tests = $max;
        $Have_Plan      = 1;