File Coverage

blib/lib/Test/Carp.pm

Criterion	Covered	Total	%
statement	127	144	88.1
branch	37	54	68.5
condition	16	27	59.2
subroutine	23	28	82.1
pod	8	8	100.0
total	211	261	80.8

package Test::Carp;

use strict;
use warnings;
use Carp;

$Test::Carp::VERSION = '0.2';

# Prototype mismatch: sub Test::Carp::_ok: none vs ($;$) at .../Test/Carp.pm line ...
# perl -MTest::More  -e 'print prototype("Test::More::ok");'
# sub _ok($;$) {
sub _ok {
    require Test::More;

    # no warnings 'redefine';
    # *_ok = \&Test::More::ok;    # make subsequent calls not do all of this ferdiddling
    goto &Test::More::ok;
}

sub import {
    my $caller = caller();

    use Data::Dumper;
    if ( ref( $_[1] ) eq 'CODE' ) {
        no warnings 'redefine';
        *_ok = $_[1];
    }

    no strict 'refs';
    for my $func (qw(
      does_carp               does_cluck
      does_croak              does_confess
      does_carp_that_matches  does_cluck_that_matches
      does_croak_that_matches does_confess_that_matches
      )) {
        *{ $caller . "::$func" } = *{$func};
      };
}

sub _does {
    my $caller = caller();
    my $func   = shift;
    my $code   = shift;

    no strict 'refs';
    my ( $carp_orig, $caller_orig ) = ( \&{"Carp::$func"}, \&{"${caller}::$func"} );

    no warnings 'redefine';
    my $called = 0;

    *{"Carp::$func"} = sub {
        return if $called++;
        _ok( 1, "$func() was called (@_)" );
        if ( $func eq 'croak' || $func eq 'confess' ) {
            local $Carp::CarpLevel = $Carp::CarpLevel + 2;
            $carp_orig->( $_[0] );
        }
    };
    *{"${caller}::$func"} = \&{"Carp::$func"};

    ( $func eq 'croak' || $func eq 'confess' ) ? eval { $code->(@_) } : $code->(@_);
    _ok( 0, "$func() was called" ) if !$called;

    *{"Carp::$func"}      = $carp_orig;
    *{"${caller}::$func"} = $caller_orig;
}

sub does_carp {
    unshift @_, 'carp';
    goto &_does;
}

sub does_cluck {
    unshift @_, 'cluck';
    goto &_does;
}

sub does_croak {
    unshift @_, 'croak';
    goto &_does;
}

sub does_confess {
    unshift @_, 'confess';
    goto &_does;
}

sub _does_and_matches {
    my $caller = caller();

    my $func  = shift;
    my $code  = shift;
    my $match = pop;

    no strict 'refs';
    my ( $carp_orig, $caller_orig ) = ( \&{"Carp::$func"}, \&{"${caller}::$func"} );

    no warnings 'redefine';
    my $called = 0;

    if ( !defined $match ) {
        $match = 'undef()';    # so you don't get "Use of uninitialized value" when used in the test name during
                               # t/02.functions.t oddity (look for 'to test that these are working we need to reverse ok()')
        *{"Carp::$func"} = sub {
            return if @_ && grep { defined $_ } @_;
            return if $called++;
            _ok( 1, "$func() was called w/ undefined argument" );
            if ( $func eq 'croak' || $func eq 'confess' ) {
                local $Carp::CarpLevel = $Carp::CarpLevel + 2;
                $carp_orig->();    # do not pass @_ or you get: Use of uninitialized value in join or string at .../Carp/Heavy.pm at line ...
            }
        };
    }
    elsif ( $match eq '' ) {
        *{"Carp::$func"} = sub {
            return if "@_" ne '';
            return if $called++;
            _ok( 1, "$func() was called w/ empty string argument" );
            if ( $func eq 'croak' || $func eq 'confess' ) {
                local $Carp::CarpLevel = $Carp::CarpLevel + 2;
                $carp_orig->(@_);
            }
        };
    }
    elsif ( ref($match) eq 'Regexp' ) {
        *{"Carp::$func"} = sub {
            return if "@_" !~ $match;
            return if $called++;
            _ok( 1, "$func() was called (w/ '@_') and matches '$match'" );
            if ( $func eq 'croak' || $func eq 'confess' ) {
                local $Carp::CarpLevel = $Carp::CarpLevel + 2;
                $carp_orig->(@_);
            }
        };
    }
    else {

        # On some odd setups qr() is not available
        if ( eval { $match = qr/$match/; ref($match) eq 'Regexp' ? 1 : 0 } ) {
            *{"Carp::$func"} = sub {
                return if "@_" !~ $match;
                return if $called++;
                _ok( 1, "$func() was called (w/ '@_') and matches '$match'" );
                if ( $func eq 'croak' || $func eq 'confess' ) {
                    local $Carp::CarpLevel = $Carp::CarpLevel + 2;
                    $carp_orig->(@_);
                }
            };
        }
        else {
            $match = quotemeta($match);    # use this instead of \Q\E so that it will be escaped in the test label
            *{"Carp::$func"} = sub {
                return if "@_" !~ m/$match/;
                return if $called++;
                _ok( 1, "$func() was called (w/ '@_') and matches '$match'" );
                if ( $func eq 'croak' || $func eq 'confess' ) {
                    local $Carp::CarpLevel = $Carp::CarpLevel + 2;
                    $carp_orig->(@_);
                }
            };
        }
    }
    *{"${caller}::$func"} = *{"Carp::$func"};

    ( $func eq 'croak' || $func eq 'confess' ) ? eval { $code->(@_) } : $code->(@_);
    _ok( 0, "$func() was called and matches '$match'" ) if !$called;

    *{"Carp::$func"}      = $carp_orig;
    *{"${caller}::$func"} = $caller_orig;
}

sub does_carp_that_matches {
    unshift @_, 'carp';
    goto &_does_and_matches;
}

sub does_cluck_that_matches {
    unshift @_, 'cluck';
    goto &_does_and_matches;
}

sub does_croak_that_matches {
    unshift @_, 'croak';
    goto &_does_and_matches;
}

sub does_confess_that_matches {
    unshift @_, 'confess';
    goto &_does_and_matches;
}

1;

__END__