ACIL FM

Pilih semua

Nama	Ukuran	Aksi
Base.pm	2.26 MB	View DL Edit
Bootstrap.pm	13.7 MB	View DL Edit
Compiler.pm	4.68 MB	View DL Edit
Grammar.pm	3.25 MB	View DL Edit
Input.pm	1.53 MB	View DL Edit
Optimizer.pm	3.81 MB	View DL Edit
Parser.pm	7.67 MB	View DL Edit
Receiver.pm	465 B	View DL Edit
Tree.pm	311 B	View DL Edit

Edit file: /home/.cpan/build/Template-Toolkit-Simple-0.31-0/inc/Pegex/Bootstrap.pm

package Pegex::Bootstrap;
use Pegex::Base;
extends 'Pegex::Compiler';

use Pegex::Grammar::Atoms;
use Pegex::Pegex::AST;

use Carp qw(carp confess croak);

#------------------------------------------------------------------------------
# The grammar. A DSL data structure. Things with '=' are tokens.
#------------------------------------------------------------------------------
has pointer => 0;
has groups => [];
has tokens => [];
has ast => {};
has stack => [];
has tree => {};
has grammar => {
    'grammar' => [
        '=pegex-start',
        'meta-section',
        'rule-section',
        '=pegex-end',
    ],
    'meta-section' => 'meta-directive*',
    'meta-directive' => [
        '=directive-start',
        '=directive-value',
        '=directive-end',
    ],
    'rule-section' => 'rule-definition*',
    'rule-definition' => [
        '=rule-start',
        '=rule-sep',
        'rule-group',
        '=rule-end',
    ],
    'rule-group' => 'any-group',
    'any-group' => [
        '=list-alt?',
        'all-group',
        [
            '=list-alt',
            'all-group',
            '*',
        ],
    ],
    'all-group' => 'rule-part+',
    'rule-part' => [
        'rule-item',
        [
            '=list-sep',
            'rule-item',
            '?',
        ],
    ],
    'rule-item' => [
        '|',
        '=rule-reference',
        '=quoted-regex',
        'regular-expression',
        'bracketed-group',
        'whitespace-token',
        '=error-message',
    ],
    'regular-expression' => [
        '=regex-start',
        '=!regex-end*',
        '=regex-end',
    ],
    'bracketed-group' => [
        '=group-start',
        'rule-group',
        '=group-end',
    ],
    'whitespace-token' => [
        '|',
        '=whitespace-maybe',
        '=whitespace-must',
    ],
};

#------------------------------------------------------------------------------
# Parser logic:
#------------------------------------------------------------------------------
sub parse {
    my ($self, $grammar_text) = @_;

$self->lex($grammar_text);
    # YYY $self->{tokens};
    $self->{pointer} = 0;
    $self->{farthest} = 0;
    $self->{tree} = {};

$self->match_ref('grammar') || do {
        my $far = $self->{farthest};
        my $tokens = $self->{tokens};
        $far -= 4 if $far >= 4;
        WWW splice @$tokens, $far, 9;
        die "Bootstrap parse failed";
    };
    # XXX $self->{tree};

return $self;
}

