File Coverage

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

Criterion	Covered	Total	%
statement	109	110	99.0
branch	16	22	72.7
condition	5	5	100.0
subroutine	13	13	100.0
pod	0	2	0.0
total	143	152	94.0

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

use Test::Stream::Plugin;

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

use PadWalker qw/peek_my peek_our/;
use Carp qw/confess croak/;

# Do not declare any variables here!!!!

my %META;
sub _metahash {
    my $string = "";
    my $vars = { %{peek_our(1)}, %{peek_my(1)} };

    {
        my $id = shift;
        my @caller = caller(0);
        my $meta = $META{$id} || return {};

        my $var_string = "";
        for my $var (keys %$vars) {
            my $end = "\$vars->{'$var'}";
            if ($var =~ m/^([\@\%\$])/) {
                $end = "${1}{$end}";
            }
            else {
                next;
            }
            $var_string .= "my $var = $end;\n";
        }

        $string = <<"        EOT";
package $caller[0];
$var_string

# This is cut off access to these variables so they can not be modified in the
# eval.
my \$vars;
my \$string;
my \%META;
# line $caller[2] "$caller[1] (SpecDeclare eval)"
my \$h = {$meta};
        EOT
    }

    my $hash = eval $string;
    die $@ unless $hash;

    return $hash;
}

# Now we can define some variables.
my $ID = 1;
our $DEBUG   = 0;
our $VERSION = "0.000003";

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 _inject_scope {
    on_scope_end {
        my $line = Devel::Declare::get_linestr();
        my $offset = Devel::Declare::get_linestr_offset();
        substr($line, $offset, 0) = ', __LINE__;';
        Devel::Declare::set_linestr($line);
        print STDERR "FINAL: |$line|\n" if $DEBUG;
    }
}

sub parser {
    my ($dec, $offset) = @_;
    my ($name, $meta);

    # Due to parsing strangeness we need to grab the meta-data and get it back
    # later. This ID is used to fetch the data later.
    my $id = $ID++;

    # This is used to back out all changes if a parsing error occurs.
    my @restore;
    my $restore = sub {
        my $line = Devel::Declare::get_linestr();
        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;
    };

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

    # After the name we use a fat comma, then get the meta hash by id, then add
    # an opening paren, which strangely works around some parser issues, we
    # will close it later
    my $post_name = " => __LINE__, Test::Stream::Plugin::SpecDeclare::_metahash($id), (";

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

    # Back out if we failed to get a name
    return $restore->() unless defined $name;

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

    # See if there is any meta stuff listed.
    $line = Devel::Declare::get_linestr();
    $start = substr($line, $offset, 1);
    if ($start eq '(') {
        my $len = Devel::Declare::toke_scan_str($offset);
        $meta = Devel::Declare::get_lex_stuff();
        Devel::Declare::clear_lex_stuff();
        $line = Devel::Declare::get_linestr();

        # Stash the meta stuff to get later, in perls older than 5.20 we can't
        # leave it here as it messes up the parser
        $META{$id} = $meta;

        # Replace meta with nothing except the newlines (to preserve line
        # numbers)
        # For some reason putting anything here other than whitespace causes
        # problems.
        my @newlines = $meta =~ /(\n)/g;
        my $new = join '' => @newlines;
        substr($line, $offset, $len) = $new;
        Devel::Declare::set_linestr($line);

        # This is how to back it out later
        push @restore => [$offset, length($new), "($meta)"];

        # Advance the offset
        $offset += length($new);
    }

    # Move to the start of the block
    $offset += Devel::Declare::toke_skipspace($offset);
    $line = Devel::Declare::get_linestr();
    $start = substr($line, $offset, 1);
    return $restore->() unless $start eq '{';

    # Close the paren we opened above, then inject the sub keyword and the
    # inject scope call which gets us the trailing semicolon.
    my $new = "), sub { BEGIN { Test::Stream::Plugin::SpecDeclare::_inject_scope(); }; ";
    substr($line, $offset, 1) = $new;
    Devel::Declare::set_linestr($line);
    $offset += length($new);
    print STDERR "PREFIN: |$line|\n" if $DEBUG;
}

1;

__END__