File Coverage

blib/lib/YAML/PP/Lexer.pm
Criterion Covered Total %
statement 532 554 96.0
branch 244 260 93.8
condition 42 44 95.4
subroutine 35 36 97.2
pod 0 24 0.0
total 853 918 92.9


line stmt bran cond sub pod time code
1 42     42   315 use strict;
  42         86  
  42         1225  
2 42     42   242 use warnings;
  42         140  
  42         2619  
3             package YAML::PP::Lexer;
4              
5             our $VERSION = '0.036_001'; # TRIAL VERSION
6              
7 42 50   42   287 use constant TRACE => $ENV{YAML_PP_TRACE} ? 1 : 0;
  42         75  
  42         3543  
8 42 100 66 42   342 use constant DEBUG => ($ENV{YAML_PP_DEBUG} || $ENV{YAML_PP_TRACE}) ? 1 : 0;
  42         114  
  42         2842  
9              
10 42     42   24377 use YAML::PP::Grammar qw/ $GRAMMAR /;
  42         249  
  42         5636  
11 42     42   330 use Carp qw/ croak /;
  42         89  
  42         280061  
12              
13             sub new {
14 4667     4667 0 11779 my ($class, %args) = @_;
15             my $self = bless {
16             reader => $args{reader},
17 4667         12236 }, $class;
18 4667         12424 $self->init;
19 4667         15308 return $self;
20             }
21              
22             sub init {
23 19809     19809 0 30407 my ($self) = @_;
24 19809         33729 $self->{next_tokens} = [];
25 19809         29890 $self->{next_line} = undef;
26 19809         29268 $self->{line} = 0;
27 19809         26661 $self->{offset} = 0;
28 19809         33418 $self->{flowcontext} = 0;
29             }
30              
31 74547     74547 0 119332 sub next_line { return $_[0]->{next_line} }
32 70113     70113 0 111094 sub set_next_line { $_[0]->{next_line} = $_[1] }
33 41017     41017 0 110044 sub reader { return $_[0]->{reader} }
34 7571     7571 0 22969 sub set_reader { $_[0]->{reader} = $_[1] }
35 130652     130652 0 211422 sub next_tokens { return $_[0]->{next_tokens} }
36 272976     272976 0 547210 sub line { return $_[0]->{line} }
37 0     0 0 0 sub set_line { $_[0]->{line} = $_[1] }
38 91158     91158 0 135761 sub offset { return $_[0]->{offset} }
39 91056     91056 0 145903 sub set_offset { $_[0]->{offset} = $_[1] }
40 29195     29195 0 48671 sub inc_line { return $_[0]->{line}++ }
41 67864     67864 0 142959 sub context { return $_[0]->{context} }
42 3870     3870 0 7158 sub set_context { $_[0]->{context} = $_[1] }
43 107290     107290 0 270116 sub flowcontext { return $_[0]->{flowcontext} }
44 4931     4931 0 8672 sub set_flowcontext { $_[0]->{flowcontext} = $_[1] }
45 17857     17857 0 53847 sub block { return $_[0]->{block} }
46 29275     29275 0 49801 sub set_block { $_[0]->{block} = $_[1] }
47              
48             my $RE_WS = '[\t ]';
49             my $RE_LB = '[\r\n]';
50             my $RE_DOC_END = qr/\A(\.\.\.)(?=$RE_WS|$)/m;
51             my $RE_DOC_START = qr/\A(---)(?=$RE_WS|$)/m;
52             my $RE_EOL = qr/\A($RE_WS+#.*|$RE_WS+)\z/;
53             #my $RE_COMMENT_EOL = qr/\A(#.*)?(?:$RE_LB|\z)/;
54              
55             #ns-word-char ::= ns-dec-digit | ns-ascii-letter | “-”
56             my $RE_NS_WORD_CHAR = '[0-9A-Za-z-]';
57             my $RE_URI_CHAR = '(?:' . '%[0-9a-fA-F]{2}' .'|'. q{[0-9A-Za-z#;/?:@&=+$,_.!*'\(\)\[\]-]} . ')';
58             my $RE_NS_TAG_CHAR = '(?:' . '%[0-9a-fA-F]{2}' .'|'. q{[0-9A-Za-z#;/?:@&=+$_.~*'\(\)-]} . ')';
59              
60             # [#x21-#x7E] /* 8 bit */
61             # | #x85 | [#xA0-#xD7FF] | [#xE000-#xFFFD] /* 16 bit */
62             # | [#x10000-#x10FFFF] /* 32 bit */
63              
64             #nb-char ::= c-printable - b-char - c-byte-order-mark
65             #my $RE_NB_CHAR = '[\x21-\x7E]';
66             my $RE_ANCHOR_CAR = '[\x21-\x2B\x2D-\x5A\x5C\x5E-\x7A\x7C\x7E\xA0-\xFF\x{100}-\x{10FFFF}]';
67              
68             my $RE_PLAIN_START = '[\x21\x22\x24-\x39\x3B-\x7E\xA0-\xFF\x{100}-\x{10FFFF}]';
69             my $RE_PLAIN_END = '[\x21-\x39\x3B-\x7E\x85\xA0-\x{D7FF}\x{E000}-\x{FEFE}\x{FF00}-\x{FFFD}\x{10000}-\x{10FFFF}]';
70             my $RE_PLAIN_FIRST = '[\x24\x28-\x29\x2B\x2E-\x39\x3B-\x3D\x41-\x5A\x5C\x5E-\x5F\x61-\x7A\x7E\xA0-\xFF\x{100}-\x{10FFFF}]';
71              
72             my $RE_PLAIN_START_FLOW = '[\x21\x22\x24-\x2B\x2D-\x39\x3B-\x5A\x5C\x5E-\x7A\x7C\x7E\xA0-\xFF\x{100}-\x{10FFFF}]';
73             my $RE_PLAIN_END_FLOW = '[\x21-\x2B\x2D-\x39\x3B-\x5A\x5C\x5E-\x7A\x7C\x7E\x85\xA0-\x{D7FF}\x{E000}-\x{FEFE}\x{FF00}-\x{FFFD}\x{10000}-\x{10FFFF}]';
74             my $RE_PLAIN_FIRST_FLOW = '[\x24\x28-\x29\x2B\x2E-\x39\x3B-\x3D\x41-\x5A\x5C\x5E-\x5F\x61-\x7A\x7C\x7E\xA0-\xFF\x{100}-\x{10FFFF}]';
75             # c-indicators
76             #! 21
77             #" 22
78             ## 23
79             #% 25
80             #& 26
81             #' 27
82             #* 2A
83             #, 2C FLOW
84             #- 2D XX
85             #: 3A XX
86             #> 3E
87             #? 3F XX
88             #@ 40
89             #[ 5B FLOW
90             #] 5D FLOW
91             #` 60
92             #{ 7B FLOW
93             #| 7C
94             #} 7D FLOW
95              
96              
97             my $RE_PLAIN_WORD = "(?::+$RE_PLAIN_END|$RE_PLAIN_START)(?::+$RE_PLAIN_END|$RE_PLAIN_END)*";
98             my $RE_PLAIN_FIRST_WORD = "(?:[:?-]+$RE_PLAIN_END|$RE_PLAIN_FIRST)(?::+$RE_PLAIN_END|$RE_PLAIN_END)*";
99             my $RE_PLAIN_WORDS = "(?:$RE_PLAIN_FIRST_WORD(?:$RE_WS+$RE_PLAIN_WORD)*)";
100             my $RE_PLAIN_WORDS2 = "(?:$RE_PLAIN_WORD(?:$RE_WS+$RE_PLAIN_WORD)*)";
101              
102             my $RE_PLAIN_WORD_FLOW = "(?::+$RE_PLAIN_END_FLOW|$RE_PLAIN_START_FLOW)(?::+$RE_PLAIN_END_FLOW|$RE_PLAIN_END_FLOW)*";
103             my $RE_PLAIN_FIRST_WORD_FLOW = "(?:[:?-]+$RE_PLAIN_END_FLOW|$RE_PLAIN_FIRST_FLOW)(?::+$RE_PLAIN_END_FLOW|$RE_PLAIN_END_FLOW)*";
104             my $RE_PLAIN_WORDS_FLOW = "(?:$RE_PLAIN_FIRST_WORD_FLOW(?:$RE_WS+$RE_PLAIN_WORD_FLOW)*)";
105             my $RE_PLAIN_WORDS_FLOW2 = "(?:$RE_PLAIN_WORD_FLOW(?:$RE_WS+$RE_PLAIN_WORD_FLOW)*)";
106              
107              
108             #c-secondary-tag-handle ::= “!” “!”
109             #c-named-tag-handle ::= “!” ns-word-char+ “!”
110             #ns-tag-char ::= ns-uri-char - “!” - c-flow-indicator
111             #ns-global-tag-prefix ::= ns-tag-char ns-uri-char*
112             #c-ns-local-tag-prefix ::= “!” ns-uri-char*
113             my $RE_TAG = "!(?:$RE_NS_WORD_CHAR*!$RE_NS_TAG_CHAR+|$RE_NS_TAG_CHAR+|<$RE_URI_CHAR+>|)";
114              
115             #c-ns-anchor-property ::= “&” ns-anchor-name
116             #ns-char ::= nb-char - s-white
117             #ns-anchor-char ::= ns-char - c-flow-indicator
118             #ns-anchor-name ::= ns-anchor-char+
119              
120             my $RE_SEQSTART = qr/\A(-)(?=$RE_WS|$)/m;
121             my $RE_COMPLEX = qr/(\?)(?=$RE_WS|$)/m;
122             my $RE_COMPLEXCOLON = qr/\A(:)(?=$RE_WS|$)/m;
123             my $RE_ANCHOR = "&$RE_ANCHOR_CAR+";
124             my $RE_ALIAS = "\\*$RE_ANCHOR_CAR+";
125              
126              
127             my %REGEXES = (
128             ANCHOR => qr{($RE_ANCHOR)},
129             TAG => qr{($RE_TAG)},
130             ALIAS => qr{($RE_ALIAS)},
131             SINGLEQUOTED => qr{(?:''|[^'\r\n]+)*},
132             );
133              
134             sub _fetch_next_line {
135 47463     47463   74759 my ($self) = @_;
136 47463         85778 my $next_line = $self->next_line;
137 47463 100       92657 if (defined $next_line ) {
138 6446         12120 return $next_line;
139             }
140              
141 41017         71775 my $line = $self->reader->readline;
142 41017 100       90234 unless (defined $line) {
143 11822         27629 $self->set_next_line(undef);
144 11822         22533 return;
145             }
146 29195         72557 $self->set_block(1);
147 29195         63731 $self->inc_line;
148 29195 50       104475 $line =~ m/\A( *)([^\r\n]*)([\r\n]|\z)/ or die "Unexpected";
149 29195         94541 $next_line = [ $1, $2, $3 ];
150 29195         68765 $self->set_next_line($next_line);
151             # $ESCAPE_CHAR from YAML.pm
152 29195 100       74631 if ($line =~ tr/\x00-\x08\x0b-\x0c\x0e-\x1f//) {
153 29         69 $self->exception("Control characters are not allowed");
154             }
155              
156 29166         59727 return $next_line;
157             }
158              
159             my %TOKEN_NAMES = (
160             '"' => 'DOUBLEQUOTE',
161             "'" => 'SINGLEQUOTE',
162             '|' => 'LITERAL',
163             '>' => 'FOLDED',
164             '!' => 'TAG',
165             '*' => 'ALIAS',
166             '&' => 'ANCHOR',
167             ':' => 'COLON',
168             '-' => 'DASH',
169             '?' => 'QUESTION',
170             '[' => 'FLOWSEQ_START',
171             ']' => 'FLOWSEQ_END',
172             '{' => 'FLOWMAP_START',
173             '}' => 'FLOWMAP_END',
174             ',' => 'FLOW_COMMA',
175             '---' => 'DOC_START',
176             '...' => 'DOC_END',
177             );
178              
179              
180             sub fetch_next_tokens {
181 31900     31900 0 52895 my ($self) = @_;
182 31900         58044 my $next = $self->next_tokens;
183 31900 100       67888 return $next if @$next;
184              
185 31102         58413 my $next_line = $self->_fetch_next_line;
186 31073 100       60958 if (not $next_line) {
187 7425         18585 return [];
188             }
189              
190 23648         38536 my $spaces = $next_line->[0];
191 23648         38452 my $yaml = \$next_line->[1];
192 23648 100       55504 if (not length $$yaml) {
193 157         709 $self->_push_tokens([ EOL => join('', @$next_line), $self->line ]);
194 157         557 $self->set_next_line(undef);
195 157         478 return $next;
196             }
197 23491 100       61181 if (substr($$yaml, 0, 1) eq '#') {
198 546         2255 $self->_push_tokens([ EOL => join('', @$next_line), $self->line ]);
199 546         1848 $self->set_next_line(undef);
200 546         1878 return $next;
201             }
202 22945 100 100     82789 if (not $spaces and substr($$yaml, 0, 1) eq "%") {
203 326         1465 $self->_fetch_next_tokens_directive($yaml, $next_line->[2]);
204 326         1017 $self->set_context(0);
205 326         809 $self->set_next_line(undef);
206 326         1110 return $next;
207             }
208 22619 100 100     150919 if (not $spaces and $$yaml =~ s/\A(---|\.\.\.)(?=$RE_WS|\z)//) {
    100 100        
209 4269         16627 $self->_push_tokens([ $TOKEN_NAMES{ $1 } => $1, $self->line ]);
210             }
211             elsif ($self->flowcontext and $$yaml =~ m/\A[ \t]+(#.*)?\z/) {
212 59         306 $self->_push_tokens([ EOL => join('', @$next_line), $self->line ]);
213 59         210 $self->set_next_line(undef);
214 59         198 return $next;
215             }
216             else {
217 18291         37338 $self->_push_tokens([ SPACE => $spaces, $self->line ]);
218             }
219              
220 22560         56553 my $partial = $self->_fetch_next_tokens($next_line);
221 22554 100       47506 unless ($partial) {
222 4686         9320 $self->set_next_line(undef);
223             }
224 22554         61865 return $next;
225             }
226              
227             my %ANCHOR_ALIAS_TAG = ( '&' => 1, '*' => 1, '!' => 1 );
228             my %BLOCK_SCALAR = ( '|' => 1, '>' => 1 );
229             my %COLON_DASH_QUESTION = ( ':' => 1, '-' => 1, '?' => 1 );
230             my %QUOTED = ( '"' => 1, "'" => 1 );
231             my %FLOW = ( '{' => 1, '[' => 1, '}' => 1, ']' => 1, ',' => 1 );
232             my %CONTEXT = ( '"' => 1, "'" => 1, '>' => 1, '|' => 1 );
233              
234             my $RE_ESCAPES = qr{(?:
235             \\([ \\\/_0abefnrtvLNP\t"]) | \\x([0-9a-fA-F]{2})
236             | \\u([A-Fa-f0-9]{4}) | \\U([A-Fa-f0-9]{4,8})
237             )}x;
238             my %CONTROL = (
239             '\\' => '\\', '/' => '/', n => "\n", t => "\t", r => "\r", b => "\b",
240             'a' => "\a", 'b' => "\b", 'e' => "\e", 'f' => "\f", 'v' => "\x0b", "\t" => "\t",
241             'P' => "\x{2029}", L => "\x{2028}", 'N' => "\x85",
242             '0' => "\0", '_' => "\xa0", ' ' => ' ', q/"/ => q/"/,
243             );
244              
245             sub _fetch_next_tokens {
246 36367     36367   44961 TRACE and warn __PACKAGE__.':'.__LINE__.": _fetch_next_tokens\n";
247 36367         59603 my ($self, $next_line) = @_;
248              
249 36367         59054 my $yaml = \$next_line->[1];
250 36367         58045 my $eol = $next_line->[2];
251              
252 36367         49750 my @tokens;
253              
254 36367         46675 while (1) {
255 74489 100       152021 unless (length $$yaml) {
256 6625         12489 push @tokens, ( EOL => $eol, $self->line );
257 6625         16532 $self->_push_tokens(\@tokens);
258 6625         17329 return;
259             }
260 67864         120424 my $first = substr($$yaml, 0, 1);
261 67864         89432 my $plain = 0;
262              
263 67864 100       115820 if ($self->context) {
264 1781 100       9098 if ($$yaml =~ s/\A($RE_WS*)://) {
265 142 100       536 push @tokens, ( WS => $1, $self->line ) if $1;
266 142         348 push @tokens, ( COLON => ':', $self->line );
267 142         347 $self->set_context(0);
268 142         326 next;
269             }
270 1639 100       5500 if ($$yaml =~ s/\A($RE_WS*(?: #.*))\z//) {
271 9         54 push @tokens, ( EOL => $1 . $eol, $self->line );
272 9         44 $self->_push_tokens(\@tokens);
273 9         40 return;
274             }
275 1630         2983 $self->set_context(0);
276             }
277 67713 100 100     259067 if ($CONTEXT{ $first }) {
    100          
    100          
    100          
    100          
278 6344         11668 push @tokens, ( CONTEXT => $first, $self->line );
279 6344         16415 $self->_push_tokens(\@tokens);
280 6344         17544 return 1;
281             }
282             elsif ($COLON_DASH_QUESTION{ $first }) {
283 19543         31736 my $token_name = $TOKEN_NAMES{ $first };
284 19543 100 100     242177 if ($$yaml =~ s/\A\Q$first\E($RE_WS+|\z)//) {
    100          
285 19018         45420 my $after = $1;
286 19018 100 100     35960 if (not $self->flowcontext and not $self->block) {
287 8         30 push @tokens, ERROR => $first . $after, $self->line;
288 8         24 $self->_push_tokens(\@tokens);
289 8         18 $self->exception("Tabs can not be used for indentation");
290             }
291 19010 100       50347 if ($after =~ tr/\t//) {
292 80         294 $self->set_block(0);
293             }
294 19010         31701 my $token_name = $TOKEN_NAMES{ $first };
295 19010         36305 push @tokens, ( $token_name => $first, $self->line );
296 19010 50       43540 if (not defined $1) {
297 0         0 push @tokens, ( EOL => $eol, $self->line );
298 0         0 $self->_push_tokens(\@tokens);
299 0         0 return;
300             }
301 19010         29141 my $ws = $1;
302 19010 100       64668 if ($$yaml =~ s/\A(#.*|)\z//) {
303 2520         7697 push @tokens, ( EOL => $ws . $1 . $eol, $self->line );
304 2520         6478 $self->_push_tokens(\@tokens);
305 2520         8870 return;
306             }
307 16490         35543 push @tokens, ( WS => $ws, $self->line );
308 16490         41485 next;
309             }
310             elsif ($self->flowcontext and $$yaml =~ s/\A:(?=[,\{\}\[\]])//) {
311 7         24 push @tokens, ( $token_name => $first, $self->line );
312 7         20 next;
313             }
314 518         1156 $plain = 1;
315             }
316             elsif ($ANCHOR_ALIAS_TAG{ $first }) {
317 5369         9072 my $token_name = $TOKEN_NAMES{ $first };
318 5369         9064 my $REGEX = $REGEXES{ $token_name };
319 5369 50       153148 if ($$yaml =~ s/\A$REGEX//) {
320 5369         15605 push @tokens, ( $token_name => $1, $self->line );
321             }
322             else {
323 0         0 push @tokens, ( "Invalid $token_name" => $$yaml, $self->line );
324 0         0 $self->_push_tokens(\@tokens);
325 0         0 return;
326             }
327             }
328             elsif ($first eq ' ' or $first eq "\t") {
329 9094 50       52534 if ($$yaml =~ s/\A($RE_WS+)//) {
330 9094         18629 my $ws = $1;
331 9094 100       33664 if ($$yaml =~ s/\A((?:#.*)?\z)//) {
332 208         967 push @tokens, ( EOL => $ws . $1 . $eol, $self->line );
333 208         620 $self->_push_tokens(\@tokens);
334 208         724 return;
335             }
336 8886         18771 push @tokens, ( WS => $ws, $self->line );
337             }
338             }
339             elsif ($FLOW{ $first }) {
340 7228         15799 push @tokens, ( $TOKEN_NAMES{ $first } => $first, $self->line );
341 7228         19286 substr($$yaml, 0, 1, '');
342 7228         14120 my $flowcontext = $self->flowcontext;
343 7228 100 100     31197 if ($first eq '{' or $first eq '[') {
    100 100        
344 2471         4967 $self->set_flowcontext(++$flowcontext);
345             }
346             elsif ($first eq '}' or $first eq ']') {
347 2460         5231 $self->set_flowcontext(--$flowcontext);
348             }
349             }
350             else {
351 20135         32023 $plain = 1;
352             }
353              
354 42136 100       84478 if ($plain) {
355 20653         37867 push @tokens, ( CONTEXT => '', $self->line );
356 20653         48833 $self->_push_tokens(\@tokens);
357 20653         53360 return 1;
358             }
359              
360             }
361              
362 0         0 return;
363             }
364              
365             sub fetch_plain {
366 20614     20614 0 40010 my ($self, $indent, $context) = @_;
367 20614         40089 my $next_line = $self->next_line;
368 20614         35762 my $yaml = \$next_line->[1];
369 20614         31706 my $eol = $next_line->[2];
370 20614         30858 my $REGEX = $RE_PLAIN_WORDS;
371 20614 100       32939 if ($self->flowcontext) {
372 2631         4469 $REGEX = $RE_PLAIN_WORDS_FLOW;
373             }
374              
375 20614         28912 my @tokens;
376 20614 100       332745 unless ($$yaml =~ s/\A($REGEX)//) {
377 7         29 $self->_push_tokens(\@tokens);
378 7         23 $self->exception("Invalid plain scalar");
379             }
380 20607         62630 my $plain = $1;
381 20607         46397 push @tokens, ( PLAIN => $plain, $self->line );
382              
383 20607 100       121657 if ($$yaml =~ s/\A(?:($RE_WS+#.*)|($RE_WS*))\z//) {
384 10026 100       25053 if (defined $1) {
385 130         574 push @tokens, ( EOL => $1 . $eol, $self->line );
386 130         419 $self->_push_tokens(\@tokens);
387 130         442 $self->set_next_line(undef);
388 130         612 return;
389             }
390             else {
391 9896         27555 push @tokens, ( EOL => $2. $eol, $self->line );
392 9896         20972 $self->set_next_line(undef);
393             }
394             }
395             else {
396 10581         31099 $self->_push_tokens(\@tokens);
397 10581         21515 my $partial = $self->_fetch_next_tokens($next_line);
398 10579 100       21627 if (not $partial) {
399 3067         6620 $self->set_next_line(undef);
400             }
401 10579         38271 return;
402             }
403              
404 9896         17143 my $RE2 = $RE_PLAIN_WORDS2;
405 9896 100       17057 if ($self->flowcontext) {
406 124         357 $RE2 = $RE_PLAIN_WORDS_FLOW2;
407             }
408 9896         14886 my $fetch_next = 0;
409 9896         20218 my @lines = ($plain);
410 9896         13034 my @next;
411 9896         13501 LOOP: while (1) {
412 10262         20112 $next_line = $self->_fetch_next_line;
413 10262 100       21608 if (not $next_line) {
414 3582         6277 last LOOP;
415             }
416 6680         10613 my $spaces = $next_line->[0];
417 6680         10601 my $yaml = \$next_line->[1];
418 6680         9847 my $eol = $next_line->[2];
419              
420 6680 100       15445 if (not length $$yaml) {
421 107         393 push @tokens, ( EOL => $spaces . $eol, $self->line );
422 107         308 $self->set_next_line(undef);
423 107         199 push @lines, '';
424 107         233 next LOOP;
425             }
426              
427 6573 100 100     35547 if (not $spaces and $$yaml =~ s/\A(---|\.\.\.)(?=$RE_WS|\z)//) {
428 622         2248 push @next, $TOKEN_NAMES{ $1 } => $1, $self->line;
429 622         1125 $fetch_next = 1;
430 622         1426 last LOOP;
431             }
432 5951 100       14448 if ((length $spaces) < $indent) {
433 5548         13165 last LOOP;
434             }
435              
436 403         863 my $ws = '';
437 403 100       2115 if ($$yaml =~ s/\A($RE_WS+)//) {
438 25         72 $ws = $1;
439             }
440 403 100       1131 if (not length $$yaml) {
441 11         46 push @tokens, ( EOL => $spaces . $ws . $eol, $self->line );
442 11         39 $self->set_next_line(undef);
443 11         26 push @lines, '';
444 11         30 next LOOP;
445             }
446 392 100       1285 if ($$yaml =~ s/\A(#.*)\z//) {
447 9         58 push @tokens, ( EOL => $spaces . $ws . $1 . $eol, $self->line );
448 9         40 $self->set_next_line(undef);
449 9         26 last LOOP;
450             }
451              
452 383 100       16541 if ($$yaml =~ s/\A($RE2)//) {
453 297         1076 push @tokens, INDENT => $spaces, $self->line;
454 297         776 push @tokens, WS => $ws, $self->line;
455 297         638 push @tokens, PLAIN => $1, $self->line;
456 297         611 push @lines, $1;
457 297         555 my $ws = '';
458 297 100       1463 if ($$yaml =~ s/\A($RE_WS+)//) {
459 41         113 $ws = $1;
460             }
461 297 100       845 if (not length $$yaml) {
462 248         699 push @tokens, EOL => $ws . $eol, $self->line;
463 248         713 $self->set_next_line(undef);
464 248         846 next LOOP;
465             }
466              
467 49 100       291 if ($$yaml =~ s/\A(#.*)\z//) {
468 17         90 push @tokens, EOL => $ws . $1 . $eol, $self->line;
469 17         66 $self->set_next_line(undef);
470 17         59 last LOOP;
471             }
472             else {
473 32 100       129 push @tokens, WS => $ws, $self->line if $ws;
474 32         97 $fetch_next = 1;
475             }
476             }
477             else {
478 86         352 push @tokens, SPACE => $spaces, $self->line;
479 86         281 push @tokens, WS => $ws, $self->line;
480 86 50       230 if ($self->flowcontext) {
481 86         176 $fetch_next = 1;
482             }
483             else {
484 0         0 push @tokens, ERROR => $$yaml, $self->line;
485             }
486             }
487              
488 118         461 last LOOP;
489              
490             }
491             # remove empty lines at the end
492 9896   100     28019 while (@lines > 1 and $lines[-1] eq '') {
493 90         292 pop @lines;
494             }
495 9896 100       19833 if (@lines > 1) {
496 242         1224 my $value = YAML::PP::Render->render_multi_val(\@lines);
497 242         426 my @eol;
498 242 100       663 if ($tokens[-3] eq 'EOL') {
499 210         545 @eol = splice @tokens, -3;
500             }
501 242         1206 $self->push_subtokens( { name => 'PLAIN_MULTI', value => $value }, \@tokens);
502 242         874 $self->_push_tokens([ @eol, @next ]);
503             }
504             else {
505 9654         32530 $self->_push_tokens([ @tokens, @next ]);
506             }
507 9896         25606 @tokens = ();
508 9896 100       19548 if ($fetch_next) {
509 740         1955 my $partial = $self->_fetch_next_tokens($next_line);
510 740 100       2075 if (not $partial) {
511 599         1318 $self->set_next_line(undef);
512             }
513             }
514 9896         35885 return;
515             }
516              
517             sub fetch_block {
518 1720     1720 0 3978 my ($self, $indent, $context) = @_;
519 1720         3613 my $next_line = $self->next_line;
520 1720         3281 my $yaml = \$next_line->[1];
521 1720         2977 my $eol = $next_line->[2];
522              
523 1720         2478 my @tokens;
524 1720         3170 my $token_name = $TOKEN_NAMES{ $context };
525 1720 50       18520 $$yaml =~ s/\A\Q$context\E// or die "Unexpected";
526 1720         6214 push @tokens, ( $token_name => $context, $self->line );
527 1720         2992 my $current_indent = $indent;
528 1720         2620 my $started = 0;
529 1720         2552 my $set_indent = 0;
530 1720         2705 my $chomp = '';
531 1720 100       8049 if ($$yaml =~ s/\A([1-9])([+-]?)//) {
    100          
532 214         570 push @tokens, ( BLOCK_SCALAR_INDENT => $1, $self->line );
533 214         460 $set_indent = $1;
534 214 100       646 $chomp = $2 if $2;
535 214 100       645 push @tokens, ( BLOCK_SCALAR_CHOMP => $2, $self->line ) if $2;
536             }
537             elsif ($$yaml =~ s/\A([+-])([1-9])?//) {
538 409         1110 push @tokens, ( BLOCK_SCALAR_CHOMP => $1, $self->line );
539 409         886 $chomp = $1;
540 409 100       1155 push @tokens, ( BLOCK_SCALAR_INDENT => $2, $self->line ) if $2;
541 409 100       1005 $set_indent = $2 if $2;
542             }
543 1720 100       4044 if ($set_indent) {
544 223         379 $started = 1;
545 223 100       567 $indent-- if $indent > 0;
546 223         478 $current_indent = $indent + $set_indent;
547             }
548 1720 100       5317 if (not length $$yaml) {
    100          
549 1662         3823 push @tokens, ( EOL => $eol, $self->line );
550             }
551             elsif ($$yaml =~ s/\A($RE_WS*(?:$RE_WS#.*|))\z//) {
552 52         231 push @tokens, ( EOL => $1 . $eol, $self->line );
553             }
554             else {
555 6         19 $self->_push_tokens(\@tokens);
556 6         18 $self->exception("Invalid block scalar");
557             }
558              
559 1714         2847 my @lines;
560 1714         2614 while (1) {
561 5257         11770 $self->set_next_line(undef);
562 5257         8869 $next_line = $self->_fetch_next_line;
563 5257 100       10572 if (not $next_line) {
564 814         1353 last;
565             }
566 4443         7195 my $spaces = $next_line->[0];
567 4443         6476 my $content = $next_line->[1];
568 4443         6181 my $eol = $next_line->[2];
569 4443 100 100     16517 if (not $spaces and $content =~ m/\A(---|\.\.\.)(?=$RE_WS|\z)/) {
570 200         480 last;
571             }
572 4243 100       10123 if ((length $spaces) < $current_indent) {
573 1436 100       3249 if (length $content) {
574 700 100       2130 if ($content =~ m/\A\t/) {
575 2         7 $self->_push_tokens(\@tokens);
576 2         11 $self->exception("Invalid block scalar");
577             }
578 698         1574 last;
579             }
580             else {
581 736         1439 push @lines, '';
582 736         1807 push @tokens, ( EOL => $spaces . $eol, $self->line );
583 736         1608 next;
584             }
585             }
586 2807 100       5962 if ((length $spaces) > $current_indent) {
587 1571 100       3402 if ($started) {
588 370         2169 ($spaces, my $more_spaces) = unpack "a${current_indent}a*", $spaces;
589 370         911 $content = $more_spaces . $content;
590             }
591             }
592 2807 100       6164 unless (length $content) {
593 257         597 push @lines, '';
594 257         668 push @tokens, ( INDENT => $spaces, $self->line, EOL => $eol, $self->line );
595 257 100       610 unless ($started) {
596 131         234 $current_indent = length $spaces;
597             }
598 257         500 next;
599             }
600 2550 100       4973 unless ($started) {
601 1383         1971 $started = 1;
602 1383         2157 $current_indent = length $spaces;
603             }
604 2550         4741 push @lines, $content;
605 2550         4992 push @tokens, (
606             INDENT => $spaces, $self->line,
607             BLOCK_SCALAR_CONTENT => $content, $self->line,
608             EOL => $eol, $self->line,
609             );
610             }
611 1712         6719 my $value = YAML::PP::Render->render_block_scalar($context, $chomp, \@lines);
612 1712         4596 my @eol = splice @tokens, -3;
613 1712         7643 $self->push_subtokens( { name => 'BLOCK_SCALAR', value => $value }, \@tokens );
614 1712         6382 $self->_push_tokens([ @eol ]);
615 1712         8958 return 0;
616             }
617              
618             sub fetch_quoted {
619 4624     4624 0 9892 my ($self, $indent, $context) = @_;
620 4624         9210 my $next_line = $self->next_line;
621 4624         8146 my $yaml = \$next_line->[1];
622 4624         7347 my $spaces = $next_line->[0];
623              
624 4624         7927 my $token_name = $TOKEN_NAMES{ $context };
625 4624 50       42459 $$yaml =~ s/\A\Q$context// or die "Unexpected";;
626 4624         13401 my @tokens = ( $token_name => $context, $self->line );
627              
628 4624         7386 my $start = 1;
629 4624         6449 my @values;
630 4624         6548 while (1) {
631              
632 5466 100       11023 unless ($start) {
633 842 100       1647 $next_line = $self->_fetch_next_line or do {
634 1         6 for (my $i = 0; $i < @tokens; $i+= 3) {
635 3         6 my $token = $tokens[ $i + 1 ];
636 3 100       10 if (ref $token) {
637 1         5 $tokens[ $i + 1 ] = $token->{orig};
638             }
639             }
640 1         4 $self->_push_tokens(\@tokens);
641 1         6 $self->exception("Missing closing quote <$context> at EOF");
642             };
643 841         1340 $start = 0;
644 841         1516 $spaces = $next_line->[0];
645 841         1732 $yaml = \$next_line->[1];
646              
647 841 100 100     4623 if (not length $$yaml) {
    100          
    100          
648 157         753 push @tokens, ( EOL => $spaces . $next_line->[2], $self->line );
649 157         465 $self->set_next_line(undef);
650 157         469 push @values, { value => '', orig => '' };
651 157         304 next;
652             }
653             elsif (not $spaces and $$yaml =~ m/\A(---|\.\.\.)(?=$RE_WS|\z)/) {
654 3         15 for (my $i = 0; $i < @tokens; $i+= 3) {
655 9         17 my $token = $tokens[ $i + 1 ];
656 9 100       24 if (ref $token) {
657 3         11 $tokens[ $i + 1 ] = $token->{orig};
658             }
659             }
660 3         11 $self->_push_tokens(\@tokens);
661 3         19 $self->exception("Missing closing quote <$context> or invalid document marker");
662             }
663             elsif ((length $spaces) < $indent) {
664 3         16 for (my $i = 0; $i < @tokens; $i+= 3) {
665 9         17 my $token = $tokens[ $i + 1 ];
666 9 100       36 if (ref $token) {
667 3         16 $tokens[ $i + 1 ] = $token->{orig};
668             }
669             }
670 3         10 $self->_push_tokens(\@tokens);
671 3         16 $self->exception("Wrong indendation or missing closing quote <$context>");
672             }
673              
674 678 100       3674 if ($$yaml =~ s/\A($RE_WS+)//) {
675 95         291 $spaces .= $1;
676             }
677 678         1707 push @tokens, ( WS => $spaces, $self->line );
678             }
679              
680 5302         12337 my $v = $self->_read_quoted_tokens($start, $context, $yaml, \@tokens);
681 5300         8714 push @values, $v;
682 5300 100       11785 if ($tokens[-3] eq $token_name) {
683 4615 100       8404 if ($start) {
684             $self->push_subtokens(
685             { name => 'QUOTED', value => $v->{value} }, \@tokens
686 4129         16104 );
687             }
688             else {
689 486         2264 my $value = YAML::PP::Render->render_quoted($context, \@values);
690 486         2112 $self->push_subtokens(
691             { name => 'QUOTED_MULTILINE', value => $value }, \@tokens
692             );
693             }
694 4615 100       9376 $self->set_context(1) if $self->flowcontext;
695 4615 100       10145 if (length $$yaml) {
696 2486         4900 my $partial = $self->_fetch_next_tokens($next_line);
697 2486 100       5321 if (not $partial) {
698 1010         2116 $self->set_next_line(undef);
699             }
700 2486         12378 return 0;
701             }
702             else {
703 2129         5232 @tokens = ();
704 2129         5356 push @tokens, ( EOL => $next_line->[2], $self->line );
705 2129         6009 $self->_push_tokens(\@tokens);
706 2129         5735 $self->set_next_line(undef);
707 2129         11321 return;
708             }
709             }
710 685         1321 $tokens[-2] .= $next_line->[2];
711 685         1788 $self->set_next_line(undef);
712 685         1142 $start = 0;
713             }
714             }
715              
716             sub _read_quoted_tokens {
717 5302     5302   11361 my ($self, $start, $first, $yaml, $tokens) = @_;
718 5302         7809 my $quoted = '';
719 5302         7684 my $decoded = '';
720 5302         8431 my $token_name = $TOKEN_NAMES{ $first };
721 5302         7633 my $eol = '';
722 5302 100       10402 if ($first eq "'") {
723 2139         3843 my $regex = $REGEXES{SINGLEQUOTED};
724 2139 50       15735 if ($$yaml =~ s/\A($regex)//) {
725 2139         5581 $quoted .= $1;
726 2139         3938 $decoded .= $1;
727 2139         4361 $decoded =~ s/''/'/g;
728             }
729 2139 100       6216 unless (length $$yaml) {
730 85 100       682 if ($quoted =~ s/($RE_WS+)\z//) {
731 24         99 $eol = $1;
732 24         334 $decoded =~ s/($eol)\z//;
733             }
734             }
735             }
736             else {
737 3163         6998 ($quoted, $decoded, $eol) = $self->_read_doublequoted($yaml);
738             }
739 5302         16905 my $value = { value => $decoded, orig => $quoted };
740              
741 5302 100       30977 if ($$yaml =~ s/\A$first//) {
742 4615 100       9870 if ($start) {
743 4129         10978 push @$tokens, ( $token_name . 'D' => $value, $self->line );
744             }
745             else {
746 486         1548 push @$tokens, ( $token_name . 'D_LINE' => $value, $self->line );
747             }
748 4615         9590 push @$tokens, ( $token_name => $first, $self->line );
749 4615         12474 return $value;
750             }
751 687 100       1966 if (length $$yaml) {
752 2         11 push @$tokens, ( $token_name . 'D' => $value->{orig}, $self->line );
753 2         16 $self->_push_tokens($tokens);
754 2         12 $self->exception("Invalid quoted <$first> string");
755             }
756              
757 685         2214 push @$tokens, ( $token_name . 'D_LINE' => $value, $self->line );
758 685         1524 push @$tokens, ( EOL => $eol, $self->line );
759              
760 685         1537 return $value;
761             }
762              
763             sub _read_doublequoted {
764 3163     3163   6450 my ($self, $yaml) = @_;
765 3163         4499 my $quoted = '';
766 3163         4508 my $decoded = '';
767 3163         4395 my $eol = '';
768 3163         4142 while (1) {
769 9259         12235 my $last = 1;
770 9259 100       31725 if ($$yaml =~ s/\A([^"\\ \t]+)//) {
771 5522         11591 $quoted .= $1;
772 5522         8099 $decoded .= $1;
773 5522         7255 $last = 0;
774             }
775 9259 100       38917 if ($$yaml =~ s/\A($RE_ESCAPES)//) {
776 1466         3195 $quoted .= $1;
777 1466 100       4870 my $dec = defined $2 ? $CONTROL{ $2 }
    100          
    100          
778             : defined $3 ? chr hex $3
779             : defined $4 ? chr hex $4
780             : chr hex $5;
781 1466         2555 $decoded .= $dec;
782 1466         2422 $last = 0;
783             }
784 9259 100       26365 if ($$yaml =~ s/\A([ \t]+)//) {
785 2740         5080 my $spaces = $1;
786 2740 100       5982 if (length $$yaml) {
787 2599         3948 $quoted .= $spaces;
788 2599         3491 $decoded .= $spaces;
789 2599         3819 $last = 0;
790             }
791             else {
792 141         378 $eol = $spaces;
793 141         363 last;
794             }
795             }
796 9118 100       19043 if ($$yaml =~ s/\A(\\)\z//) {
797 82         225 $quoted .= $1;
798 82         144 $decoded .= $1;
799 82         166 last;
800             }
801 9036 100       18807 last if $last;
802             }
803 3163         10735 return ($quoted, $decoded, $eol);
804             }
805              
806             sub _fetch_next_tokens_directive {
807 326     326   954 my ($self, $yaml, $eol) = @_;
808 326         553 my @tokens;
809              
810 326         594 my $trailing_ws = '';
811 326   100     1170 my $warn = $ENV{YAML_PP_RESERVED_DIRECTIVE} || 'warn';
812 326 100       5331 if ($$yaml =~ s/\A(\s*%YAML[ \t]+([0-9]+\.[0-9]+))//) {
    100          
    50          
813 163         428 my $dir = $1;
814 163         336 my $version = $2;
815 163 100       1360 if ($$yaml =~ s/\A($RE_WS+)//) {
    100          
816 28         88 $trailing_ws = $1;
817             }
818             elsif (length $$yaml) {
819 1         7 push @tokens, ( 'Invalid directive' => $dir.$$yaml.$eol, $self->line );
820 1         5 $self->_push_tokens(\@tokens);
821 1         2 return;
822             }
823 162 100       763 if ($version !~ m/^1\.[12]$/) {
824 9 50       65 if ($warn eq 'warn') {
    50          
825 0         0 warn "Unsupported YAML version '$dir'";
826             }
827             elsif ($warn eq 'fatal') {
828 0         0 push @tokens, ( 'Unsupported YAML version' => $dir, $self->line );
829 0         0 $self->_push_tokens(\@tokens);
830 0         0 return;
831             }
832             }
833 162         487 push @tokens, ( YAML_DIRECTIVE => $dir, $self->line );
834             }
835             elsif ($$yaml =~ s/\A(\s*%TAG[ \t]+(!$RE_NS_WORD_CHAR*!|!)[ \t]+(tag:\S+|!$RE_URI_CHAR+))($RE_WS*)//) {
836 118         452 push @tokens, ( TAG_DIRECTIVE => $1, $self->line );
837             # TODO
838 118         309 my $tag_alias = $2;
839 118         270 my $tag_url = $3;
840 118         449 $trailing_ws = $4;
841             }
842             elsif ($$yaml =~ s/\A(\s*\A%(?:\w+).*)//) {
843 45         183 push @tokens, ( RESERVED_DIRECTIVE => $1, $self->line );
844 45 50       227 if ($warn eq 'warn') {
    50          
845 0         0 warn "Found reserved directive '$1'";
846             }
847             elsif ($warn eq 'fatal') {
848 0         0 die "Found reserved directive '$1'";
849             }
850             }
851             else {
852 0         0 push @tokens, ( 'Invalid directive' => $$yaml, $self->line );
853 0         0 push @tokens, ( EOL => $eol, $self->line );
854 0         0 $self->_push_tokens(\@tokens);
855 0         0 return;
856             }
857 325 100 66     1326 if (not length $$yaml) {
    100          
    50          
858 297         744 push @tokens, ( EOL => $eol, $self->line );
859             }
860             elsif ($trailing_ws and $$yaml =~ s/\A(#.*)?\z//) {
861 27         150 push @tokens, ( EOL => "$trailing_ws$1$eol", $self->line );
862 27         118 $self->_push_tokens(\@tokens);
863 27         92 return;
864             }
865             elsif ($$yaml =~ s/\A([ \t]+#.*)?\z//) {
866 0         0 push @tokens, ( EOL => "$1$eol", $self->line );
867 0         0 $self->_push_tokens(\@tokens);
868 0         0 return;
869             }
870             else {
871 1         6 push @tokens, ( 'Invalid directive' => $trailing_ws.$$yaml, $self->line );
872 1         4 push @tokens, ( EOL => $eol, $self->line );
873             }
874 298         974 $self->_push_tokens(\@tokens);
875 298         802 return;
876             }
877              
878             sub _push_tokens {
879 84487     84487   150598 my ($self, $new_tokens) = @_;
880 84487         139779 my $next = $self->next_tokens;
881 84487         136052 my $line = $self->line;
882 84487         144779 my $column = $self->offset;
883              
884 84487         191484 for (my $i = 0; $i < @$new_tokens; $i += 3) {
885 152605         244627 my $value = $new_tokens->[ $i + 1 ];
886 152605         207937 my $name = $new_tokens->[ $i ];
887 152605         203398 my $line = $new_tokens->[ $i + 2 ];
888 152605         435620 my $push = {
889             name => $name,
890             line => $line,
891             column => $column,
892             value => $value,
893             };
894 152605 100       334140 $column += length $value unless $name eq 'CONTEXT';
895 152605         226384 push @$next, $push;
896 152605 100       386748 if ($name eq 'EOL') {
897 24383         60480 $column = 0;
898             }
899             }
900 84487         189659 $self->set_offset($column);
901 84487         126332 return $next;
902             }
903              
904             sub push_subtokens {
905 6569     6569 0 12824 my ($self, $token, $subtokens) = @_;
906 6569         12134 my $next = $self->next_tokens;
907 6569         11494 my $line = $self->line;
908 6569         12163 my $column = $self->offset;
909 6569         11429 $token->{column} = $column;
910 6569         11623 $token->{subtokens} = \my @sub;
911              
912 6569         16005 for (my $i = 0; $i < @$subtokens; $i+=3) {
913 28839         42346 my $name = $subtokens->[ $i ];
914 28839         45402 my $value = $subtokens->[ $i + 1 ];
915 28839         37076 my $line = $subtokens->[ $i + 2 ];
916 28839         65846 my $push = {
917             name => $subtokens->[ $i ],
918             line => $line,
919             column => $column,
920             };
921 28839 100       52299 if (ref $value eq 'HASH') {
922 5293         31305 %$push = ( %$push, %$value );
923 5293         13919 $column += length $value->{orig};
924             }
925             else {
926 23546         38710 $push->{value} = $value;
927 23546         33760 $column += length $value;
928             }
929 28839 100       52472 if ($push->{name} eq 'EOL') {
930 4712         6101 $column = 0;
931             }
932 28839         70482 push @sub, $push;
933             }
934 6569         11966 $token->{line} = $sub[0]->{line};
935 6569         10862 push @$next, $token;
936 6569         15807 $self->set_offset($column);
937 6569         12385 return $next;
938             }
939              
940             sub exception {
941 61     61 0 119 my ($self, $msg) = @_;
942 61         109 my $next = $self->next_tokens;
943 61         103 $next = [];
944 61 50       172 my $line = @$next ? $next->[0]->{line} : $self->line;
945 61         438 my @caller = caller(0);
946 61         136 my $yaml = '';
947 61 100       107 if (my $nl = $self->next_line) {
948 60         164 $yaml = join '', @$nl;
949 60         109 $yaml = $nl->[1];
950             }
951 61         132 my $e = YAML::PP::Exception->new(
952             line => $line,
953             column => $self->offset + 1,
954             msg => $msg,
955             next => $next,
956             where => $caller[1] . ' line ' . $caller[2],
957             yaml => $yaml,
958             );
959 61         1408 croak $e;
960             }
961              
962             1;