view release on metacpan or  search on metacpan

perl5/Pugs-Compiler-Rule/RuleInline-more.pl  view on Meta::CPAN

package Pugs::Runtime::RuleInline;

# - fglock
#
use strict;
use warnings;
use Data::Dumper;
use PadWalker qw( peek_my );  # peek_our ); ???

sub alternation {
    return '( ' . join( ' || ', @_ ) . ' )';
}

sub concat {    
    return '( ' . join( ' && ', @_ ) . ' )';
}

# 2 versions - match anywhere; match at $pos
sub constant_at_pos { 
    my $const = shift;
    my $len = length( $const );
    '( ( substr( $s, $pos, '.$len.' ) eq \''.$const.'\' ) 
    ? do { $pos += '.$len.'; push @match, \''.$const.'\' }
    : 0
)'
}
sub constant_anywhere { 
    my $const = shift;
    "( ( \$s =~ m/\Q$const\E/s ) 
    ? do { \$pos = pos \$s; push \@match, $const } 
    : 0 
)"
}

# implements <after>
# $pos must be saved
sub constant_reversed { 
    my $const = shift;
    my $len = length( $const );
    '( ( substr( $s, $pos - '.$len.', '.$len.' ) eq \''.$const.'\' ) 
    ? do { $pos -= '.$len.' }
    : 0
)'

sub greedy_star {
    "do { while @_ {} }"
}

sub null {
    "1";
};

sub wrap {
    return "sub { 
    my \@match; my \$pos = 0; my \$s = shift; 
    $_[0]; 
    return \\\@match; \n}\n";
}

my $r = 
    concat( 
        alternation( constant_at_pos('a'), constant_at_pos('b') ),
        constant_at_pos('b'),
        greedy_star( constant_at_pos('x') ),
    );
print wrap( $r );
my $x = eval wrap( $r );
print Dumper( $x->("abxxxd") );