File Coverage

lib/Test/Easy.pm

Criterion	Covered	Total	%
statement	16	18	88.8
branch			n/a
condition			n/a
subroutine	6	6	100.0
pod			n/a
total	22	24	91.6

use strict;
use warnings;
package Test::Easy;
use base qw(Exporter);

use 5.006002;

# used as helper modules within this module
require Test::More;
use Carp qw(confess);

# this module re-exports functions from these modules
use Test::Easy::DataDriven;
use Test::Easy::DeepEqual;
use Test::Easy::Time;
use Test::Resub;

our $VERSION = 1.11;

## spend a little time moving things around into @EXPORT, @EXPORT_OK
our @EXPORT = qw(nearly_ok around_about wiretap);
our @EXPORT_OK = qw(nearly test_sub);
foreach my $supplier (qw(
  Test::Resub
  Test::Easy::DataDriven
  Test::Easy::Time
  Test::Easy::DeepEqual
)) {
  no strict 'refs';
  push @EXPORT, @{"$supplier\::EXPORT"};
  push @EXPORT_OK, @{"$supplier\::EXPORT_TAGS"};
}

# Set up %EXPORT_TAGS based on whatever we've shoved into @EXPORT, @EXPORT_OK
our %EXPORT_TAGS = (
  helpers => [@EXPORT_OK],
  all => [@EXPORT, @EXPORT_OK],
);
foreach my $supplier (qw(Test::Resub Test::Easy::DataDriven)) {
  no strict 'refs';
  %EXPORT_TAGS = _merge(%EXPORT_TAGS, %{"$supplier\::EXPORT_TAGS"});
}

sub _merge {
  my %out;
  while (my ($k, $v) = splice @_, 0, 2) {
    push @{$out{$k}}, @$v;
  }
  return %out;
}

# code begins here

sub nearly_ok {
  my ($got, $expected, $epsilon, $message) = @_;
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  Test::More::ok( nearly($got, $expected, $epsilon), $message )
     or warn "expected $got to be $expected +/- $epsilon; actual difference was " . ($expected - $got) . "\n";
}

sub nearly {
  my ($got, $expected, $epsilon) = @_;
  my $close = abs($expected - $got) <= $epsilon;
  return !!$close;
}

sub around_about {
  my ($now, $epsilon) = @_;

  $epsilon ||= 0;

  return Test::Easy::equivalence->new(
    raw  => [$now, $epsilon],
    explain => sub {
      my ($got, $raw) = @_;
      return sprintf '%s within %s seconds of %s', $got, reverse @$raw;
    },
    test => sub {
      my ($got) = @_;
      return time_nearly($got, $now, $epsilon);
    },
  );
}

sub test_sub (&) {
  my $test = shift;
  return sub {
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    goto &$test;
  };
}

sub wiretap {
  my ($target, $pre, @args) = @_;
  my $orig = do { no strict 'refs'; *{$target}{CODE} };
  return resub $target, sub {
    $pre->(@_) if $pre;
    $orig->(@_);
  }, @args;
}

1;

__END__