view release on metacpan or  search on metacpan

lib/Acme/Gosub.pm  view on Meta::CPAN

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__

=head1 NAME

Acme::Gosub - Implement BASIC-like "gosub" and "greturn" in Perl

=head1 SYNOPSIS

    use Acme::Gosub;

    sub pythagoras
    {
        my ($x, $y) = (@_);
        my ($temp, $square, $sum);
        $sum = 0;
        $temp = $x;
        gosub SQUARE;
        $sum += $square;
        $temp = $y;
        gosub SQUARE;
        $sum += $square;
        return $sum;

    SQUARE:
        $square = $temp * $temp;
        greturn;
    }

=head1 DESCRIPTION