File Coverage

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

Criterion	Covered	Total	%
statement	82	83	98.8
branch	15	20	75.0
condition	3	3	100.0
subroutine	11	11	100.0
pod	0	3	0.0
total	111	120	92.5

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

use Carp qw/confess croak/;

use Test::Stream::Plugin;
use Devel::Declare;
use B::Hooks::EndOfScope;

our $VERSION = "0.000001";
our $DEBUG  = 0;
our $RECORD = 0;
our @RECORD;

sub load_ts_plugin {
    my $class = shift;
    my $caller = shift;

    Devel::Declare->setup_for(
        $caller->[0],
        {
            map { $_ => { const => \&parser } } grep { $caller->[0]->can($_) } qw{
                describe    cases
                tests       it
                case
                before_all  after_all  around_all
                before_case after_case around_case
                before_each after_each around_each
            }
        },
    );
}

sub parser {
    my ($dec, $offset) = @_;
    $offset += Devel::Declare::toke_move_past_token($offset);
    $offset += Devel::Declare::toke_skipspace($offset);

    my ($name, $meta);

    my @restore;
    my $restore = sub {
        my $line = Devel::Declare::get_linestr();
        push @RECORD => [0, $line, @restore] if $RECORD;
        print "MANGLE: |$line|\n" if $DEBUG;
        for my $set (reverse @restore) {
            my ($offset, $len, $val) = @$set;
            substr($line, $offset, $len) = $val;
        }
        Devel::Declare::set_linestr($line);
        print "FIXED:  |$line|\n" if $DEBUG;
        return 0;
    };

    # Get name
    my $line = Devel::Declare::get_linestr();
    my $start = substr($line, $offset, 1);

    if ($start eq '"' || $start eq "'") {
        my $len = Devel::Declare::toke_scan_str($offset);
        $name = Devel::Declare::get_lex_stuff();
        Devel::Declare::clear_lex_stuff();
        $offset += $len;
        substr($line, $offset, 0) = ", ";
        Devel::Declare::set_linestr($line);
        push @restore => [$offset, 2, ""];
        $offset += 2;
    }
    elsif (my $nlen = Devel::Declare::toke_scan_word($offset, 1)) {
        $name = substr($line, $offset, $nlen);
        my $new = "$name => ";
        substr($line, $offset, $nlen) = $new;
        Devel::Declare::set_linestr($line);
        push @restore => [$offset, length($new), $name];
        $offset += length($new);
    }

    return $restore->() unless defined $name;

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

    $line = Devel::Declare::get_linestr();
    $start = substr($line, $offset, 1);
    if ($start eq '(') {
        my $len = Devel::Declare::toke_scan_str($offset);
        $line = Devel::Declare::get_linestr();
        $meta = Devel::Declare::get_lex_stuff();
        Devel::Declare::clear_lex_stuff();
        my $new = "{$meta}, ";
        substr($line, $offset, $len) = $new;
        push @restore => [$offset, length($new), "($meta)"];
        Devel::Declare::set_linestr($line);
        $offset += length($new);
    }

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

    return $restore->() unless $start eq '{';

    my $new = "sub { BEGIN { Test::Stream::Plugin::SpecDeclare::inject_scope() }; ";
    substr($line, $offset, 1) = $new;
    Devel::Declare::set_linestr($line);
    print STDERR "$line\n" if $DEBUG;
    push @RECORD => [1, $line, @restore] if $RECORD;
}

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

1;

__END__