File Coverage

blib/lib/Acme/ComeFrom.pm

Criterion	Covered	Total	%
statement	25	25	100.0
branch	5	6	83.3
condition			n/a
subroutine	5	5	100.0
pod	0	1	0.0
total	35	37	94.5

package Acme::ComeFrom;
$Acme::ComeFrom::VERSION = '0.11';

use 5.005;
use strict;
use vars qw/$CacheEXPR/;
use Filter::Simple 0.70;

my $Mark  = '__COME_FROM';
my $count = '0000';

FILTER_ONLY code => sub {
    my ( %subs, %labels, @tokens, @counts );
    my $source = $_;

    $_ = $source and return unless $source =~ /comefrom/;

    while ( $source =~
        s/\bcomefrom\b(\s*)\(?(&?)?([\w\:]+|[^\;]+)(?:\(\))?\)?/$Mark$count:$1/ )
    {
        my $token = $3;

        push @{ $subs{$token} }, $count++ and next if $2;
        push @{ $labels{$token} }, $count++ and next if $token =~ /^[\w\:]+$/;
        push @tokens, $token;
        push @counts, $count++;
    }

    $_ = $source and return unless %subs or %labels or @tokens;

    my $code = '';

    if (%subs) {
        require Hook::LexWrap;
        $code .= 'require Hook::LexWrap;';
    }

    while ( my ( $k, $v ) = each %subs ) {
        my $chunk = make_chunk($v);
        $code .= "Hook::LexWrap::wrap($k, post => sub { $chunk });";
    }

    if (@tokens) {
        $source =~ s!(\n\s*)([a-zA-Z_]\w+):!
            my $label = $2;
            my $chunk = make_chunk(
                [ @counts, exists $labels{$label} ? @{$labels{$label}} : ()],
                $label, \@tokens
            ) unless substr($label, 0, length($Mark)) eq $Mark;

            "$1$label:" . ($chunk ? "do {$chunk};" : '');
        !eg;
    }
    else {
        while ( my ( $k, $v ) = each %labels ) {
            my $chunk = make_chunk($v);
            $source =~ s!\Q$k\E:!$k: do {$chunk};!g;
        }
    }

    $_ = ( $code ? "CHECK { $code; 1 };" : '' ) . $source;
};

sub make_chunk {
    my $pkg = '$' . __PACKAGE__;
    my ( $v, $label, $cond ) = @_;
    my $chunk = '';

    foreach my $iter ( 0 .. $#{$v} ) {
        my $fork = ( $iter != $#{$v} );

        if ( defined $cond->[$iter] ) {
            my $forktext = ( $fork ? ' or fork' : '' );

            $chunk .= "
                if (\$Acme::ComeFrom::CacheEXPR) {
                    $pkg\::CACHE[$v->[$iter]] = eval q;$cond->[$iter];
                        unless exists $pkg\::CACHE[$v->[$iter]];

                    goto $Mark$v->[$iter] unless
                        ('$label' ne $pkg\::CACHE[$v->[$iter]])$forktext;
                }
                else {
                    goto $Mark$v->[$iter] unless
                        ('$label' ne eval q;$cond->[$iter];)$forktext;
                }
            ";
        }
        else {
            $chunk .= "goto $Mark$v->[$iter]" . ( $fork ? " unless fork();" : ';' );
        }
    }

    $chunk =~ s/\n */ /g;
    return $chunk;
}

1;

__END__