File Coverage

inc/Test/Exception/LessClever.pm

Criterion	Covered	Total	%
statement	15	51	29.4
branch	0	18	0.0
condition	0	2	0.0
subroutine	5	10	50.0
pod	5	5	100.0
total	25	86	29.0

#line 1
package Test::Exception::LessClever;
use strict;
use warnings;

use base 'Exporter';
use Test::Builder;
use Carp qw/carp/;

#{{{ POD

#line 52

#}}}

our @EXPORT_OK = qw/live_or_die/;
our @EXPORT = qw/lives_ok dies_ok throws_ok lives_and/;
our @CARP_NOT = ( __PACKAGE__ );
our $TB = Test::Builder->new;
our $VERSION = "0.006";

#line 77

sub live_or_die {
    my ( $code ) = @_;
    my $return = eval { $code->(); 'did not die' } || "died";
    my $msg = $@;

    if ( $return eq 'did not die' ) {
        return ( 1, $return ) if wantarray;
        return 1;
    }
    else {
        return 0 unless wantarray;

        if ( !$msg ) {
            carp "code died as expected, however the error is masked. This"
               . " can occur when an object's DESTROY() method calls eval";
        }

        return ( 0, $msg );
    }
}

#line 104

sub lives_ok(&;$) {
    my ( $code, $name ) = @_;
    my $ok = live_or_die( $code );
    $TB->ok( $ok, $name );
    return $ok;
}

#line 117

sub dies_ok(&;$) {
    my ( $code, $name ) = @_;
    my $ok = live_or_die( $code );
    $TB->ok( !$ok, $name );
    return !$ok;
}

#line 132

sub throws_ok(&$;$) {
    my ( $code, $reg, $name ) = @_;
    my ( $ok, $msg ) = live_or_die( $code );
    my ( $pkg, $file, $number ) = caller;

    # If we lived
    if ( $ok ) {
        $TB->diag( "Test did not die as expected at $file line $number." );
        return $TB->ok( !$ok, $name );
    }

    my $match = $msg =~ $reg ? 1 : 0;
    $TB->ok( $match, $name );

    $TB->diag( "$file line $number:\n  Wanted: $reg\n  Got: $msg" )
        unless( $match );

    return $match;
}

#line 160

sub lives_and(&;$) {
    my ( $code, $name ) = @_;
    my ( $ok, $msg )= live_or_die( $code );
    my ( $pkg, $file, $number ) = caller;
    chomp( $msg );
    $msg =~ s/\n/ /g;
    $TB->diag( "Test unexpectedly died: '$msg' at $file line $number." ) unless $ok;
    $TB->ok( $ok, $name ) if !$ok;
    return $ok;
}

1;

__END__