view release on metacpan or  search on metacpan

lib/Combinator.pm  view on Meta::CPAN

L<http://search.cpan.org/dist/Combinator/>

=back


=head1 LICENSE AND COPYRIGHT

Copyright 2011 Cindy Wang (CindyLinz).

This program is free software; you can redistribute it and/or modify it
under the terms of either: the GNU General Public License as published
by the Free Software Foundation; or the Artistic License.

See http://dev.perl.org/licenses/ for more information.


=cut

use Filter::Simple;
use Guard;
use Devel::Caller;

my %opt;
my $begin_pat;
my $end_pat;
my $cir_begin_pat;
my $ser_pat;
my $par_pat;
my $cir_par_pat;
my $com_pat;
my $token_pat;
my $nex_begin_pat;
my $line_shift;

our $cv1 = [];

sub import {
    my $self = shift;
    %opt = (
        verbose => 0,
        begin => qr/\{\{com\b/,
        cir_begin => qr/\{\{cir\b/,
        nex_begin => qr/\{\{nex\b/,
        ser => qr/--ser\b/,
        par => qr/--com\b/,
        cir_par => qr/--cir\b/,
        end => qr/\}\}(?:com|cir|nex)\b/,
        next => qr/\{\{next\}\}/,
        @_
    );
    $begin_pat = qr/$opt{begin}|$opt{cir_begin}|(?:$opt{nex_begin})/;
    $end_pat = $opt{end};
    $ser_pat = $opt{ser};
    $par_pat = $opt{par};
    $cir_begin_pat = $opt{cir_begin};
    $nex_begin_pat = $opt{nex_begin};
    $cir_par_pat = $opt{cir_par};
    $com_pat = qr/($begin_pat((?:(?-2)|(?!$begin_pat).)*?)$end_pat)/s;
    $token_pat = qr/$com_pat|(?!$begin_pat)./s;
    $line_shift = (caller)[2];
}

sub att_sub {
    my($att1, $att2, $cb) = @_;
    sub {
        unshift @_, $att1, $att2;
        &$cb;
    }
}

# $cv = [wait_count, cb, args]
sub cv_end { # (cv, args)
    --$_[0][0];
    push @{$_[0][2]//=[]}, @{$_[1]} if $_[1];
    if( !$_[0][0] ) {
        if( $_[0][1] ) {
            delete($_[0][1])->(@{$_[0][2]});
        }
        undef $_[0][2];
    }
}
sub cv_cb { # (cv, cb)
    if( $_[0][0] ) {
        $_[0][1] = $_[1];
    }
    else {
        $_[1](@{$_[0][2]});
        undef $_[0][2];
    }
}

sub ser {
    my $depth = shift;
    if( @_ <= 1 ) { # next only
        return $_[0];
    }
    my $code = shift;
    unshift @_, $depth;
    my $next = &ser;
    replace_code($depth, $code);
    $code =~ s/$opt{next}/(do{my\$t=\$Combinator::cv1;++\$t->[0];sub{if(\$t){Combinator::cv_end(\$t,\\\@_);undef\$t}else{my(undef,\$f,\$l)=caller;warn"next should be invoked only once at \$f line \$l.\\n"}}})/g;
    my $out = "local\$Combinator::guard=Guard::guard{Combinator::cv_end(\$Combinator::cv0,\\\@_)};local\$Combinator::cv1=[1];$code;--\$Combinator::cv1->[0];Combinator::cv_cb(\$Combinator::cv1,Combinator::att_sub(\$Combinator::head,\$Combinator::cv0,s...
    return $out;
}

sub com { # depth, code, head
    my($depth, $code, $head) = @_;
    my @ser;
    $code .= "\n" if( substr($code, -1) eq "\n" );
    push @ser, $1 while( $code =~ m/(?:^|$ser_pat)($token_pat*?)(?=$ser_pat|$)/gs );

    if( @ser == 1 && $head !~ $cir_par_pat && $head !~ $cir_begin_pat && $head !~ $nex_begin_pat ) {
        replace_code($depth, @ser);
        return "{$ser[0]}";
    }

    my $delayed = $head =~ $nex_begin_pat;

    my $out = (
            $delayed ?