File Coverage

blib/lib/Test/Bomb.pm

Criterion	Covered	Total	%
statement	47	47	100.0
branch	22	22	100.0
condition	2	2	100.0
subroutine	9	9	100.0
pod	4	4	100.0
total	84	84	100.0

use strict;
use warnings;
package Test::Bomb;
# ABSTRACT: a test which succeeds until a deadline passes ( a time bomb )

our $VERSION = 0.007;

use Exporter qw/import/;
use Date::Parse;
use Test::More;

our @EXPORT = qw/ bomb /;


my @configFiles = (
    $ENV{TESTBOMBCONFIG} || '',
    './t/tbc', './t/testbombconfig',
    './.tbc', './.testbombconfig',
    './tbc', './testbombconfig',
    ($ENV{HOME}||'.').'/.tbc',
    ($ENV{HOME}||'.').'/.testbombconfig',
);


%Test::Bomb::groups = ( );


sub bomb {
    local( $Test::Builder::Level ) = 2;
    ok( 0, 'Don\'t send me out there! I can\'t take the preasure!'), return
                         if releasing();
    if( $_[0] eq '-after' ) {
	checkDate($_[1]);
    } elsif( $_[0] eq '-with' ) {
        my $name = $_[1];
	if( exists $Test::Bomb::groups{$name} ) {
	    checkDate($Test::Bomb::groups{$name})
	} else {
	    checkDate(readConfig($name));
	}
    } else {
        ok 0, 'invalid parameter: \''. $_[0] . "'";
    }
    return
}


sub readConfig {
    local( $Test::Builder::Level ) = 3;
    my $name = shift;
    my $stringDate;
    my $configFile = ( grep { -f $_ } @configFiles )[0] || '';
    open IN, $configFile or ok( 0, 'failed to open config file'),
                           return 'configFail';
    ($stringDate) = map { $_->[0] eq $name ? $_->[1] : () }
		    map { s/(^\s+|\s+$|['"])//g; chomp; [split /\s*=\s*/,$_] }
			     (  );
    close IN;
    ok( 0, 'bomb group is not defined: '.$name), return 'configFail'
			if not defined $stringDate;
    return $stringDate;
}


sub checkDate {
    local( $Test::Builder::Level ) = 3;
    my $dateStr = shift;
    return if $dateStr eq 'configFail' ;
    my $time = str2time($dateStr);
    ok(0, "invalid date: '$dateStr'"), return unless $time;
    my $res = time < $time;
    my $name = $res ? "bomb after $dateStr" : 'deadline passed' ;
    ok $res, $name ;
}


sub releasing {
    return 1 if exists $ENV{DZIL_RELEASING};
}


1; # End of Test::Bomb


__END__