?????????? ????????? - ??????????????? - /home/.cpan/build/Template-Toolkit-Simple-0.31-0/inc/Pegex/Parser.pm
???????
package Pegex::Parser; use Pegex::Base; use Pegex::Input; use Pegex::Optimizer; use Scalar::Util; has grammar => (required => 1); has receiver => (); has input => (); has debug => ( exists($ENV{PERL_PEGEX_DEBUG}) ? $ENV{PERL_PEGEX_DEBUG} : defined($Pegex::Parser::Debug) ? $Pegex::Parser::Debug : 0 ); sub BUILD { my ($self) = @_; $self->{throw_on_error} ||= 1; # $self->{rule} = undef; # $self->{parent} = undef; # $self->{error} = undef; # $self->{position} = undef; # $self->{farthest} = undef; } # XXX Add an optional $position argument. Default to 0. This is the position # to start parsing. Set position and farthest below to this value. Allows for # sub-parsing. Need to somehow return the finishing position of a subparse. # Maybe this all goes in a subparse() method. sub parse { my ($self, $input, $start) = @_; $start =~ s/-/_/g if $start; $self->{position} = 0; $self->{farthest} = 0; $self->{input} = (not ref $input) ? Pegex::Input->new(string => $input) : $input; $self->{input}->open unless $self->{input}{_is_open}; $self->{buffer} = $self->{input}->read; die "No 'grammar'. Can't parse" unless $self->{grammar}; $self->{grammar}{tree} ||= $self->{grammar}->make_tree; my $start_rule_ref = $start || $self->{grammar}{tree}{'+toprule'} || $self->{grammar}{tree}{'TOP'} & 'TOP' or die "No starting rule for Pegex::Parser::parse"; die "No 'receiver'. Can't parse" unless $self->{receiver}; my $optimizer = Pegex::Optimizer->new( parser => $self, grammar => $self->{grammar}, receiver => $self->{receiver}, ); $optimizer->optimize_grammar($start_rule_ref); # Add circular ref and weaken it. $self->{receiver}{parser} = $self; Scalar::Util::weaken($self->{receiver}{parser}); if ($self->{receiver}->can("initial")) { $self->{rule} = $start_rule_ref; $self->{parent} = {}; $self->{receiver}->initial(); } my $match = $self->debug ? do { my $method = $optimizer->make_trace_wrapper(\&match_ref); $self->$method($start_rule_ref, {'+asr' => 0}); } : $self->match_ref($start_rule_ref, {}); $self->{input}->close; if (not $match or $self->{position} < length ${$self->{buffer}}) { $self->throw_error("Parse document failed for some reason"); return; # In case $self->throw_on_error is off } if ($self->{receiver}->can("final")) { $self->{rule} = $start_rule_ref; $self->{parent} = {}; $match = [ $self->{receiver}->final(@$match) ]; } $match->[0]; } sub match_next { my ($self, $next) = @_; my ($rule, $method, $kind, $min, $max, $assertion) = @{$next}{'rule', 'method', 'kind', '+min', '+max', '+asr'}; my ($position, $match, $count) = ($self->{position}, [], 0); while (my $return = $method->($self, $rule, $next)) { $position = $self->{position} unless $assertion; $count++; push @$match, @$return; last if $max == 1; } if (not $count and $min == 0 and $kind eq 'all') { $match = [[]]; } if ($max != 1) { if ($next->{-flat}) { $match = [ map { (ref($_) eq 'ARRAY') ? (@$_) : ($_) } @$match ]; } else { $match = [$match] } $self->{farthest} = $position if ($self->{position} = $position) > $self->{farthest}; } my $result = ($count >= $min and (not $max or $count <= $max)) ^ ($assertion == -1); if (not($result) or $assertion) { $self->{farthest} = $position if ($self->{position} = $position) > $self->{farthest}; } ($result ? $next->{'-skip'} ? [] : $match : 0); } sub match_rule { my ($self, $position, $match) = (@_, []); $self->{position} = $position; $self->{farthest} = $position if $position > $self->{farthest}; $match = [ $match ] if @$match > 1; my ($ref, $parent) = @{$self}{'rule', 'parent'}; my $rule = $self->{grammar}{tree}{$ref} or die "No rule defined for '$ref'"; [ $rule->{action}->($self->{receiver}, @$match) ]; } sub match_ref { my ($self, $ref, $parent) = @_; my $rule = $self->{grammar}{tree}{$ref} or die "No rule defined for '$ref'"; my $match = $self->match_next($rule) or return; return $Pegex::Constant::Dummy unless $rule->{action}; @{$self}{'rule', 'parent'} = ($ref, $parent); # XXX Possible API mismatch. # Not sure if we should "splat" the $match. [ $rule->{action}->($self->{receiver}, @$match) ]; } sub match_rgx { my ($self, $regexp) = @_; my $buffer = $self->{buffer}; pos($$buffer) = $self->{position}; $$buffer =~ /$regexp/g or return; $self->{position} = pos($$buffer); $self->{farthest} = $self->{position} if $self->{position} > $self->{farthest}; no strict 'refs'; my $captures = [ map $$_, 1..$#+ ]; $captures = [ $captures ] if $#+ > 1; return $captures; } sub match_all { my ($self, $list) = @_; my $position = $self->{position}; my $set = []; my $len = 0; for my $elem (@$list) { if (my $match = $self->match_next($elem)) { if (not ($elem->{'+asr'} or $elem->{'-skip'})) { push @$set, @$match; $len++; } } else { $self->{farthest} = $position if ($self->{position} = $position) > $self->{farthest}; return; } } $set = [ $set ] if $len > 1; return $set; } sub match_any { my ($self, $list) = @_; for my $elem (@$list) { if (my $match = $self->match_next($elem)) { return $match; } } return; } sub match_err { my ($self, $error) = @_; $self->throw_error($error); } sub trace { my ($self, $action) = @_; my $indent = ($action =~ /^try_/) ? 1 : 0; $self->{indent} ||= 0; $self->{indent}-- unless $indent; print STDERR ' ' x $self->{indent}; $self->{indent}++ if $indent; my $snippet = substr(${$self->{buffer}}, $self->{position}); $snippet = substr($snippet, 0, 30) . "..." if length $snippet > 30; $snippet =~ s/\n/\\n/g; print STDERR sprintf("%-30s", $action) . ($indent ? " >$snippet<\n" : "\n"); } sub throw_error { my ($self, $msg) = @_; $@ = $self->{error} = $self->format_error($msg); return undef unless $self->{throw_on_error}; require Carp; Carp::croak($self->{error}); } sub format_error { my ($self, $msg) = @_; my $buffer = $self->{buffer}; my $position = $self->{farthest}; my $real_pos = $self->{position}; my $line = @{[substr($$buffer, 0, $position) =~ /(\n)/g]} + 1; my $column = $position - rindex($$buffer, "\n", $position); my $pretext = substr( $$buffer, $position < 50 ? 0 : $position - 50, $position < 50 ? $position : 50 ); my $context = substr($$buffer, $position, 50); $pretext =~ s/.*\n//gs; $context =~ s/\n/\\n/g; return <<"..."; Error parsing Pegex document: msg: $msg line: $line column: $column context: $pretext$context ${\ (' ' x (length($pretext) + 10) . '^')} position: $position ($real_pos pre-lookahead) ... } # TODO Move this to a Parser helper role/subclass sub line_column { my ($self, $position) = @_; $position ||= $self->{position}; my $buffer = $self->{buffer}; my $line = @{[substr($$buffer, 0, $position) =~ /(\n)/g]} + 1; my $column = $position - rindex($$buffer, "\n", $position); return [$line, $position]; } # XXX Need to figure out what uses this. (sample.t) { package Pegex::Constant; our $Null = []; our $Dummy = []; } 1;
| ver. 1.6 |
Github
|
.
| PHP 8.2.30 | ??????????? ?????????: 0 |
proxy
|
phpinfo
|
???????????