File Coverage

blib/lib/Test/Recent.pm

Criterion	Covered	Total	%
statement	74	75	98.6
branch	25	28	89.2
condition	7	10	70.0
subroutine	14	14	100.0
pod	2	2	100.0
total	122	129	94.5

package Test::Recent;
use 5.006;

use base qw(Exporter);

use strict;
use Test::Builder::Tester;

use DateTime;
use Time::Duration::Parse qw(parse_duration);
use DateTime::Format::ISO8601;
use Scalar::Util qw(blessed);
use Carp qw(croak);

use vars qw(@EXPORT_OK $VERSION $OverridedNowForTesting $RelativeTo);

$VERSION = "2.50";

my $tester = Test::Builder->new();

# utility regex
my $YMD    = qr/[0-9]{4}-[0-9]{2}-[0-9]{2}/x;
my $HMS    = qr/[0-9]{2}:[0-9]{2}:[0-9]{2}/x;
my $SUBSEC = qr/[0-9]+/x;
my $TZ     = qr/[+-][0-9]{2}/x;
my $EPOCH  = qr/\A  \d+ (?:\.\d+)?  \z/x;

$Test::Recent::future_duration = DateTime::Duration->new( seconds => 0 );

# convert anything that's passed to us into a DateTime object
sub _datetime($) {
	my $str = shift;
	return unless defined $str;
	return $str if blessed $str && $str->isa("DateTime");

	###
	# is this epoch seconds?
	###

	if ($str =~ $EPOCH) {
		return DateTime->from_epoch( epoch => $str );
	}

	###
	# munge common extra formats into ISO8601
	###

	# postgres
	$str =~ s<\A ($YMD) [ ] ($HMS) [.] $SUBSEC ($TZ) \z><$1T$2$3>x;

	return eval { DateTime::Format::ISO8601->parse_datetime( $str ) };  ## no critic (RequireCheckingReturnValueOfEval)
}

# work out what the time is now
sub _now() {
	# people can override time!
	my $now = $RelativeTo;
	if (defined $now) {
		$now = _datetime($now);
		unless (defined $now) {
			croak "\$Test::Recent::RelativeTo isn't parsable by Test::Recent";
		}
	}

	# historically we allowed $OverridedNowForTesting to be used to override
	# the sense of time.  If some muppet is still using this, let them
	$now = $OverridedNowForTesting unless defined $now;

	$now = DateTime->now() unless defined $now;

	return $now;
}

sub occured_within_ago($$) {
	my $value = shift;
	return unless defined $value;

	my $time = _datetime($value);
	return unless defined $time;

	# forget the nanoseconds in the time passed to us.  This is necessary
	# because DateTime->now() doesn't return nanoseconds, so if we don't
	# forget nanoseconds what is passed in might actually be mistaken
	# for something in the future
	$time = $time->clone->set_nanosecond(0);

	my $durations = shift;
	my ($past_duration, $future_duration);
	if (ref $durations eq "ARRAY") {
		($past_duration, $future_duration) = @{ $durations };
	} else {
		($past_duration, $future_duration)
			= ($durations, $Test::Recent::future_duration);
	}

	foreach my $duration ($past_duration, $future_duration) {
		unless (blessed $duration && $duration->isa("DateTime::Duration")) {
			$duration = DateTime::Duration->new(
				seconds => parse_duration($duration)
			);
		}
	}

	my $now = _now;
	my $ago = $now - $past_duration;
	my $ahead = $now + $future_duration;

	return if $ahead < $time;
	return if $time < $ago;
	return 1;
}
push @EXPORT_OK, "occured_within_ago";

sub recent ($;$$) {
	my $time = shift;
	my $desc = pop || "recent time";
	my $duration = shift || "10s";

	# work out when now is and "freeze it"
	local $RelativeTo = _now;  ## no critic (ProhibitMixedCaseVars)

	my $ok = occured_within_ago($time, $duration);
	$tester->ok($ok, $desc);
	return 1 if $ok;
	$tester->diag("$time not recent to $RelativeTo");
	return;
}
push @EXPORT_OK, "recent";

1;

__END__