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

    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;
    }

package Acme::Gosub;

use strict;
use warnings;
use vars qw($VERSION);
use Carp;

$VERSION = '0.1.4';

# 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__