File Coverage

blib/lib/Test2/Tools/Class.pm

Criterion	Covered	Total	%
statement	63	63	100.0
branch	17	18	94.4
condition	12	15	80.0
subroutine	9	9	100.0
pod			n/a
total	101	105	96.1

package Test2::Tools::Class;
use strict;
use warnings;

our $VERSION = '0.000156';

use Test2::API qw/context/;
use Test2::Util::Ref qw/render_ref/;

use Scalar::Util qw/blessed/;

our @EXPORT = qw/can_ok isa_ok DOES_ok/;
use base 'Exporter';

# For easier grepping
# sub isa_ok  is defined here
# sub can_ok  is defined here
# sub DOES_ok is defined here
BEGIN {
    for my $op (qw/isa can DOES/) {
        my $sub = sub($;@) {
            my ($thing, @args) = @_;
            my $ctx = context();

            my (@items, $name);
            if (ref($args[0]) eq 'ARRAY') {
                $name  = $args[1];
                @items = @{$args[0]};
            }
            else {
                @items = @args;
            }

            my $thing_name = ref($thing) ? render_ref($thing) : defined($thing) ? "$thing" : "";
            $thing_name =~ s/\n/\\n/g;
            $thing_name =~ s/#//g;
            $thing_name =~ s/\(0x[a-f0-9]+\)//gi;

            $name ||= @items == 1 ? "$thing_name\->$op('$items[0]')" : "$thing_name\->$op(...)";

            unless (defined($thing) && (blessed($thing) || !ref($thing) && length($thing))) {
                my $thing = defined($thing)
                    ? ref($thing) || "'$thing'"
                    : '';

                $ctx->ok(0, $name, ["$thing is neither a blessed reference or a package name."]);

                $ctx->release;
                return 0;
            }

            unless(UNIVERSAL->can($op) || $thing->can($op)) {
                $ctx->skip($name, "'$op' is not supported on this platform");
                $ctx->release;
                return 1;
            }

            my $file = $ctx->trace->file;
            my $line = $ctx->trace->line;

            my @bad;
            for my $item (@items) {
                my ($bool, $ok, $err);

                {
                    local ($@, $!);
                    $ok = eval qq/#line $line "$file"\n\$bool = \$thing->$op(\$item); 1/;
                    $err = $@;
                }

                die $err unless $ok;
                next if $bool;

                push @bad => $item;
            }

            $ctx->ok( !@bad, $name, [map { "Failed: $thing_name\->$op('$_')" } @bad]);

            $ctx->release;

            return !@bad;
        };

        no strict 'refs';
        *{$op . "_ok"} = $sub;
    }
}

1;

__END__