File Coverage

blib/lib/Test/Arrow.pm

Criterion	Covered	Total	%
statement	335	420	79.7
branch	111	196	56.6
condition	30	65	46.1
subroutine	66	69	95.6
pod	34	34	100.0
total	576	784	73.4

package Test::Arrow;
use strict;
use warnings;
use Test::Builder::Module;
use Test::Name::FromLine;
use Text::MatchedPosition;

our $VERSION = '0.21';

our @ISA = qw/Test::Builder::Module/;

sub _carp {
    my ($pkg, $file, $line) = caller;
    return warn @_, " at $pkg, $file line $line\n";
}

sub _croak {
    my ($pkg, $file, $line) = caller;
    return die @_, " at $pkg, $file line $line\n";
}

sub PASS { 1 }
sub FAIL { 0 }

sub import {
    my $pkg  = shift;
    my %args = map { $_ => 1 } @_;

    {
        my $caller = caller;
        no strict 'refs'; ## no critic
        *{"${caller}::done"} = \&done;
        *{"${caller}::t"} = \&t;
    }

    $pkg->_import_option_no_strict(\%args);
    $pkg->_import_option_no_warnings(\%args);
    $pkg->_import_option_binary(\%args);

    if (scalar(keys %args) > 0) {
        _croak "Wrong option: " . join(", ", keys %args);
    }

    if ( _need_io_handle() ) {
        require IO::Handle;
        IO::Handle->import;
    }
}

sub _need_io_handle { $] < 5.014000 }

sub _import_option_no_strict {
    my ($pkg, $args) = @_;

    my $no_strict = delete $args->{no_strict} or delete $args->{'-strict'};
    if (!$no_strict) {
        strict->import;
    }
}

sub _import_option_no_warnings {
    my ($pkg, $args) = @_;

    my $no_warnings = delete $args->{no_warnings} or delete $args->{'-warnings'};
    if (!$no_warnings) {
        warnings->import;
    }
}

sub _import_option_binary {
    my ($pkg, $args) = @_;

    my $binary = delete $args->{binary} or delete $args->{binary_mode}
                    or delete $args->{not_utf8} or delete $args->{'-utf8'} or delete $args->{'-utf'};
    if (!$binary) {
        binmode $pkg->builder->$_, ':utf8' for qw(failure_output todo_output output);
        require utf8;
        utf8->import;
    }
}

sub new {
    my $class = shift;
    my %args  = @_;

    my $self = bless {
        no_x => delete $args{'no_x'},
    }, $class;

    if ($args{plan}) {
        $self->plan(%{$args{plan}});
    }

    $self;
}

sub t {
    return __PACKAGE__->new(@_);
}

sub _tb { __PACKAGE__->builder }

sub _reset {
    my ($self) = @_;

    delete $self->{_name};
    delete $self->{_expected};
    delete $self->{_got};

    $self;
}

sub pass { shift; _tb->ok(PASS, @_) }
sub fail { shift; _tb->ok(FAIL, @_) }

sub plan {
    my $self = shift;

    return _tb->plan(@_);
}

sub skip {
    my ($self, $why, $how_many) = @_;

    # If the plan is set, and is static, then skip needs a count. If the plan
    # is 'no_plan' we are fine. As well if plan is undefined then we are
    # waiting for done_testing.
    unless (defined $how_many) {
        my $plan = _tb->has_plan;
        _carp "skip() needs to know \$how_many tests are in the block"
            if $plan && $plan =~ m/^\d+$/;
        $how_many = 1;
    }

    if(defined $how_many and $how_many =~ /\D/) {
        _carp "skip() was passed a non-numeric number of tests.  Did you get the arguments backwards?";
        $how_many = 1;
    }

    for(1 .. $how_many) {
        _tb->skip($why);
    }

    no warnings 'exiting';
    last SKIP;
}

sub BAIL_OUT {
    _tb->BAIL_OUT(scalar @_ == 1 ? $_[0] : $_[1]);
}

sub name {
    my ($self, $name) = @_;

    if (defined $name) {
        $self->{_name} = $name;
    }

    $self;
}

sub expected {
    my ($self, $value) = @_;

    my $arg_count = scalar(@_) - 1;

    if ($arg_count > 1) {
        _croak "'expected' method expects just only one arg. You passed $arg_count args.";
    }

    $self->{_expected} = $value;

    $self;
}

