view release on metacpan or  search on metacpan

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

        *share = sub { return $_[0] };
        *lock  = sub { 0 };
    }
}

#line 117

our $Test = Test::Builder->new;

sub new {
    my($class) = shift;
    $Test ||= $class->create;
    return $Test;
}

#line 139

sub create {
    my $class = shift;

    my $self = bless {}, $class;
    $self->reset;

    return $self;
}

#line 168

sub child {
    my( $self, $name ) = @_;

    if( $self->{Child_Name} ) {
        $self->croak("You already have a child named ($self->{Child_Name}) running");
    }

    my $child = bless {}, ref $self;
    $child->reset;

    # Add to our indentation
    $child->_indent( $self->_indent . '    ' );
    $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};

    # This will be reset in finalize. We do this here lest one child failure
    # cause all children to fail.
    $child->{Child_Error} = $?;
    $?                    = 0;
    $child->{Parent}      = $self;
    $child->{Name}        = $name || "Child of " . $self->name;
    $self->{Child_Name}   = $child->name;
    return $child;
}


#line 201

sub subtest {
    my $self = shift;
    my($name, $subtests) = @_;

    if ('CODE' ne ref $subtests) {
        $self->croak("subtest()'s second argument must be a code ref");
    }

    # Turn the child into the parent so anyone who has stored a copy of
    # the Test::Builder singleton will get the child.
    my $child = $self->child($name);
    my %parent = %$self;
    %$self = %$child;

    my $error;
    if( !eval { $subtests->(); 1 } ) {
        $error = $@;
    }

    # Restore the parent and the copied child.
    %$child = %$self;
    %$self = %parent;

    # Die *after* we restore the parent.
    die $error if $error and !eval { $error->isa('Test::Builder::Exception') };

    return $child->finalize;
}


#line 250

sub finalize {
    my $self = shift;

    return unless $self->parent;
    if( $self->{Child_Name} ) {
        $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
    }
    $self->_ending;

    # XXX This will only be necessary for TAP envelopes (we think)
    #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );

    my $ok = 1;
    $self->parent->{Child_Name} = undef;
    if ( $self->{Skip_All} ) {
        $self->parent->skip($self->{Skip_All});
    }
    elsif ( not @{ $self->{Test_Results} } ) {
        $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
    }
    else {
        $self->parent->ok( $self->is_passing, $self->name );
    }
    $? = $self->{Child_Error};
    delete $self->{Parent};

    return $self->is_passing;
}

sub _indent      {
    my $self = shift;

    if( @_ ) {
        $self->{Indent} = shift;