File Coverage

blib/lib/Acme/Gosub.pm

Criterion	Covered	Total	%
statement	76	81	93.8
branch	21	26	80.7
condition	2	5	40.0
subroutine	10	11	90.9
pod	3	3	100.0
total	112	126	88.8

package Acme::Gosub;
$Acme::Gosub::VERSION = '0.1.7';
use strict;
use warnings;
use Carp;

# LOAD FILTERING MODULE...
use Filter::Util::Call;

# CATCH ATTEMPTS TO CALL case OUTSIDE THE SCOPE OF ANY switch

my $next_label_idx = 0;
use vars qw(%ret_labels);

$::_S_W_I_T_C_H = sub { croak "case/when statement not in switch/given block" };

my $offset;
my $fallthrough;

sub import
{
    $fallthrough = grep /\bfallthrough\b/, @_;
    $offset = (caller)[2]+1;
    filter_add({}) unless @_>1 && $_[1] eq 'noimport';
    my $pkg = caller;
    1;
}

sub unimport
{
    filter_del()
}

sub filter
{
    my($self) = @_ ;
    local $Acme::Gosub::file = (caller)[1];

    my $status = 1;
    $status = filter_read(1_000_000);
    return $status if $status<0;
        $_ = filter_blocks($_,$offset);
    $_ = "# line $offset\n" . $_ if $offset; undef $offset;
    return $status;
}

use Text::Balanced ':ALL';

sub line
{
    my ($pretext,$offset) = @_;
    ($pretext=~tr/\n/\n/)+($offset||0);
}

my $EOP = qr/\n\n|\Z/;
my $CUT = qr/\n=cut.*$EOP/;
my $pod_or_DATA = qr/ ^=(?:head[1-4]|item) .*? $CUT
                    | ^=pod .*? $CUT
                    | ^=for .*? $EOP
                    | ^=begin \s* (\S+) .*? \n=end \s* \1 .*? $EOP
                    | ^__(DATA|END)__\n.*
                    /smx;

my $casecounter = 1;
sub filter_blocks
{
    my ($source, $line) = @_;
    return $source unless $source =~ /gosub|greturn/;
    pos $source = 0;
    my $text = "";
    component: while (pos $source < length $source)
    {
        if ($source =~ m/(\G\s*use\s+Acme::Gosub\b)/gc)
        {
            $text .= q{use Acme::Gosub 'noimport'};
            next component;
        }
        my @pos = Text::Balanced::_match_quotelike(\$source,qr/\s*/,1,0);
        if (defined $pos[0])
        {
            my $pre = substr($source,$pos[0],$pos[1]); # matched prefix
            $text .= $pre . substr($source,$pos[2],$pos[18]-$pos[2]);
            next component;
        }
        if ($source =~ m/\G\s*($pod_or_DATA)/gc) {
            next component;
        }
        @pos = Text::Balanced::_match_variable(\$source,qr/\s*/);
        if (defined $pos[0])
        {
            $text .= " " if $pos[0] < $pos[2];
            $text .= substr($source,$pos[0],$pos[4]-$pos[0]);
            next component;
        }

        if ($source =~ m/\G(\n*)(\s*)gosub\b/gc)
        {
            $text .= "$1$2";
            my $arg;
            if ($source =~ m/\G\s*(\w+)\s*;/gc)
            {
                $arg = $1;
            }
            else
            {
                my $pos_source = pos($source);
                # This is an Evil hack that meant to get Text::Balanced to do
                # what we want. What happens is that we put an initial ";"
                # so the end of the statement will be a ";" too.
                my $source_for_text_balanced = ";" .
                    substr($source, $pos_source);
                pos($source_for_text_balanced) = 0;
                @pos = Text::Balanced::_match_codeblock(\$source_for_text_balanced,qr/\s*/,qr/;/,qr/;/,qr/[[{(<]/,qr/[]})>]/,undef)
                    or do {
                        die "Bad gosub statement (problem in the parentheses?) near $Acme::Gosub::file line ", line(substr($source_for_text_balanced,0,pos $source_for_text_balanced),$line), "\n";
                    };
                my $future_pos_source = $pos_source + pos($source_for_text_balanced);
                print join(",",@pos), "\n";
                $arg = filter_blocks(substr($source_for_text_balanced,1,$pos[4]-$pos[0]),line(substr($source_for_text_balanced,0,1),$line));
                print "\$arg = $arg\n";
                pos($source) = $future_pos_source;
            }

            my $next_ret_label = "__G_O_S_U_B_RET_LABEL_" .
                ($next_label_idx++);

            $text .= "push \@{\$Acme::Gosub::ret_labels{(caller(0))[3]}}, \"$next_ret_label\";";
            $text .= "goto $arg;";
            $text .= "$next_ret_label:";
            next component;
        }
        elsif ($source =~ m/\G(\s*)greturn\s*;/gc)
        {
            $text .= $1;
            $text .= "goto (pop(\@{\$Acme::Gosub::ret_labels{(caller(0))[3]}}));";
            next component;
        }

        $source =~ m/\G(\s*(-[sm]\s+|\w+|#.*\n|\W))/gc;
        $text .= $1;
    }
    $text;
}

1;

__END__