File Coverage

blib/lib/Test/Stream/Plugin/Core.pm

Criterion	Covered	Total	%
statement	212	214	99.0
branch	65	74	87.8
condition	10	14	71.4
subroutine	34	34	100.0
pod	18	18	100.0
total	339	354	95.7

package Test::Stream::Plugin::Core;
use strict;
use warnings;

use Scalar::Util qw/reftype refaddr/;
use Carp qw/croak confess carp/;

use Test::Stream::Sync;

use Test::Stream::Table qw/table/;

use Test::Stream::Context qw/context/;
use Test::Stream::Util qw{
    protect
    get_stash
    parse_symbol
    update_mask
    render_ref
};

use Test::Stream::Exporter;
default_exports qw{
    ok pass fail
    diag note
    plan skip_all done_testing
    BAIL_OUT
    todo skip
    can_ok isa_ok DOES_ok ref_ok
    imported_ok not_imported_ok
    ref_is ref_is_not
    set_encoding
    cmp_ok
};
no Test::Stream::Exporter;

sub set_encoding {
    my $enc = shift;
    my $format = Test::Stream::Sync->stack->top->format;

    unless ($format && eval { $format->can('encoding') }) {
        $format = '' unless defined $format;
        croak "Unable to set encoding on formatter '$format'";
    }

    $format->encoding($enc);
}

sub pass {
    my ($name) = @_;
    my $ctx = context();
    $ctx->ok(1, $name);
    $ctx->release;
    return 1;
}

sub fail {
    my ($name, @diag) = @_;
    my $ctx = context();
    $ctx->ok(0, $name, \@diag);
    $ctx->release;
    return 0;
}

sub ok($;$@) {
    my ($bool, $name, @diag) = @_;
    my $ctx = context();
    $ctx->ok($bool, $name, \@diag);
    $ctx->release;
    return $bool ? 1 : 0;
}

sub ref_is($$;$@) {
    my ($got, $exp, $name, @diag) = @_;
    my $ctx = context();

    $got = '' unless defined $got;
    $exp = '' unless defined $exp;

    my $bool = 0;
    if (!ref($got)) {
        $ctx->ok(0, $name, ["First argument '$got' is not a reference", @diag]);
    }
    elsif(!ref($exp)) {
        $ctx->ok(0, $name, ["Second argument '$exp' is not a reference", @diag]);
    }
    else {
        # Don't let overloading mess with us.
        $bool = refaddr($got) == refaddr($exp);
        $ctx->ok($bool, $name, ["'$got' is not the same reference as '$exp'", @diag]);
    }

    $ctx->release;
    return $bool ? 1 : 0;
}

sub ref_is_not($$;$) {
    my ($got, $exp, $name, @diag) = @_;
    my $ctx = context();

    $got = '' unless defined $got;
    $exp = '' unless defined $exp;

    my $bool = 0;
    if (!ref($got)) {
        $ctx->ok(0, $name, ["First argument '$got' is not a reference", @diag]);
    }
    elsif(!ref($exp)) {
        $ctx->ok(0, $name, ["Second argument '$exp' is not a reference", @diag]);
    }
    else {
        # Don't let overloading mess with us.
        $bool = refaddr($got) != refaddr($exp);
        $ctx->ok($bool, $name, ["'$got' is the same reference as '$exp'", @diag]);
    }

    $ctx->release;
    return $bool ? 1 : 0;
}

sub diag {
    my $ctx = context();
    $ctx->diag( join '', @_ );
    $ctx->release;
}

sub note {
    my $ctx = context();
    $ctx->note( join '', @_ );
    $ctx->release;
}

sub BAIL_OUT {
    my ($reason) = @_;
    my $ctx = context();
    $ctx->bail($reason);
    $ctx->release if $ctx;
}

sub skip_all {
    my ($reason) = @_;
    my $ctx = context();
    $ctx->plan(0, SKIP => $reason);
    $ctx->release if $ctx;
}

sub plan {
    my ($max) = @_;
    my $ctx = context();
    $ctx->plan($max);
    $ctx->release;
}

update_mask('*', '*', __PACKAGE__ . '::done_testing', {lock => 1});
sub done_testing {
    my $ctx = context();
    $ctx->hub->finalize($ctx->debug, 1);
    $ctx->release;
}

sub todo {
    my $reason = shift;
    my $code   = shift;

    my $ctx = context();
    my $todo = $ctx->hub->set_todo($reason);
    $ctx->release;

    return $todo unless $code;

    # tail-end recursion to remove this stack frame from the stack trace.
    # We push $todo onto @_ so that it is not destroyed until the sub returns.
    push @_ => $todo;
    goto &$code;
}

sub skip {
    my ($why, $num) = @_;
    $num ||= 1;
    my $ctx = context();
    $ctx->debug->set_skip($why);
    $ctx->ok(1, "skipped test") for 1 .. $num;
    $ctx->debug->set_skip(undef);
    $ctx->release;
    no warnings 'exiting';
    last SKIP;
}

