File Coverage

blib/lib/MarpaX/Repa/Lexer.pm
Criterion Covered Total %
statement 89 119 74.7
branch 39 90 43.3
condition 23 40 57.5
subroutine 9 9 100.0
pod 6 6 100.0
total 166 264 62.8


line stmt bran cond sub pod time code
1 2     2   30 use 5.010;
  2         8  
2 2     2   10 use strict;
  2         4  
  2         32  
3 2     2   8 use warnings;
  2         3  
  2         2152  
4              
5             package MarpaX::Repa::Lexer;
6             our $VERSION = '0.01';
7              
8             =head1 NAME
9              
10             MarpaX::Repa::Lexer - simplify lexing for Marpa parser
11              
12             =head1 DESCRIPTION
13              
14             Most details are in L.
15              
16             =head1 METHODS
17              
18             =head2 new
19              
20             Returns a new lexer instance. Takes named arguments.
21              
22             my $lexer = MyLexer->new(
23             tokens => {
24             word => qr{\b\w+\b},
25             },
26             store => 'array',
27             debug => 1,
28             );
29              
30             Possible arguments:
31              
32             =over 4
33              
34             =item tokens
35              
36             Hash with names of terminals as keys and one of the
37             following as value:
38              
39             =over 4
40              
41             =item string
42              
43             Just a string to match.
44              
45             'a token' => "matches this long string",
46              
47             =item regular expression
48              
49             A C compiled regexp.
50              
51             'a token' => qr{"[^"]+"},
52              
53             Note that regexp MUST match at least one character. At this moment
54             look behind to look at chars before the current position is not
55             supported.
56              
57             =item hash
58              
59             With hash you can define token specific options. At this moment
60             'store' option only (see below). Use C key to set what to
61             match (string or regular expression):
62              
63             'a token' => {
64             match => "a string",
65             store => 'hash',
66             },
67              
68             Per token options are:
69              
70             =over 4
71              
72             =item store
73              
74             What to store (pass as value to Marpa's recognizer). The following variants
75             are supported:
76              
77             =over 4
78              
79             =item hash (default)
80              
81             { token => 'a token', value => 'a value' }
82              
83             =item array
84              
85             [ 'a token', 'a value' ]
86              
87             =item scalar
88              
89             'a value'
90              
91             =item undef
92              
93             undef is stored so later Repa's actions will skip it.
94              
95             =item a callback
96              
97             A function will be called with token name and reference to its value.
98             Should return a reference or undef that will be passed to recognizer.
99              
100             =back
101              
102             =item check
103              
104             A callback that can check whether token is really match or not.
105              
106             =back
107              
108             =back
109              
110             =item complete
111              
112             If true then parse should complete in one go and consume whole input.
113              
114             =item debug
115              
116             If true then lexer prints debug log to STDERR.
117              
118             =item min_buffer
119              
120             Minimal size of the buffer (4*1024 by default).
121              
122             =back
123              
124             =cut
125              
126             sub new {
127 9     9 1 19 my $proto = shift;
128 9   33     63 my $self = bless { @_ }, ref $proto || $proto;
129 9         24 return $self->init;
130             }
131              
132             =head2 init
133              
134             Setups instance and returns C<$self>. No need to call, it's called
135             from the constructor.
136              
137             =cut
138              
139             sub init {
140 9     9 1 17 my $self = shift;
141              
142 9         24 my $tokens = $self->{'tokens'};
143 9         28 foreach my $token ( keys %$tokens ) {
144 9         18 my ($match, @rest);
145 9 50       28 if ( ref( $tokens->{ $token } ) eq 'HASH' ) {
146 0         0 $match = $tokens->{ $token }{'match'};
147 0         0 @rest = (@{ $tokens->{ $token } }{'store','check'});
  0         0  
148             } else {
149 9         23 $match = $tokens->{ $token };
150             }
151 9   50     54 $rest[0] ||= $self->{'store'} || 'hash';
      33        
152 9 0       35 my $type =
    50          
153             ref $match ? 'RE'
154             : length $match == 1 ? 'CHAR'
155             : 'STRING';
156 9         33 $tokens->{ $token } = [ $type, $match, @rest ];
157             }
158              
159 9   50     46 $self->{'min_buffer'} //= 4*1024;
160 9   50     42 $self->{'buffer'} //= '';
161              
162 9         27 return $self;
163             }
164              
165             =head2 recognize
166              
167             Takes a recognizer and a file handle. Parses input. Dies on critical errors, but
168             not when parser lost its way. Returns recognizer that was passed.
169              
170             =cut
171              
172             sub recognize {
173 9     9 1 17 my $self = shift;
174 9         15 my $rec = shift;
175 9         13 my $fh = shift;
176              
177              
178 9         27 my $buffer = $self->buffer;
179 9         27 my $buffer_can_grow = $self->grow_buffer( $fh );
180              
181 9         31 my $expected = $rec->terminals_expected;
182 9 50       248 return $rec unless @$expected;
183              
184 9         24 while ( length $$buffer ) {
185             say STDERR "Expect token(s): ". join(', ', map "'$_'", @$expected)
186 10 50       29 if $self->{'debug'};
187              
188             say STDERR "Buffer start: ". $self->dump_buffer .'...'
189 10 50       24 if $self->{'debug'};
190              
191 10         19 my $longest = 0;
192 10         14 my @alternatives;
193 10         21 my $first_char = substr $$buffer, 0, 1;
194 10         22 foreach my $token ( @$expected ) {
195 13         25 REDO:
196              
197             my ($matched, $match, $length);
198 13 50       19 my ($type, $what, $how, $check) = @{ $self->{'tokens'}{ $token } || [] };
  13         45  
199              
200 13 0       43 unless ( $type ) {
    0          
    50          
    50          
201 0 0       0 say STDERR "Unknown token: '$token'" if $self->{'debug'};
202 0         0 next;
203             }
204 0         0 elsif ( $type eq 'RE' ) {
205 13 100       148 if ( $$buffer =~ /^($what)/ ) {
206 10         51 ($matched, $match, $length) = (1, $1, length $1);
207 10 100 100     45 if ( $length == length $$buffer && $buffer_can_grow ) {
208 3         8 $buffer_can_grow = $self->grow_buffer( $fh );
209 3         30 goto REDO;
210             }
211             }
212             }
213 0         0 elsif ( $type eq 'STRING' ) {
214 0         0 $length = length $what;
215 0 0       0 ($matched, $match) = (1, $what)
216             if $what eq substr $$buffer, 0, $length;
217             }
218 0         0 elsif ( $type eq 'CHAR' ) {
219 0 0       0 ($matched, $match, $length) = (1, $first_char, 1)
220             if $what eq $first_char;
221             }
222             else {
223 0         0 die "Unknown type $type";
224             }
225              
226 10 100       25 unless ( $matched ) {
227 3 50       12 say STDERR "No '$token' in ". $self->dump_buffer if $self->{'debug'};
228 3         8 next;
229             }
230              
231 7 50       16 unless ( $length ) {
232 0         0 die "Token '$token' matched empty string. This is not supported.";
233             }
234             say STDERR "Token '$token' matched ". $self->dump_buffer( $length )
235 7 50       19 if $self->{'debug'};
236              
237 7 50 33     26 if ( $check && !$check->( $self, $token, $match, $length ) ) {
238             say STDERR "\tCheck failed for '$token', skipping"
239 0 0       0 if $self->{'debug'};
240 0         0 next;
241             }
242              
243 7 50       18 if ( $self->{longest_expected} ) {
244 0 0       0 if ( $length > $longest ) {
    0          
245 0 0       0 say STDERR "New longest token of length $length" if $self->{'debug'};
246 0         0 @alternatives = (); $longest = $length;
  0         0  
247             } elsif ( $length < $longest ) {
248 0 0       0 say STDERR "Skipping $token token as it's short" if $self->{'debug'};
249 0         0 next;
250             }
251             }
252 7         30 push @alternatives, [$token, $how, $match, $length];
253             }
254              
255 10         18 foreach my $e ( @alternatives ) {
256 7         19 my ($token, $how, $match, $length) = @$e;
257 7 50       20 say STDERR "Accepting $token of length $length" if $self->{'debug'};
258              
259 7 50       33 if ( ref $how ) {
    50          
    50          
    50          
    0          
260 0         0 $match = $how->( $token, \"$match" );
261             } elsif ( $how eq 'hash' ) {
262 0         0 $match = \{ token => $token, value => $match };
263             } elsif ( $how eq 'array' ) {
264 0         0 $match = \[$token, $match];
265             } elsif ( $how eq 'scalar' ) {
266 7         17 $match = \"$match";
267             } elsif ( $how eq 'undef' ) {
268 0         0 $match = \undef;
269             } else {
270 0         0 die "Unknown store variant - '$how'";
271             }
272              
273 7         27 $rec->alternative( $token, $match, $length );
274             }
275              
276 10         364 my $skip = 0;
277 10         15 while (1) {
278             # XXX: we are done, no way to advance further, we would love this
279             # to be improved in Marpa
280 12 100       35 if ( $rec->current_earleme == $rec->thin->furthest_earleme ) {
281             die "Failed to parse: parser reached furthest earleme, but buffer is not empty - '". $self->dump_buffer . "'"
282 3 50 33     39 if $self->{complete} && (length $$buffer || $buffer_can_grow);
      66        
283 2         8 return $rec;
284             }
285              
286 9         102 $skip++;
287 9         26 local $@;
288 9 50       20 if ( defined (my $events = eval { $rec->earleme_complete }) ) {
  9         26  
289 9 100 66     364 if ( $events && $rec->exhausted ) {
290 5         55 substr $$buffer, 0, $skip, '';
291             die "Failed to parse: parser is exhausted, but buffer is not empty - '". $self->dump_buffer . "'"
292 5 100 66     22 if $self->{complete} && (length $$buffer || $buffer_can_grow);
      66        
293 4         18 return $rec;
294             }
295 4         12 $expected = $rec->terminals_expected;
296 4 100       66 last if @$expected;
297             } else {
298 0 0       0 say STDERR "Failed to parse: $@" if $self->{'debug'};
299 0 0       0 die "Failed to parse: $@" if $self->{complete};
300 0         0 return $rec;
301             }
302             }
303 2         6 substr $$buffer, 0, $skip, '';
304             $buffer_can_grow = $self->grow_buffer( $fh )
305 2 100 66     13 if $buffer_can_grow && $self->{'min_buffer'} > length $$buffer;
306              
307 2 50       19 say STDERR '' if $self->{'debug'};
308             }
309 1         3 return $rec;
310             }
311              
312             =head2 buffer
313              
314             Returns reference to the current buffer.
315              
316             =cut
317              
318 15     15 1 4958 sub buffer { \$_[0]->{'buffer'} }
319              
320             =head2 grow_buffer
321              
322             Called when L needs a re-fill with a file handle as argument.
323             Returns true if there is still data to come from the handle.
324              
325             =cut
326              
327             sub grow_buffer {
328 13     13 1 22 my $self = shift;
329 13 50       65 local $/ = $self->{'min_buffer'}? \($self->{'min_buffer'}*2) : undef;
330 13   100     83 $self->{'buffer'} .= readline($_[0]) // return 0;
331 8         27 return 1 && $self->{'min_buffer'};
332             }
333              
334             =head2 dump_buffer
335              
336             Returns first 20 chars of the buffer with everything besides ASCII encoded
337             with C<\x{####}>. Use argument to control size, zero to mean whole buffer.
338              
339             =cut
340              
341             sub dump_buffer {
342 2     2 1 4 my $self = shift;
343 2   50     8 my $show = shift // 20;
344 2 50       8 my $str = $show? substr( $self->{'buffer'}, 0, $show ) : $self->{'buffer'};
345 2         6 (my $res = $str) =~ s/([^\x20-\x7E])/'\\x{'. hex( ord $1 ) .'}' /ge;
  0         0  
346 2         47 return $res;
347             }
348              
349             1;