sub got {
    my ($self, $value) = @_;

    my $arg_count = scalar(@_) - 1;

    if ($arg_count > 1) {
        _croak "'got' method expects just only one arg. You passed $arg_count args.";
    }

    $self->{_got} = $value;

    $self;
}

sub _specific {
    my ($self, $key, $value) = @_;

    if (defined $value && exists $self->{$key} && defined $self->{$key}) {
        $key =~ s/^_//;
        $self->diag("You set '$key' also in args.");
    }

    return exists $self->{$key} && defined $self->{$key} ? $self->{$key} : $value;
}

sub ok {
    my ($self, $value, $name) = @_;

    my $got = $self->_specific('_got', $value);
    my $test_name = defined $name ? $name : $self->{_name};

    _tb->ok($got, $test_name);

    $self->_reset;

    $value;
}

sub to_be {
    my ($self, $got, $name) = @_;

    my $expected = $self->{_expected};
    my $test_name = $self->_specific('_name', $name);

    my $ret = _tb->is_eq($got, $expected, $test_name);

    $self->_reset;

    $ret;
}

sub _test {
    my $self   = shift;
    my $method = shift;

    my $got = $self->_specific('_got', $_[0]);
    my $expected = $self->_specific('_expected', $_[1]);
    my $test_name = $self->_specific('_name', $_[2]);

    local $Test::Builder::Level = 2;
    my $ret = _tb->$method($got, $expected, $test_name);

    $self->_reset;

    $ret;
}

sub is { shift->_test('is_eq', @_) }

sub isnt { shift->_test('isnt_eq', @_) }

sub is_num { shift->_test('is_num', @_) }

sub isnt_num { shift->_test('isnt_num', @_) }

sub like { shift->_test('like', @_) }

sub unlike {
    my $self = shift;

    my $got = $self->_specific('_got', $_[0]);
    my $expected = $self->_specific('_expected', $_[1]);
    my $test_name = $self->_specific('_name', $_[2]);

    my $ret = _tb->unlike($got, $expected, $test_name);

    $self->_reset;

    return $ret if $ret eq '1';

    my $pos = Text::MatchedPosition->new($got, $expected);
    return _tb->diag( sprintf <<'DIAGNOSTIC', $pos->line, $pos->offset );
          matched at line: %d, offset: %d
DIAGNOSTIC
}

sub diag {
    my $self = shift;

    _tb->diag(@_);

    $self;
}

sub note {
    my $self = shift;

    _tb->note(@_);

    $self;
}

sub explain {
    my $self = shift;

    if (scalar @_ == 0) {
        my $hash = {
            got      => $self->{_got},
            expected => $self->{_expected},
            name     => $self->{_name},
        };
        $self->diag(_tb->explain($hash));
    }
    else {
        $self->diag(_tb->explain(@_));
    }

    $self;
}

sub x {
    my $self = shift;

    return $self if $self->{no_x};

    my $hash = {
        got      => $self->{_got},
        expected => $self->{_expected},
        name     => $self->{_name},
    };

    $self->diag(_tb->explain(@_, $hash));

    $self;
}

sub done_testing {
    my $self = shift;

    _tb->done_testing(@_);

    $self;
}

sub done {
    _tb->done_testing(@_);
}

# Mostly copied from Test::More::can_ok
sub can_ok {
    my ($self, $proto, @methods) = @_;

    my $class = ref $proto || $proto;

    unless($class) {
        my $ok = _tb->ok(FAIL, "->can(...)");
        _tb->diag('    can_ok() called with empty class or reference');
        return $ok;
    }

    unless(@methods) {
        my $ok = _tb->ok(FAIL, "$class->can(...)");
        _tb->diag('    can_ok() called with no methods');
        return $ok;
    }

    my @nok = ();
    for my $method (@methods) {
        _tb->_try(sub { $proto->can($method) }) or push @nok, $method;
    }

    my $name = scalar @methods == 1 ? "$class->can('$methods[0]')" : "$class->can(...)";

    my $ok = _tb->ok(!@nok, $name);

    _tb->diag(map "    $class->can('$_') failed\n", @nok);

    return $ok;
}

