File Coverage

inc/Pegex/Parser.pm
Criterion Covered Total %
statement 95 150 63.3
branch 43 86 50.0
condition 18 31 58.0
subroutine 12 18 66.6
pod 0 13 0.0
total 168 298 56.3


line stmt bran cond sub pod time code
1             package Pegex::Parser;
2 4     4   19 use Pegex::Base;
  4         5  
  4         25  
3              
4 4     4   1210 use Pegex::Input;
  4         10  
  4         135  
5 4     4   1410 use Pegex::Optimizer;
  4         11  
  4         147  
6 4     4   27 use Scalar::Util;
  4         7  
  4         5310  
7              
8             has grammar => (required => 1);
9             has receiver => ();
10             has input => ();
11             has debug => (
12             exists($ENV{PERL_PEGEX_DEBUG}) ? $ENV{PERL_PEGEX_DEBUG} :
13             defined($Pegex::Parser::Debug) ? $Pegex::Parser::Debug :
14             0
15             );
16             sub BUILD {
17 4     4 0 8 my ($self) = @_;
18 4   50     33 $self->{throw_on_error} ||= 1;
19             # $self->{rule} = undef;
20             # $self->{parent} = undef;
21             # $self->{error} = undef;
22             # $self->{position} = undef;
23             # $self->{farthest} = undef;
24             }
25              
26             # XXX Add an optional $position argument. Default to 0. This is the position
27             # to start parsing. Set position and farthest below to this value. Allows for
28             # sub-parsing. Need to somehow return the finishing position of a subparse.
29             # Maybe this all goes in a subparse() method.
30             sub parse {
31 8     8 0 19 my ($self, $input, $start) = @_;
32              
33 8 50       38 $start =~ s/-/_/g if $start;
34              
35 8         22 $self->{position} = 0;
36 8         19 $self->{farthest} = 0;
37              
38 8 50       65 $self->{input} = (not ref $input)
39             ? Pegex::Input->new(string => $input)
40             : $input;
41              
42 8 50       118 $self->{input}->open
43             unless $self->{input}{_is_open};
44 8         36 $self->{buffer} = $self->{input}->read;
45              
46 8 50       31 die "No 'grammar'. Can't parse"
47             unless $self->{grammar};
48              
49 8   33     34 $self->{grammar}{tree} ||= $self->{grammar}->make_tree;
50              
51 8 50 33     48 my $start_rule_ref = $start ||
52             $self->{grammar}{tree}{'+toprule'} ||
53             $self->{grammar}{tree}{'TOP'} & 'TOP' or
54             die "No starting rule for Pegex::Parser::parse";
55              
56 8 50       56 die "No 'receiver'. Can't parse"
57             unless $self->{receiver};
58              
59 8         54 my $optimizer = Pegex::Optimizer->new(
60             parser => $self,
61             grammar => $self->{grammar},
62             receiver => $self->{receiver},
63             );
64              
65 8         47 $optimizer->optimize_grammar($start_rule_ref);
66              
67             # Add circular ref and weaken it.
68 8         28 $self->{receiver}{parser} = $self;
69 8         44 Scalar::Util::weaken($self->{receiver}{parser});
70              
71 8 50       74 if ($self->{receiver}->can("initial")) {
72 0         0 $self->{rule} = $start_rule_ref;
73 0         0 $self->{parent} = {};
74 0         0 $self->{receiver}->initial();
75             }
76              
77 8 50       54 my $match = $self->debug ? do {
78 0         0 my $method = $optimizer->make_trace_wrapper(\&match_ref);
79 0         0 $self->$method($start_rule_ref, {'+asr' => 0});
80             } : $self->match_ref($start_rule_ref, {});
81              
82 8         94 $self->{input}->close;
83              
84 8 50 33     540 if (not $match or $self->{position} < length ${$self->{buffer}}) {
  8         47  
85 0         0 $self->throw_error("Parse document failed for some reason");
86 0         0 return; # In case $self->throw_on_error is off
87             }
88              
89 8 50       82 if ($self->{receiver}->can("final")) {
90 8         19 $self->{rule} = $start_rule_ref;
91 8         15 $self->{parent} = {};
92 8         37 $match = [ $self->{receiver}->final(@$match) ];
93             }
94              
95 8         151 $match->[0];
96             }
97              
98             sub match_next {
99 1139     1139 0 1062 my ($self, $next) = @_;
100              
101 1139         2612 my ($rule, $method, $kind, $min, $max, $assertion) =
102 1139         971 @{$next}{'rule', 'method', 'kind', '+min', '+max', '+asr'};
103              
104 1139         1667 my ($position, $match, $count) =
105             ($self->{position}, [], 0);
106              
107 1139         1743 while (my $return = $method->($self, $rule, $next)) {
108 502 50       930 $position = $self->{position} unless $assertion;
109 502         399 $count++;
110 502         646 push @$match, @$return;
111 502 100       976 last if $max == 1;
112             }
113 1139 100 100     3645 if (not $count and $min == 0 and $kind eq 'all') {
      100        
114 1         6 $match = [[]];
115             }
116 1139 100       1643 if ($max != 1) {
117 32 50       95 if ($next->{-flat}) {
118 0 0       0 $match = [ map { (ref($_) eq 'ARRAY') ? (@$_) : ($_) } @$match ];
  0         0  
119             }
120             else {
121 32         56 $match = [$match]
122             }
123 32 50       90 $self->{farthest} = $position
124             if ($self->{position} = $position) > $self->{farthest};
125             }
126 1139   66     3195 my $result = ($count >= $min and (not $max or $count <= $max))
127             ^ ($assertion == -1);
128 1139 100 100     2813 if (not($result) or $assertion) {
129 617 50       1202 $self->{farthest} = $position
130             if ($self->{position} = $position) > $self->{farthest};
131             }
132              
133 1139 100       4137 ($result ? $next->{'-skip'} ? [] : $match : 0);
    100          
134             }
135              
136             sub match_rule {
137 0     0 0 0 my ($self, $position, $match) = (@_, []);
138 0         0 $self->{position} = $position;
139 0 0       0 $self->{farthest} = $position
140             if $position > $self->{farthest};
141 0 0       0 $match = [ $match ] if @$match > 1;
142 0         0 my ($ref, $parent) = @{$self}{'rule', 'parent'};
  0         0  
143 0 0       0 my $rule = $self->{grammar}{tree}{$ref}
144             or die "No rule defined for '$ref'";
145              
146 0         0 [ $rule->{action}->($self->{receiver}, @$match) ];
147             }
148              
149             sub match_ref {
150 572     572 0 597 my ($self, $ref, $parent) = @_;
151 572 50       1534 my $rule = $self->{grammar}{tree}{$ref}
152             or die "No rule defined for '$ref'";
153 572 100       925 my $match = $self->match_next($rule) or return;
154 239 50       465 return $Pegex::Constant::Dummy unless $rule->{action};
155 239         232 @{$self}{'rule', 'parent'} = ($ref, $parent);
  239         507  
156              
157             # XXX Possible API mismatch.
158             # Not sure if we should "splat" the $match.
159 239         839 [ $rule->{action}->($self->{receiver}, @$match) ];
160             }
161              
162             sub match_rgx {
163 336     336 0 339 my ($self, $regexp) = @_;
164 336         386 my $buffer = $self->{buffer};
165              
166 336         702 pos($$buffer) = $self->{position};
167 336 100       2787 $$buffer =~ /$regexp/g or return;
168              
169 140         208 $self->{position} = pos($$buffer);
170              
171 140 100       306 $self->{farthest} = $self->{position}
172             if $self->{position} > $self->{farthest};
173              
174 4     4   35 no strict 'refs';
  4         6  
  4         4206  
175 140         567 my $captures = [ map $$_, 1..$#+ ];
176 140 50       296 $captures = [ $captures ] if $#+ > 1;
177              
178 140         366 return $captures;
179             }
180              
181             sub match_all {
182 170     170 0 190 my ($self, $list) = @_;
183 170         201 my $position = $self->{position};
184 170         197 my $set = [];
185 170         161 my $len = 0;
186 170         223 for my $elem (@$list) {
187 339 100       718 if (my $match = $self->match_next($elem)) {
188 232 100 100     814 if (not ($elem->{'+asr'} or $elem->{'-skip'})) {
189 209         261 push @$set, @$match;
190 209         416 $len++;
191             }
192             }
193             else {
194 107 50       221 $self->{farthest} = $position
195             if ($self->{position} = $position) > $self->{farthest};
196 107         265 return;
197             }
198             }
199 63 50       167 $set = [ $set ] if $len > 1;
200 63         151 return $set;
201             }
202              
203             sub match_any {
204 109     109 0 118 my ($self, $list) = @_;
205 109         158 for my $elem (@$list) {
206 228 100       423 if (my $match = $self->match_next($elem)) {
207 68         183 return $match;
208             }
209             }
210 41         102 return;
211             }
212              
213             sub match_err {
214 0     0 0   my ($self, $error) = @_;
215 0           $self->throw_error($error);
216             }
217              
218             sub trace {
219 0     0 0   my ($self, $action) = @_;
220 0 0         my $indent = ($action =~ /^try_/) ? 1 : 0;
221 0   0       $self->{indent} ||= 0;
222 0 0         $self->{indent}-- unless $indent;
223 0           print STDERR ' ' x $self->{indent};
224 0 0         $self->{indent}++ if $indent;
225 0           my $snippet = substr(${$self->{buffer}}, $self->{position});
  0            
226 0 0         $snippet = substr($snippet, 0, 30) . "..."
227             if length $snippet > 30;
228 0           $snippet =~ s/\n/\\n/g;
229 0 0         print STDERR sprintf("%-30s", $action) .
230             ($indent ? " >$snippet<\n" : "\n");
231             }
232              
233             sub throw_error {
234 0     0 0   my ($self, $msg) = @_;
235 0           $@ = $self->{error} = $self->format_error($msg);
236 0 0         return undef unless $self->{throw_on_error};
237 0           require Carp;
238 0           Carp::croak($self->{error});
239             }
240              
241             sub format_error {
242 0     0 0   my ($self, $msg) = @_;
243 0           my $buffer = $self->{buffer};
244 0           my $position = $self->{farthest};
245 0           my $real_pos = $self->{position};
246              
247 0           my $line = @{[substr($$buffer, 0, $position) =~ /(\n)/g]} + 1;
  0            
248 0           my $column = $position - rindex($$buffer, "\n", $position);
249              
250 0 0         my $pretext = substr(
    0          
251             $$buffer,
252             $position < 50 ? 0 : $position - 50,
253             $position < 50 ? $position : 50
254             );
255 0           my $context = substr($$buffer, $position, 50);
256 0           $pretext =~ s/.*\n//gs;
257 0           $context =~ s/\n/\\n/g;
258              
259 0           return <<"...";
260             Error parsing Pegex document:
261 0           msg: $msg
262             line: $line
263             column: $column
264             context: $pretext$context
265             ${\ (' ' x (length($pretext) + 10) . '^')}
266             position: $position ($real_pos pre-lookahead)
267             ...
268             }
269              
270             # TODO Move this to a Parser helper role/subclass
271             sub line_column {
272 0     0 0   my ($self, $position) = @_;
273 0   0       $position ||= $self->{position};
274 0           my $buffer = $self->{buffer};
275 0           my $line = @{[substr($$buffer, 0, $position) =~ /(\n)/g]} + 1;
  0            
276 0           my $column = $position - rindex($$buffer, "\n", $position);
277 0           return [$line, $position];
278             }
279              
280             # XXX Need to figure out what uses this. (sample.t)
281             {
282             package Pegex::Constant;
283             our $Null = [];
284             our $Dummy = [];
285             }
286              
287             1;