view release on metacpan or  search on metacpan

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

    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

Using this function enables using the "gosub" and "greturn" statements inside
your program. "gosub" is identical to "goto" except that it records the
place from which it was invoked. Then, when a "greturn" is used, it jumps back
to the place of the last goto that was not "greturned" yet. If you're not
a BASIC programmer you can think of it as a poor man's recursion.

For more information consult the examples in the test files.

=head1 FUNCTIONS

=head2 filter()

Does the actual filtering to the code.

=head2 filter_blocks()

The workhorse of the module - does most of the work of transforming the code.

=head2 line()