BEGIN {
    for my $op (qw/isa can DOES/) {
        my $sub = sub($;@) {
            my ($thing, @items) = @_;
            my $ctx = context();

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

            my @bad;
            for my $item (@items) {
                my $bool;
                protect { eval qq/#line $line "$file"\n\$bool = \$thing->$op(\$item); 1/ || die $@ };
                next if $bool;

                push @bad => $item;
            }

            $ctx->ok(
                !@bad,
                @items == 1 ? "$thing\->$op('$items[0]')" : "$thing\->$op(...)",
                [map { "Failed: $thing\->$op('$_')" } @bad],
            );

            $ctx->release;

            return !@bad;
        };
        no strict 'refs';
        *{$op . "_ok"} = $sub;
    }
}

sub ref_ok($;$$) {
    my ($thing, $wanttype, $name) = @_;
    my $ctx = context();

    my $gottype = reftype($thing);

    if (!$gottype) {
        $ctx->ok(0, $name, ["'$thing' is not a reference"]);
        $ctx->release;
        return 0;
    }

    if ($wanttype && $gottype ne $wanttype) {
        $ctx->ok(0, $name, ["'$thing' is not a '$wanttype' reference"]);
        $ctx->release;
        return 0;
    }

    $ctx->ok(1, $name);
    $ctx->release;
    return 1;
}

sub _imported {
    my $caller = shift;

    my $stash = get_stash($caller);
    my @missing;
    for my $item (@_) {
        my ($name, $type) = parse_symbol($item);

        if(my $glob = $stash->{$name}) {
            my $val = *{$glob}{$type};
            next if defined $val;
        }

        push @missing => $item;
    }

    return @missing;
}

sub imported_ok {
    my $caller = caller;

    my $ctx = context();

    my @missing = _imported($caller, @_);

    $ctx->ok(!@missing, "Imported expected symbols", [map { "'$_' was not imported." } @missing]);

    $ctx->release;

    return !@missing;
}

sub not_imported_ok {
    my $caller = caller;

    my $ctx = context();

    my %missing = map {$_ => 1} _imported($caller, @_);

    my @found = grep { !$missing{$_} } @_;

    $ctx->ok(!@found, "Did not import symbols", [map { "'$_' was imported." } @found]);

    $ctx->release;

    return !@found;
}

our %OPS = (
    '=='  => 'num',
    '!='  => 'num',
    '>='  => 'num',
    '<='  => 'num',
    '>'   => 'num',
    '<'   => 'num',
    '<=>' => 'num',

    'eq'  => 'str',
    'ne'  => 'str',
    'gt'  => 'str',
    'lt'  => 'str',
    'ge'  => 'str',
    'le'  => 'str',
    'cmp' => 'str',
    '!~'  => 'str',
    '=~'  => 'str',

    '&&'  => 'logic',
    '||'  => 'logic',
    'xor' => 'logic',
    'or'  => 'logic',
    'and' => 'logic',
    '//'  => 'logic',

    '&' => 'bitwise',
    '|' => 'bitwise',

    '~~' => 'match',
);
sub cmp_ok($$$;$@) {
    my ($got, $op, $exp, $name, @diag) = @_;

    my $ctx = context();

    # warnings and syntax errors should report to the cmp_ok call, not the test
    # context, they may not be the same.
    my ($pkg, $file, $line) = caller;

    my $type = $OPS{$op};
    if (!$type) {
        carp "operator '$op' is not supported (you can add it to %Test::Stream::Plugin::Core::OPS)";
        $type = 'unsupported';
    }

    local ($@, $!, $SIG{__DIE__});

    my $test;
    my $lived = eval <<"    EOT";
#line $line "(eval in cmp_ok) $file"
\$test = (\$got $op \$exp);
1;
    EOT
    my $error = $@;
    $ctx->send_event('Exception', error => $error) unless $lived;

    if ($test && $lived) {
        $ctx->ok(1, $name);
        $ctx->release;
        return 1;
    }

    # Uhg, it failed, do roughly the same thing Test::More did to try and show
    # diagnostics, but make it better by showing both the overloaded and
    # unoverloaded form if overloading is in play. Also unoverload numbers,
    # Test::More only unoverloaded strings.

    my ($display_got, $display_exp);
    if($type eq 'str') {
        $display_got = defined($got) ? "$got" : undef;
        $display_exp = defined($exp) ? "$exp" : undef;
    }
    elsif($type eq 'num') {
        $display_got = defined($got) ? sprintf("%D", $got) : undef;
        $display_exp = defined($exp) ? sprintf("%D", $exp) : undef;
    }
    else { # Well, we did what we could.
        $display_got = $got;
        $display_exp = $exp;
    }

    my $got_ref = ref($got) ? render_ref($got) : $got;
    my $exp_ref = ref($exp) ? render_ref($exp) : $exp;

    my @table;
    my $show_both = (
        (defined($got) && $got_ref ne "$display_got")
        ||
        (defined($exp) && $exp_ref ne "$display_exp")
    );

    if ($show_both) {
        @table = table(
            header => ['type', 'got', 'op', 'check'],
            rows   => [
                [$type, $display_got, $op, $lived ? $display_exp : ''],
                ['orig', $got_ref, '', $exp_ref],
            ],
        );
    }
    else {
        @table = table(
            header => ['got', 'op', 'check'],
            rows   => [[$display_got, $op, $lived ? $display_exp : '']],
        );
    }

    $ctx->ok(0, $name, [@table, @diag]);
    $ctx->release;
    return 0;
}

1;

__END__