# Mostly copied from Test::More::isa_ok
sub isa_ok {
    my $self = shift;

    my $got = $self->_specific('_got', $_[0]);
    my $expected = $self->_specific('_expected', $_[1]);
    my $test_name = $self->_specific('_name', $_[2]);

    my $whatami = 'class';
    if (!defined $got) {
        $whatami = 'undef';
    }
    elsif (ref $got) {
        $whatami = 'reference';

        local($@, $!);
        require Scalar::Util;
        if(Scalar::Util::blessed($got)) {
            $whatami = 'object';
        }
    }

    # We can't use UNIVERSAL::isa because we want to honor isa() overrides
    my ($result, $error) = _tb->_try(sub { $got->isa($expected) });

    if ($error) {
        _croak <
WHOA! I tried to call ->isa on your $whatami and got some weird error.
Here's the error.
$error
WHOA
    }

    # Special case for isa_ok( [], "ARRAY" ) and like
    if ($whatami eq 'reference') {
        $result = UNIVERSAL::isa($got, $expected);
    }

    my ($diag, $name) = $self->_get_isa_diag_name($whatami, $got, $expected, $test_name);

    my $ok;
    if ($result) {
        $ok = _tb->ok(PASS, $name);
    }
    else {
        $ok = _tb->ok(FAIL, $name);
        _tb->diag("    $diag\n");
    }

    $self->_reset;

    return $ok;
}

sub _get_isa_diag_name {
    my ($self, $whatami, $got, $expected, $test_name) = @_;

    my ($diag, $name);

    if (defined $test_name) {
        $name = "'$test_name' isa '$expected'";
        $diag = defined $got ? "'$test_name' isn't a '$expected'" : "'$test_name' isn't defined";
    }
    elsif ($whatami eq 'object') {
        my $my_class = ref $got;
        $test_name = qq[An object of class '$my_class'];
        $name = "$test_name isa '$expected'";
        $diag = "The object of class '$my_class' isn't a '$expected'";
    }
    elsif ($whatami eq 'reference') {
        my $type = ref $got;
        $test_name = qq[A reference of type '$type'];
        $name = "$test_name isa '$expected'";
        $diag = "The reference of type '$type' isn't a '$expected'";
    }
    elsif ($whatami eq 'undef') {
        $test_name = 'undef';
        $name = "$test_name isa '$expected'";
        $diag = "$test_name isn't defined";
    }
    elsif($whatami eq 'class') {
        $test_name = qq[The class (or class-like) '$got'];
        $name = "$test_name isa '$expected'";
        $diag = "$test_name isn't a '$expected'";
    }
    else {
        _croak;
    }

    return($diag, $name);
}

sub throw_ok {
    my $self = shift;

    eval { shift->() };

    _tb->ok(!!$@, $self->_specific('_name', $_[0]));

    $self->_reset;

    $self;
}

