File Coverage

blib/lib/Test2/Plugin/SpecDeclare.pm

Criterion	Covered	Total	%
statement	75	78	96.1
branch	18	24	75.0
condition	4	6	66.6
subroutine	9	9	100.0
pod	0	2	0.0
total	106	119	89.0

package Test2::Plugin::SpecDeclare;
use strict;
use warnings;

use Devel::Declare;
use B::Hooks::EndOfScope;

use Carp qw/croak/;

our $VERSION = '0.000002';

sub import {
    my $class = shift;
    my $into  = caller;

    my @keywords;
    my %params;
    for my $arg (@_) {
        if ($arg =~ m/^-(.+)$/) {
            $params{$1} = 1;
            next;
        }
        push @keywords => $arg;
    }

    if(delete $params{spec} || !@_) {
        my %seen;
        push @keywords => grep { !$seen{$_}++ && $into->can($_) }
            @Test2::Tools::Spec::EXPORT,
            @Test2::Tools::Spec::EXPORT_OK;
    }

    croak "Unknown parameter(s): " . join(',', map { "-$_" } keys %params)
        if keys %params;

    croak "No keywords (Did you forget to load Test2::Tools::Spec, or specify a list of keywords?)"
        unless @keywords;

    Devel::Declare->setup_for(
        $into,
        {map { $_ => {const => \&parser} } @keywords},
    );
}

sub inject {
    on_scope_end {
        my $linestr = Devel::Declare::get_linestr;
        my $offset  = Devel::Declare::get_linestr_offset;
        substr($linestr, $offset, 0) = ', __LINE__;';
        Devel::Declare::set_linestr($linestr);
    };
}

sub parser {
    my ($declarator, $offset) = @_;
    my @caller = caller(1);

    # Skip the declarator
    $offset += Devel::Declare::toke_move_past_token($offset);
    $offset += Devel::Declare::toke_skipspace($offset);
    my $line = Devel::Declare::get_linestr();

    my $name;
    my $name_offset = $offset;
    my $name_len;

    # Get the block name
    my $start = substr($line, $offset, 1);
    if ($start eq '(') {
        # No changes
        return;
    }
    elsif ($start eq '"' || $start eq "'") {
        # Quoted name
        $name_len = Devel::Declare::toke_scan_str($offset);
        $name     = Devel::Declare::get_lex_stuff();
        Devel::Declare::clear_lex_stuff();
        $offset += $name_len;
    }
    elsif ($name_len = Devel::Declare::toke_scan_word($offset, 1)) {
        # Bareword name
        $name = substr($line, $offset, $name_len);
        $offset += $name_len;
    }

    $offset += Devel::Declare::toke_skipspace($offset);
    $line = Devel::Declare::get_linestr();

    my $meta = "";
    my $meta_offset;
    my $meta_len;

    $start = substr($line, $offset, 1);
    if ($start eq '(') {
        $meta_offset = $offset;
        $meta_len    = Devel::Declare::toke_scan_str($offset);
        $meta        = Devel::Declare::get_lex_stuff();
        Devel::Declare::clear_lex_stuff();
        $line = Devel::Declare::get_linestr();

        die "Syntax error at $caller[1] line $caller[2]: Test2::Plugin::SpecDeclare does not support multiline parameters.\n"
            if $meta =~ m/\n/;

        $offset += $meta_len;
        $offset += Devel::Declare::toke_skipspace($offset);
        $line = Devel::Declare::get_linestr();
        $start = substr($line, $offset, 1);
    }

    # No changes
    return unless $start eq '{';

    # Ok! we are good to munge this thing!
    substr($line, $offset, 1) = " sub { BEGIN { Test2::Plugin::SpecDeclare::inject() }; ";

    if ($meta) {
        substr($line, $meta_offset + $meta_len - 1, 1) = '}, ';
        substr($line, $meta_offset, 1) = ' +{';
    }

    substr($line, $name_offset + $name_len, 0) = ' => __LINE__, ';

    Devel::Declare::set_linestr($line);
    $line = Devel::Declare::get_linestr();
}

1;

__END__