File Coverage

inc/Pegex/Parser.pm
Criterion Covered Total %
statement 97 150 64.6
branch 45 86 52.3
condition 19 31 61.2
subroutine 12 18 66.6
pod 0 13 0.0
total 173 298 58.0


line stmt bran cond sub pod time code
1             package Pegex::Parser;
2 1     1   4 use Pegex::Base;
  1         2  
  1         7  
3              
4 1     1   1666 use Pegex::Input;
  1         2  
  1         28  
5 1     1   373 use Pegex::Optimizer;
  1         4  
  1         38  
6 1     1   8 use Scalar::Util;
  1         2  
  1         993  
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 13     13 0 1707 my ($self) = @_;
18 13   50     62 $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 14     14 0 184 my ($self, $input, $start) = @_;
32              
33 14 100       56 $start =~ s/-/_/g if $start;
34              
35 14         24 $self->{position} = 0;
36 14         28 $self->{farthest} = 0;
37              
38 14 50       65 $self->{input} = (not ref $input)
39             ? Pegex::Input->new(string => $input)
40             : $input;
41              
42 14 50       577 $self->{input}->open
43             unless $self->{input}{_is_open};
44 14         47 $self->{buffer} = $self->{input}->read;
45              
46 14 50       40 die "No 'grammar'. Can't parse"
47             unless $self->{grammar};
48              
49 14   66     83 $self->{grammar}{tree} ||= $self->{grammar}->make_tree;
50              
51 14 50 33     1840 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 14 50       47 die "No 'receiver'. Can't parse"
57             unless $self->{receiver};
58              
59 14         81 my $optimizer = Pegex::Optimizer->new(
60             parser => $self,
61             grammar => $self->{grammar},
62             receiver => $self->{receiver},
63             );
64              
65 14         675 $optimizer->optimize_grammar($start_rule_ref);
66              
67             # Add circular ref and weaken it.
68 14         38 $self->{receiver}{parser} = $self;
69 14         69 Scalar::Util::weaken($self->{receiver}{parser});
70              
71 14 50       80 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 14 50       44 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 14         59 $self->{input}->close;
83              
84 14 50 33     42 if (not $match or $self->{position} < length ${$self->{buffer}}) {
  14         57  
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 14 50       88 if ($self->{receiver}->can("final")) {
90 14         24 $self->{rule} = $start_rule_ref;
91 14         19 $self->{parent} = {};
92 14         92 $match = [ $self->{receiver}->final(@$match) ];
93             }
94              
95 14         763 $match->[0];
96             }
97              
98             sub match_next {
99 1575     1575 0 1360 my ($self, $next) = @_;
100              
101 1575         2927 my ($rule, $method, $kind, $min, $max, $assertion) =
102 1575         1294 @{$next}{'rule', 'method', 'kind', '+min', '+max', '+asr'};
103              
104 1575         1901 my ($position, $match, $count) =
105             ($self->{position}, [], 0);
106              
107 1575         1928 while (my $return = $method->($self, $rule, $next)) {
108 502 50       931 $position = $self->{position} unless $assertion;
109 502         358 $count++;
110 502         642 push @$match, @$return;
111 502 100       838 last if $max == 1;
112             }
113 1575 100 100     4591 if (not $count and $min == 0 and $kind eq 'all') {
      100        
114 4         9 $match = [[]];
115             }
116 1575 100       2029 if ($max != 1) {
117 40 100       95 if ($next->{-flat}) {
118 4 50       9 $match = [ map { (ref($_) eq 'ARRAY') ? (@$_) : ($_) } @$match ];
  4         15  
119             }
120             else {
121 36         55 $match = [$match]
122             }
123 40 50       80 $self->{farthest} = $position
124             if ($self->{position} = $position) > $self->{farthest};
125             }
126 1575   66     3355 my $result = ($count >= $min and (not $max or $count <= $max))
127             ^ ($assertion == -1);
128 1575 100 100     3152 if (not($result) or $assertion) {
129 1050 50       1734 $self->{farthest} = $position
130             if ($self->{position} = $position) > $self->{farthest};
131             }
132              
133 1575 100       4689 ($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 790     790 0 774 my ($self, $ref, $parent) = @_;
151 790 50       1599 my $rule = $self->{grammar}{tree}{$ref}
152             or die "No rule defined for '$ref'";
153 790 100       1073 my $match = $self->match_next($rule) or return;
154 252 50       436 return $Pegex::Constant::Dummy unless $rule->{action};
155 252         229 @{$self}{'rule', 'parent'} = ($ref, $parent);
  252         469  
156              
157             # XXX Possible API mismatch.
158             # Not sure if we should "splat" the $match.
159 252         742 [ $rule->{action}->($self->{receiver}, @$match) ];
160             }
161              
162             sub match_rgx {
163 544     544 0 453 my ($self, $regexp) = @_;
164 544         536 my $buffer = $self->{buffer};
165              
166 544         1015 pos($$buffer) = $self->{position};
167 544 100       3245 $$buffer =~ /$regexp/g or return;
168              
169 123         162 $self->{position} = pos($$buffer);
170              
171 123 50       258 $self->{farthest} = $self->{position}
172             if $self->{position} > $self->{farthest};
173              
174 1     1   8 no strict 'refs';
  1         116  
  1         944  
175 123         502 my $captures = [ map $$_, 1..$#+ ];
176 123 50       270 $captures = [ $captures ] if $#+ > 1;
177              
178 123         305 return $captures;
179             }
180              
181             sub match_all {
182 164     164 0 143 my ($self, $list) = @_;
183 164         158 my $position = $self->{position};
184 164         138 my $set = [];
185 164         136 my $len = 0;
186 164         187 for my $elem (@$list) {
187 316 100       446 if (my $match = $self->match_next($elem)) {
188 214 100 100     648 if (not ($elem->{'+asr'} or $elem->{'-skip'})) {
189 191         205 push @$set, @$match;
190 191         338 $len++;
191             }
192             }
193             else {
194 102 50       183 $self->{farthest} = $position
195             if ($self->{position} = $position) > $self->{farthest};
196 102         212 return;
197             }
198             }
199 62 50       135 $set = [ $set ] if $len > 1;
200 62         120 return $set;
201             }
202              
203             sub match_any {
204 129     129 0 145 my ($self, $list) = @_;
205 129         153 for my $elem (@$list) {
206 469 100       736 if (my $match = $self->match_next($elem)) {
207 79         169 return $match;
208             }
209             }
210 50         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;