sub throw {
    my $self = shift;
    my $code = shift;

    _croak 'The `throw` method expects code ref.' unless ref $code eq 'CODE';

    eval { $code->() };

    if (my $e = $@) {
        if (defined $_[0]) {
            _tb->like($e, $_[0], $_[1] || 'Thrown correctly');
            $self->_reset;
        }
        else {
            $self->got($e);
        }
    }
    else {
        _tb->ok(FAIL);
        $self->diag(q|Failed, because it's expected to throw an exeption, but not.|);
    }

    $self;
}

sub catch {
    my $self  = shift;
    my $regex = shift;

    my $ret = _tb->like(
        $self->_specific('_got', undef),
        $regex,
        $self->_specific('_name', $_[0]),
    );

    $self->_reset;

    $ret;
}

sub warnings_ok {
    my ($self, $code, $name) = @_;

    my $warn = 0;
    eval {
        local $SIG{__WARN__} = sub { $warn++ };
        $code->();
    };
    if (my $e = $@) {
        _tb->ok(FAIL);
        $self->diag("An exception happened: $e");
    }

    _tb->ok($warn > 0, $self->_specific('_name', $name));

    $self->_reset;

    $self;
}

sub warnings {
    my ($self, $code, $regex, $name) = @_;

    _croak 'The `warn` method expects code ref.' unless ref $code eq 'CODE';

    my @warns;
    eval {
        local $SIG{__WARN__} = sub { push @warns, shift };
        $code->();
    };
    if (my $e = $@) {
        _tb->ok(FAIL);
        $self->diag("An exception happened: $e");
    }

    if (scalar @warns > 0) {
        my $warn = join "\t", @warns;
        if (defined $regex) {
            _tb->like($warn, $regex, $self->_specific('_name', $name));
            $self->_reset;
        }
        else {
            $self->got($warn);
        }
    }
    else {
        _tb->ok(FAIL);
        $self->diag(q|Failed, because there is no warnings.|);
    }

    $self;
}

# The most code around is_depply is copied from Test::More::is_deeply
our (@Data_Stack, %Refs_Seen);

my $DNE = bless [], 'Does::Not::Exist';

sub _dne {
    return ref $_[1] eq ref $DNE;
}

sub is_deeply {
    my $self = shift;

    my $got = $self->_specific('_got', $_[0]);
    my $expected = $self->_specific('_expected', $_[1]);
    my $test_name = $self->_specific('_name', $_[2]);

    _tb->_unoverload_str(\$expected, \$got);

    my $ok;

    if (!ref $got and !ref $expected) {
        # neither is a reference
        $ok = _tb->is_eq($got, $expected, $test_name);
    }
    elsif (!ref $got xor !ref $expected) {
        # one's a reference, one isn't
        $ok = _tb->ok(FAIL, $test_name);
        _tb->diag( $self->_format_stack({ vals => [$got, $expected] }) );
    }
    else {
        # both references
        local @Data_Stack = ();
        $ok = $self->_deep_check($got, $expected);
        _tb->diag( $self->_format_stack(@Data_Stack) ) unless $ok;
        _tb->ok($ok, $test_name);
    }

    $self->_reset;

    $self;
}

sub __same_ref { !(!ref $_[0] xor !ref $_[1]) }
sub __not_ref  {  (!ref $_[0] and !ref $_[1]) }

sub _deep_check {
    my ($self, $e1, $e2) = @_;

    my $ok = FAIL;

    # Effectively turn %Refs_Seen into a stack.  This avoids picking up
    # the same referenced used twice (such as [\$a, \$a]) to be considered
    # circular.
    local %Refs_Seen = %Refs_Seen;

    {
        _tb->_unoverload_str(\$e1, \$e2);

        # Either they're both references or both not.
        my $same_ref = __same_ref($e1, $e2);
        my $not_ref  = __not_ref($e1, $e2);

        if (defined $e1 xor defined $e2) {
            $ok = FAIL;
        }
        elsif (!defined $e1 and !defined $e2) {
            # Shortcut if they're both undefined.
            $ok = PASS;
        }
        elsif ($self->_dne($e1) xor $self->_dne($e2)) {
            $ok = FAIL;
        }
        elsif ($same_ref and ($e1 eq $e2)) {
            $ok = PASS;
        }
        elsif ($not_ref) {
            $self->_push_data_stack('', [$e1, $e2]);
            $ok = FAIL;
        }
        else {
            if ($Refs_Seen{$e1}) {
                return $Refs_Seen{$e1} eq $e2;
            }
            else {
                $Refs_Seen{$e1} = "$e2";
            }

            $ok = $self->__deep_check_type($ok, $e1, $e2);
        }
    }

    return $ok;
}

sub __deep_check_type {
    my ($self, $ok, $e1, $e2) = @_;

    my $type = $self->_type($e1);
    $type = 'DIFFERENT' unless $self->_type($e2) eq $type;

    if ($type eq 'DIFFERENT') {
        $self->_push_data_stack($type, [$e1, $e2]);
        $ok = FAIL;
    }
    elsif ($type eq 'ARRAY') {
        $ok = $self->_eq_array($e1, $e2);
    }
    elsif ($type eq 'HASH') {
        $ok = $self->_eq_hash($e1, $e2);
    }
    elsif ($type eq 'REF') {
        $self->_push_data_stack($type, [$e1, $e2]);
        $ok = $self->_deep_check($$e1, $$e2);
        pop @Data_Stack if $ok;
    }
    elsif ($type eq 'SCALAR') {
        $self->_push_data_stack('REF', [$e1, $e2]);
        $ok = $self->_deep_check($$e1, $$e2);
        pop @Data_Stack if $ok;
    }
    elsif ($type) {
        $self->_push_data_stack($type, [$e1, $e2]);
        $ok = FAIL;
    }
    else {
        _croak <<_WHOA_;
WHOA!  No type in _deep_check
This should never happen!  Please contact the author immediately!
_WHOA_
    }

    return $ok;
}

sub _push_data_stack {
    my ($self, $type, $vals, $idx) = @_;

    my $hash = {};

    $hash->{type} = $type if $type;
    $hash->{vals} = $vals if $vals;
    $hash->{idx}  = $idx  if $idx;

    push @Data_Stack, $hash;
}

sub _eq_array {
    my ($self, $a1, $a2) = @_;

    if ( grep $self->_type($_) ne 'ARRAY', $a1, $a2 ) {
        warn "eq_array passed a non-array ref";
        return FAIL;
    }

    return PASS if $a1 eq $a2;

    my $ok = PASS;
    my $max = $#$a1 > $#$a2 ? $#$a1 : $#$a2;

    for (0 .. $max) {
        my $e1 = $_ > $#$a1 ? $DNE : $a1->[$_];
        my $e2 = $_ > $#$a2 ? $DNE : $a2->[$_];

        next if $self->_equal_nonrefs($e1, $e2);

        $self->_push_data_stack('ARRAY', [$e1, $e2], $_);
        $ok = $self->_deep_check($e1, $e2);
        pop @Data_Stack if $ok;

        last unless $ok;
    }

    return $ok;
}

sub _eq_hash {
    my ($self, $a1, $a2) = @_;

    if ( grep $self->_type($_) ne 'HASH', $a1, $a2 ) {
        warn "eq_hash passed a non-hash ref";
        return FAIL;
    }

    return PASS if $a1 eq $a2;

    my $ok = PASS;
    my $bigger = keys %$a1 > keys %$a2 ? $a1 : $a2;

    for my $k ( keys %$bigger ) {
        my $e1 = exists $a1->{$k} ? $a1->{$k} : $DNE;
        my $e2 = exists $a2->{$k} ? $a2->{$k} : $DNE;

        next if $self->_equal_nonrefs($e1, $e2);

        $self->_push_data_stack('HASH', [$e1, $e2], $k);
        $ok = $self->_deep_check($e1, $e2);
        pop @Data_Stack if $ok;

        last unless $ok;
    }

    return $ok;
}

sub _equal_nonrefs {
    my ($self, $e1, $e2) = @_;

    return if ref $e1 or ref $e2;

    if (defined $e1) {
        return PASS if defined $e2 and $e1 eq $e2;
    }
    else {
        return PASS if !defined $e2;
    }

    return;
}

sub _type {
    my ($self, $thing) = @_;

    return '' if !ref $thing;

    for my $type (qw/Regexp ARRAY HASH REF SCALAR GLOB CODE VSTRING/) {
        return $type if UNIVERSAL::isa($thing, $type);
    }

    return '';
}

sub _format_stack {
    my ($self, @stack) = @_;

    my $var       = '$FOO';
    my $did_arrow = 0;

    for my $entry (@stack) {
        my $type = $entry->{type} || '';
        my $idx = $entry->{'idx'};
        if($type eq 'HASH') {
            $var .= "->" unless $did_arrow++;
            $var .= "{$idx}";
        }
        elsif($type eq 'ARRAY') {
            $var .= "->" unless $did_arrow++;
            $var .= "[$idx]";
        }
        elsif($type eq 'REF') {
            $var = "\${$var}";
        }
    }

    my @vals = @{ $stack[-1]{vals} }[ 0, 1 ];
    my @vars = ();

    ( $vars[0] = $var ) =~ s/\$FOO/     \$got/;
    ( $vars[1] = $var ) =~ s/\$FOO/\$expected/;

    my $out = "Structures begin differing at:\n";

    for my $idx (0 .. $#vals) {
        my $val = $vals[$idx];
        $vals[$idx]
          = !defined $val     ? 'undef'
          : $self->_dne($val) ? "Does not exist"
          : ref $val          ? "$val"
          :                     "'$val'";
    }

    $out .= "$vars[0] = $vals[0]\n" . "$vars[1] = $vals[1]\n";

    $out =~ s/^/    /msg;

    return $out;
}

{
    no warnings 'once';
    *expect = *expected;

    *warn_ok    = *warnings_ok;
    *warning_ok = *warnings_ok;

    *warning = *warnings;
}

1;

__END__