sub match_next {
    my ($self, $next) = @_;
    my $method;
    if (ref $next) {
        $next = [@$next];
        if ($next->[0] eq '|') {
            shift @$next;
            $method = 'match_any';
        }
        else {
            $method = 'match_all';
        }
        if ($next->[-1] =~ /^[\?\*\+]$/) {
            my $quant = pop @$next;
            return $self->match_times($quant, $method => $next);
        }
        else {
            return $self->$method($next);
        }
    }
    else {
        $method = ($next =~ s/^=//) ? 'match_token' : 'match_ref';
        if ($next =~ s/([\?\*\+])$//) {
            return $self->match_times($1, $method => $next);
        }
        else {
            return $self->$method($next);
        }
    }
}

sub match_times {
    my ($self, $quantity, $method, @args) = @_;
    my ($min, $max) =
        $quantity eq '' ? (1, 1) :
        $quantity eq '?' ? (0, 1) :
        $quantity eq '*' ? (0, 0) :
        $quantity eq '+' ? (1, 0) : die "Bad quantity '$quantity'";
    my $stop = $max || 9999;
    my $count = 0;
    my $pointer = $self->{pointer};
    while ($stop-- and $self->$method(@args)) {
        $count++;
    }
    return 1 if $count >= $min and (not $max or $count <= $max);
    $self->{pointer} = $pointer;
    $self->{farthest} = $pointer if $pointer > $self->{farthest};
    return;
}

sub match_any {
    my ($self, $any) = @_;
    my $pointer = $self->{pointer};
    for (@$any) {
        if ($self->match_next($_)) {
            return 1;
        }
    }
    $self->{pointer} = $pointer;
    $self->{farthest} = $pointer if $pointer > $self->{farthest};
    return;
}

sub match_all {
    my ($self, $all) = @_;
    my $pointer = $self->{pointer};
    for (@$all) {
        if (not $self->match_next($_)) {
            $self->{pointer} = $pointer;
            $self->{farthest} = $pointer if $pointer > $self->{farthest};
            return;
        }
    }
    return 1;
}

sub match_ref {
    my ($self, $ref) = @_;
    my $rule = $self->{grammar}->{$ref}
        or Carp::confess "Not a rule reference: '$ref'";
    $self->match_next($rule);
}

sub match_token {
    my ($self, $token_want) = @_;
    my $not = ($token_want =~ s/^\!//) ? 1 : 0;
    return if $self->{pointer} >= @{$self->{tokens}};
    my $token = $self->{tokens}[$self->{pointer}];
    my $token_got = $token->[0];
    if (($token_want eq $token_got) xor $not) {
        $token_got =~ s/-/_/g;
        my $method = "got_$token_got";
        if ($self->can($method)) {
            # print "$method\n";
            $self->$method($token);
        }
        $self->{pointer}++;
        return 1;
    }
    return;
}

#------------------------------------------------------------------------------
# Receiver/ast-generator methods:
#------------------------------------------------------------------------------
sub got_directive_start {
    my ($self, $token) = @_;
    $self->{directive_name} = $token->[1];
}

sub got_directive_value {
    my ($self, $token) = @_;
    my $value = $token->[1];
    $value =~ s/\s+$//;
    my $name = $self->{directive_name};
    if (my $old_value = $self->{tree}{"+$name"}) {
        if (not ref($old_value)) {
            $old_value = $self->{tree}{"+$name"} = [$old_value];
        }
        push @$old_value, $value;
    }
    else {
        $self->{tree}{"+$name"} = $value;
    }
}

sub got_rule_start {
    my ($self, $token) = @_;
    $self->{stack} = [];
    my $rule_name = $token->[1];
    $rule_name =~ s/-/_/g;
    $self->{rule_name} = $rule_name;
    $self->{tree}{'+toprule'} ||= $rule_name;
    $self->{groups} = [[0, ':']];
}

sub got_rule_end {
    my ($self) = @_;
    $self->{tree}{$self->{rule_name}} = $self->group_ast;
}

sub got_group_start {
    my ($self, $token) = @_;
    push @{$self->{groups}}, [scalar(@{$self->{stack}}), $token->[1]];
}

sub got_group_end {
    my ($self, $token) = @_;
    my $rule = $self->group_ast;
    Pegex::Pegex::AST::set_quantity($rule, $token->[1]);
    push @{$self->{stack}}, $rule;
}

sub got_list_alt {
    my ($self) = @_;
    push @{$self->{stack}}, '|';
}

sub got_list_sep {
    my ($self, $token) = @_;
    push @{$self->{stack}}, $token->[1];
}

sub got_rule_reference {
    my ($self, $token) = @_;
    my $name = $token->[2];
    $name =~ s/-/_/g;
    $name =~ s/^<(.*)>$/$1/;
    my $rule = { '.ref' => $name };
    Pegex::Pegex::AST::set_modifier($rule, $token->[1]);
    Pegex::Pegex::AST::set_quantity($rule, $token->[3]);
    push @{$self->{stack}}, $rule;
}

sub got_error_message {
    my ($self, $token) = @_;
    push @{$self->{stack}}, { '.err' => $token->[1] };
}

sub got_whitespace_maybe {
    my ($self) = @_;
    $self->got_rule_reference(['whitespace-maybe', undef, '_', undef]);
}

sub got_whitespace_must {
    my ($self) = @_;
    $self->got_rule_reference(['whitespace-maybe', undef, '__', undef]);
}

sub got_quoted_regex {
    my ($self, $token) = @_;
    my $regex = $token->[1];
    $regex =~ s/([^\w\`\%\:\<\/\,\=\;])/\\$1/g;
    push @{$self->{stack}}, { '.rgx' => $regex };
}

sub got_regex_start {
    my ($self) = @_;
    push @{$self->{groups}}, [scalar(@{$self->{stack}}), '/'];
}

sub got_regex_end {
    my ($self) = @_;
    my $regex = join '', map {
        if (ref($_)) {
            my $part;
            if (defined($part = $_->{'.rgx'})) {
                $part;
            }
            elsif (defined($part = $_->{'.ref'})) {
                "<$part>";
            }
            else {
                XXX $_;
            }
        }
        else {
            $_;
        }
    } splice(@{$self->{stack}}, (pop @{$self->{groups}})->[0]);
    $regex =~ s!\(([ism]?\:|\=|\!)!(?$1!g;
    push @{$self->{stack}}, {'.rgx' => $regex};
}

sub got_regex_raw {
    my ($self, $token) = @_;
    push @{$self->{stack}}, $token->[1];
}

#------------------------------------------------------------------------------
# Receiver helper methods:
#------------------------------------------------------------------------------
sub group_ast {
    my ($self) = @_;
    my ($offset, $gmod) = @{pop @{$self->{groups}}};
    $gmod ||= '';
    my $rule = [splice(@{$self->{stack}}, $offset)];

for (my $i = 0; $i < @$rule-1; $i++) {
        if ($rule->[$i + 1] =~ /^%%?$/) {
            $rule->[$i] = Pegex::Pegex::AST::set_separator(
                $rule->[$i],
                splice @$rule, $i+1, 2
            );
        }
    }
    my $started = 0;
    for (
        my $i = (@$rule and $rule->[0] eq '|') ? 1 : 0;
        $i < @$rule-1;
        $i++
    ) {
        next if $rule->[$i] eq '|';
        if ($rule->[$i+1] eq '|') {
            $i++;
            $started = 0;
        }
        else {
            $rule->[$i] = {'.all' => [$rule->[$i]]}
                unless $started++;
            push @{$rule->[$i]{'.all'}}, splice @$rule, $i+1, 1;
            $i--
        }
    }
    if (grep {$_ eq '|'} @$rule) {
        $rule = [{'.any' => [ grep {$_ ne '|'} @$rule ]}];
    }

$rule = $rule->[0] if @$rule <= 1;
    Pegex::Pegex::AST::set_modifier($rule, $gmod)
        unless $gmod eq ':';

return $rule;
}

# DEBUG: wrap/trace parse methods:
# for my $method (qw(
#     match_times match_next match_ref match_token match_any match_all
# )) {
#     no strict 'refs';
#     no warnings 'redefine';
#     my $orig = \&$method;
#     *$method = sub {
#         my $self = shift;
#         my $args = join ', ', map {
#             ref($_) ? '[' . join(', ', @$_) . ']' :
#             length($_) ? $_ : "''"
#         } @_;
#         print "$method($args)\n";
#         die if $main::x++ > 250;
#         $orig->($self, @_);
#     };
# }

#------------------------------------------------------------------------------
# Lexer logic:
#------------------------------------------------------------------------------
my $ALPHA = 'A-Za-z';
my $DIGIT = '0-9';
my $DASH  = '\-';
my $SEMI  = '\;';
my $UNDER  = '\_';
my $HASH  = '\#';
my $EOL   = '\r?\n';
my $WORD  = "$DASH$UNDER$ALPHA$DIGIT";
my $WS    = "(?:[\ \t]|$HASH.*$EOL)";
my $MOD   = '[\!\=\-\+\.]';
my $GMOD  = '[\.\-]';
my $QUANT = '(?:[\?\*\+]|\d+(?:\+|\-\d+)?)';
my $NAME  = "$UNDER?[$UNDER$ALPHA](?:[$WORD]*[$ALPHA$DIGIT])?";

# Repeated Rules:
my $rem   = [qr/\A(?:$WS+|$EOL+)/];
my $qr    = [qr/\A\'((?:\\.|[^\'])*)\'/, 'quoted-regex'];

# Lexer regex tree:
has regexes => {
    pegex => [
        [qr/\A%(grammar|version|extends|include)$WS+/,
            'directive-start', 'directive'],

[qr/\A($NAME)(?=$WS*\:)/,
            'rule-start', 'rule'],

$rem,

[qr/\A\z/,
            'pegex-end', 'end'],
    ],

rule => [
        [qr/\A(?:$SEMI$WS*$EOL?|\s*$EOL|)(?=$NAME$WS*\:|\z)/,
            'rule-end', 'end'],

[qr/\A\:/,
            'rule-sep'],

[qr/\A(?:\+|\~\~)(?=\s)/,
            'whitespace-must'],
        [qr/\A(?:\-|\~)(?=\s)/,
            'whitespace-maybe'],

$qr,
        [qr/\A($MOD)?($NAME|<$NAME>)($QUANT)?(?!$WS*$NAME\:)/,
            'rule-reference'],
        [qr/\A\//,
            'regex-start', 'regex'],
        [qr/\A\`([^\`\n]*?)\`/,
            'error-message'],

[qr/\A($GMOD)?$/,
            'group-start'],
        [qr/\A$($QUANT)?/,
            'group-end'],
        [qr/\A\|/,
            'list-alt'],
        [qr/\A(\%\%?)/,
            'list-sep'],

$rem,
    ],

directive => [
        [qr/\A(\S.*)/,
            'directive-value'],
        [qr/\A$EOL/,
            'directive-end', 'end']
    ],

regex => [
        [qr/\A$WS+(?:\+|\~\~|\-\-)/,
            'whitespace-must'],
        [qr/\A(?:\-|~)(?![-~])/,
            'whitespace-maybe'],
        $qr,
        [qr/\A$WS+()($NAME|<$NAME>)/,
            'rule-reference'],
        [qr/\A([^\s\'\/]+)/,
            'regex-raw'],
        [qr/\A$WS+/],
        [qr/\A$EOL+/],
        [qr/\A\//,
            'regex-end', 'end'],
        $rem,
    ],
};

sub lex {
    my ($self, $grammar) = @_;

my $tokens = $self->{tokens} = [['pegex-start']];
    my $stack = ['pegex'];
    my $pos = 0;

OUTER: while (1) {
        my $state = $stack->[-1];
        my $set = $self->{regexes}->{$state} or die "Invalid state '$state'";
        for my $entry (@$set) {
            my ($regex, $name, $scope) = @$entry;
            if (substr($grammar, $pos) =~ $regex) {
                $pos += length($&);
                if ($name) {
                    no strict 'refs';
                    my @captures = map $$_, 1..$#+;
                    pop @captures
                        while @captures and not defined $captures[-1];
                    push @$tokens, [$name, @captures];
                    if ($scope) {
                        if ($scope eq 'end') {
                            pop @$stack;
                        }
                        else {
                            push @$stack, $scope;
                            # Hack to support /+ â¦/
                            if ($scope eq 'regex') {
                                if (substr($grammar, $pos) =~ /\A\+(?=[\s\/])/) {
                                    $pos += length($&);
                                    push @$tokens, ['whitespace-must'];
                                }
                            }
                        }
                    }
                }
                last OUTER unless @$stack;
                next OUTER;
            }
        }
        my $text = substr($grammar, $pos, 50);
        $text =~ s/\n/\\n/g;
        WWW $tokens;
        die <<"...";
Failed to lex $state here-->$text
...
    }
}

1;

# vim: set lisp:

Batal

Isi Zip:

Create