Auftrags-Controller: Email: Anhang-Policy anders prüfen
[kivitendo-erp.git] / modules / override / YAML / Loader.pm
1 package YAML::Loader;
2
3 use YAML::Mo;
4 extends 'YAML::Loader::Base';
5
6 use YAML::Loader::Base;
7 use YAML::Types;
8
9 # Context constants
10 use constant LEAF       => 1;
11 use constant COLLECTION => 2;
12 use constant VALUE      => "\x07YAML\x07VALUE\x07";
13 use constant COMMENT    => "\x07YAML\x07COMMENT\x07";
14
15 # Common YAML character sets
16 my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
17 my $FOLD_CHAR   = '>';
18 my $LIT_CHAR    = '|';
19 my $LIT_CHAR_RX = "\\$LIT_CHAR";
20
21 sub load {
22     my $self = shift;
23     $self->stream($_[0] || '');
24     return $self->_parse();
25 }
26
27 # Top level function for parsing. Parse each document in order and
28 # handle processing for YAML headers.
29 sub _parse {
30     my $self = shift;
31     my (%directives, $preface);
32     $self->{stream} =~ s|\015\012|\012|g;
33     $self->{stream} =~ s|\015|\012|g;
34     $self->line(0);
35     $self->die('YAML_PARSE_ERR_BAD_CHARS')
36       if $self->stream =~ /$ESCAPE_CHAR/;
37 #     $self->die('YAML_PARSE_ERR_NO_FINAL_NEWLINE')
38     $self->{stream} .= "\n"
39       if length($self->stream) and
40          $self->{stream} !~ s/(.)\n\Z/$1/s;
41     $self->lines([split /\x0a/, $self->stream, -1]);
42     $self->line(1);
43     # Throw away any comments or blanks before the header (or start of
44     # content for headerless streams)
45     $self->_parse_throwaway_comments();
46     $self->document(0);
47     $self->documents([]);
48     # Add an "assumed" header if there is no header and the stream is
49     # not empty (after initial throwaways).
50     if (not $self->eos) {
51         if ($self->lines->[0] !~ /^---(\s|$)/) {
52             unshift @{$self->lines}, '---';
53             $self->{line}--;
54         }
55     }
56
57     # Main Loop. Parse out all the top level nodes and return them.
58     while (not $self->eos) {
59         $self->anchor2node({});
60         $self->{document}++;
61         $self->done(0);
62         $self->level(0);
63         $self->offset->[0] = -1;
64
65         if ($self->lines->[0] =~ /^---\s*(.*)$/) {
66             my @words = split /\s+/, $1;
67             %directives = ();
68             while (@words && $words[0] =~ /^#(\w+):(\S.*)$/) {
69                 my ($key, $value) = ($1, $2);
70                 shift(@words);
71                 if (defined $directives{$key}) {
72                     $self->warn('YAML_PARSE_WARN_MULTIPLE_DIRECTIVES',
73                       $key, $self->document);
74                     next;
75                 }
76                 $directives{$key} = $value;
77             }
78             $self->preface(join ' ', @words);
79         }
80         else {
81             $self->die('YAML_PARSE_ERR_NO_SEPARATOR');
82         }
83
84         if (not $self->done) {
85             $self->_parse_next_line(COLLECTION);
86         }
87         if ($self->done) {
88             $self->{indent} = -1;
89             $self->content('');
90         }
91
92         $directives{YAML} ||= '1.0';
93         $directives{TAB} ||= 'NONE';
94         ($self->{major_version}, $self->{minor_version}) =
95           split /\./, $directives{YAML}, 2;
96         $self->die('YAML_PARSE_ERR_BAD_MAJOR_VERSION', $directives{YAML})
97           if $self->major_version ne '1';
98         $self->warn('YAML_PARSE_WARN_BAD_MINOR_VERSION', $directives{YAML})
99           if $self->minor_version ne '0';
100         $self->die('Unrecognized TAB policy')
101           unless $directives{TAB} =~ /^(NONE|\d+)(:HARD)?$/;
102
103         push @{$self->documents}, $self->_parse_node();
104     }
105     return wantarray ? @{$self->documents} : $self->documents->[-1];
106 }
107
108 # This function is the dispatcher for parsing each node. Every node
109 # recurses back through here. (Inlines are an exception as they have
110 # their own sub-parser.)
111 sub _parse_node {
112     my $self = shift;
113     my $preface = $self->preface;
114     $self->preface('');
115     my ($node, $type, $indicator, $escape, $chomp) = ('') x 5;
116     my ($anchor, $alias, $explicit, $implicit, $class) = ('') x 5;
117     ($anchor, $alias, $explicit, $implicit, $preface) =
118       $self->_parse_qualifiers($preface);
119     if ($anchor) {
120         $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
121     }
122     $self->inline('');
123     while (length $preface) {
124         my $line = $self->line - 1;
125         if ($preface =~ s/^($FOLD_CHAR|$LIT_CHAR_RX)(-|\+)?\d*\s*//) {
126             $indicator = $1;
127             $chomp = $2 if defined($2);
128         }
129         else {
130             $self->die('YAML_PARSE_ERR_TEXT_AFTER_INDICATOR') if $indicator;
131             $self->inline($preface);
132             $preface = '';
133         }
134     }
135     if ($alias) {
136         $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias)
137           unless defined $self->anchor2node->{$alias};
138         if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') {
139             $node = $self->anchor2node->{$alias};
140         }
141         else {
142             $node = do {my $sv = "*$alias"};
143             push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
144         }
145     }
146     elsif (length $self->inline) {
147         $node = $self->_parse_inline(1, $implicit, $explicit);
148         if (length $self->inline) {
149             $self->die('YAML_PARSE_ERR_SINGLE_LINE');
150         }
151     }
152     elsif ($indicator eq $LIT_CHAR) {
153         $self->{level}++;
154         $node = $self->_parse_block($chomp);
155         $node = $self->_parse_implicit($node) if $implicit;
156         $self->{level}--;
157     }
158     elsif ($indicator eq $FOLD_CHAR) {
159         $self->{level}++;
160         $node = $self->_parse_unfold($chomp);
161         $node = $self->_parse_implicit($node) if $implicit;
162         $self->{level}--;
163     }
164     else {
165         $self->{level}++;
166         $self->offset->[$self->level] ||= 0;
167         if ($self->indent == $self->offset->[$self->level]) {
168             if ($self->content =~ /^-( |$)/) {
169                 $node = $self->_parse_seq($anchor);
170             }
171             elsif ($self->content =~ /(^\?|\:( |$))/) {
172                 $node = $self->_parse_mapping($anchor);
173             }
174             elsif ($preface =~ /^\s*$/) {
175                 $node = $self->_parse_implicit('');
176             }
177             else {
178                 $self->die('YAML_PARSE_ERR_BAD_NODE');
179             }
180         }
181         else {
182             $node = undef;
183         }
184         $self->{level}--;
185     }
186     $#{$self->offset} = $self->level;
187
188     if ($explicit) {
189         if ($class) {
190             if (not ref $node) {
191                 my $copy = $node;
192                 undef $node;
193                 $node = \$copy;
194             }
195             CORE::bless $node, $class;
196         }
197         else {
198             $node = $self->_parse_explicit($node, $explicit);
199         }
200     }
201     if ($anchor) {
202         if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') {
203             # XXX Can't remember what this code actually does
204             for my $ref (@{$self->anchor2node->{$anchor}}) {
205                 ${$ref->[0]} = $node;
206                 $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS',
207                     $anchor, $ref->[1]);
208             }
209         }
210         $self->anchor2node->{$anchor} = $node;
211     }
212     return $node;
213 }
214
215 # Preprocess the qualifiers that may be attached to any node.
216 sub _parse_qualifiers {
217     my $self = shift;
218     my ($preface) = @_;
219     my ($anchor, $alias, $explicit, $implicit, $token) = ('') x 5;
220     $self->inline('');
221     while ($preface =~ /^[&*!]/) {
222         my $line = $self->line - 1;
223         if ($preface =~ s/^\!(\S+)\s*//) {
224             $self->die('YAML_PARSE_ERR_MANY_EXPLICIT') if $explicit;
225             $explicit = $1;
226         }
227         elsif ($preface =~ s/^\!\s*//) {
228             $self->die('YAML_PARSE_ERR_MANY_IMPLICIT') if $implicit;
229             $implicit = 1;
230         }
231         elsif ($preface =~ s/^\&([^ ,:]+)\s*//) {
232             $token = $1;
233             $self->die('YAML_PARSE_ERR_BAD_ANCHOR')
234               unless $token =~ /^[a-zA-Z0-9]+$/;
235             $self->die('YAML_PARSE_ERR_MANY_ANCHOR') if $anchor;
236             $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $alias;
237             $anchor = $token;
238         }
239         elsif ($preface =~ s/^\*([^ ,:]+)\s*//) {
240             $token = $1;
241             $self->die('YAML_PARSE_ERR_BAD_ALIAS')
242               unless $token =~ /^[a-zA-Z0-9]+$/;
243             $self->die('YAML_PARSE_ERR_MANY_ALIAS') if $alias;
244             $self->die('YAML_PARSE_ERR_ANCHOR_ALIAS') if $anchor;
245             $alias = $token;
246         }
247     }
248     return ($anchor, $alias, $explicit, $implicit, $preface);
249 }
250
251 # Morph a node to it's explicit type
252 sub _parse_explicit {
253     my $self = shift;
254     my ($node, $explicit) = @_;
255     my ($type, $class);
256     if ($explicit =~ /^\!?perl\/(hash|array|ref|scalar)(?:\:(\w(\w|\:\:)*)?)?$/) {
257         ($type, $class) = (($1 || ''), ($2 || ''));
258
259         # FIXME # die unless uc($type) eq ref($node) ?
260
261         if ( $type eq "ref" ) {
262             $self->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'XXX', $explicit)
263             unless exists $node->{VALUE()} and scalar(keys %$node) == 1;
264
265             my $value = $node->{VALUE()};
266             $node = \$value;
267         }
268
269         if ( $type eq "scalar" and length($class) and !ref($node) ) {
270             my $value = $node;
271             $node = \$value;
272         }
273
274         if ( length($class) ) {
275             CORE::bless($node, $class);
276         }
277
278         return $node;
279     }
280     if ($explicit =~ m{^!?perl/(glob|regexp|code)(?:\:(\w(\w|\:\:)*)?)?$}) {
281         ($type, $class) = (($1 || ''), ($2 || ''));
282         my $type_class = "YAML::Type::$type";
283         no strict 'refs';
284         if ($type_class->can('yaml_load')) {
285             return $type_class->yaml_load($node, $class, $self);
286         }
287         else {
288             $self->die('YAML_LOAD_ERR_NO_CONVERT', 'XXX', $explicit);
289         }
290     }
291     # This !perl/@Foo and !perl/$Foo are deprecated but still parsed
292     elsif ($YAML::TagClass->{$explicit} ||
293            $explicit =~ m{^perl/(\@|\$)?([a-zA-Z](\w|::)+)$}
294           ) {
295         $class = $YAML::TagClass->{$explicit} || $2;
296         if ($class->can('yaml_load')) {
297             require YAML::Node;
298             return $class->yaml_load(YAML::Node->new($node, $explicit));
299         }
300         else {
301             if (ref $node) {
302                 return CORE::bless $node, $class;
303             }
304             else {
305                 return CORE::bless \$node, $class;
306             }
307         }
308     }
309     elsif (ref $node) {
310         require YAML::Node;
311         return YAML::Node->new($node, $explicit);
312     }
313     else {
314         # XXX This is likely wrong. Failing test:
315         # --- !unknown 'scalar value'
316         return $node;
317     }
318 }
319
320 # Parse a YAML mapping into a Perl hash
321 sub _parse_mapping {
322     my $self = shift;
323     my ($anchor) = @_;
324     my $mapping = {};
325     $self->anchor2node->{$anchor} = $mapping;
326     my $key;
327     while (not $self->done and $self->indent == $self->offset->[$self->level]) {
328         # If structured key:
329         if ($self->{content} =~ s/^\?\s*//) {
330             $self->preface($self->content);
331             $self->_parse_next_line(COLLECTION);
332             $key = $self->_parse_node();
333             $key = "$key";
334         }
335         # If "default" key (equals sign)
336         elsif ($self->{content} =~ s/^\=\s*//) {
337             $key = VALUE;
338         }
339         # If "comment" key (slash slash)
340         elsif ($self->{content} =~ s/^\=\s*//) {
341             $key = COMMENT;
342         }
343         # Regular scalar key:
344         else {
345             $self->inline($self->content);
346             $key = $self->_parse_inline();
347             $key = "$key";
348             $self->content($self->inline);
349             $self->inline('');
350         }
351
352         unless ($self->{content} =~ s/^:\s*//) {
353             $self->die('YAML_LOAD_ERR_BAD_MAP_ELEMENT');
354         }
355         $self->preface($self->content);
356         my $line = $self->line;
357         $self->_parse_next_line(COLLECTION);
358         my $value = $self->_parse_node();
359         if (exists $mapping->{$key}) {
360             $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY');
361         }
362         else {
363             $mapping->{$key} = $value;
364         }
365     }
366     return $mapping;
367 }
368
369 # Parse a YAML sequence into a Perl array
370 sub _parse_seq {
371     my $self = shift;
372     my ($anchor) = @_;
373     my $seq = [];
374     $self->anchor2node->{$anchor} = $seq;
375     while (not $self->done and $self->indent == $self->offset->[$self->level]) {
376         if ($self->content =~ /^-(?: (.*))?$/) {
377             $self->preface(defined($1) ? $1 : '');
378         }
379         else {
380             $self->die('YAML_LOAD_ERR_BAD_SEQ_ELEMENT');
381         }
382         if ($self->preface =~ /^(\s*)(\w.*\:(?: |$).*)$/) {
383             $self->indent($self->offset->[$self->level] + 2 + length($1));
384             $self->content($2);
385             $self->level($self->level + 1);
386             $self->offset->[$self->level] = $self->indent;
387             $self->preface('');
388             push @$seq, $self->_parse_mapping('');
389             $self->{level}--;
390             $#{$self->offset} = $self->level;
391         }
392         else {
393             $self->_parse_next_line(COLLECTION);
394             push @$seq, $self->_parse_node();
395         }
396     }
397     return $seq;
398 }
399
400 # Parse an inline value. Since YAML supports inline collections, this is
401 # the top level of a sub parsing.
402 sub _parse_inline {
403     my $self = shift;
404     my ($top, $top_implicit, $top_explicit) = (@_, '', '', '');
405     $self->{inline} =~ s/^\s*(.*)\s*$/$1/; # OUCH - mugwump
406     my ($node, $anchor, $alias, $explicit, $implicit) = ('') x 5;
407     ($anchor, $alias, $explicit, $implicit, $self->{inline}) =
408       $self->_parse_qualifiers($self->inline);
409     if ($anchor) {
410         $self->anchor2node->{$anchor} = CORE::bless [], 'YAML-anchor2node';
411     }
412     $implicit ||= $top_implicit;
413     $explicit ||= $top_explicit;
414     ($top_implicit, $top_explicit) = ('', '');
415     if ($alias) {
416         $self->die('YAML_PARSE_ERR_NO_ANCHOR', $alias)
417           unless defined $self->anchor2node->{$alias};
418         if (ref($self->anchor2node->{$alias}) ne 'YAML-anchor2node') {
419             $node = $self->anchor2node->{$alias};
420         }
421         else {
422             $node = do {my $sv = "*$alias"};
423             push @{$self->anchor2node->{$alias}}, [\$node, $self->line];
424         }
425     }
426     elsif ($self->inline =~ /^\{/) {
427         $node = $self->_parse_inline_mapping($anchor);
428     }
429     elsif ($self->inline =~ /^\[/) {
430         $node = $self->_parse_inline_seq($anchor);
431     }
432     elsif ($self->inline =~ /^"/) {
433         $node = $self->_parse_inline_double_quoted();
434         $node = $self->_unescape($node);
435         $node = $self->_parse_implicit($node) if $implicit;
436     }
437     elsif ($self->inline =~ /^'/) {
438         $node = $self->_parse_inline_single_quoted();
439         $node = $self->_parse_implicit($node) if $implicit;
440     }
441     else {
442         if ($top) {
443             $node = $self->inline;
444             $self->inline('');
445         }
446         else {
447             $node = $self->_parse_inline_simple();
448         }
449         $node = $self->_parse_implicit($node) unless $explicit;
450     }
451     if ($explicit) {
452         $node = $self->_parse_explicit($node, $explicit);
453     }
454     if ($anchor) {
455         if (ref($self->anchor2node->{$anchor}) eq 'YAML-anchor2node') {
456             for my $ref (@{$self->anchor2node->{$anchor}}) {
457                 ${$ref->[0]} = $node;
458                 $self->warn('YAML_LOAD_WARN_UNRESOLVED_ALIAS',
459                     $anchor, $ref->[1]);
460             }
461         }
462         $self->anchor2node->{$anchor} = $node;
463     }
464     return $node;
465 }
466
467 # Parse the inline YAML mapping into a Perl hash
468 sub _parse_inline_mapping {
469     my $self = shift;
470     my ($anchor) = @_;
471     my $node = {};
472     $self->anchor2node->{$anchor} = $node;
473
474     $self->die('YAML_PARSE_ERR_INLINE_MAP')
475       unless $self->{inline} =~ s/^\{\s*//;
476     while (not $self->{inline} =~ s/^\s*\}//) {
477         my $key = $self->_parse_inline();
478         $self->die('YAML_PARSE_ERR_INLINE_MAP')
479           unless $self->{inline} =~ s/^\: \s*//;
480         my $value = $self->_parse_inline();
481         if (exists $node->{$key}) {
482             $self->warn('YAML_LOAD_WARN_DUPLICATE_KEY');
483         }
484         else {
485             $node->{$key} = $value;
486         }
487         next if $self->inline =~ /^\s*\}/;
488         $self->die('YAML_PARSE_ERR_INLINE_MAP')
489           unless $self->{inline} =~ s/^\,\s*//;
490     }
491     return $node;
492 }
493
494 # Parse the inline YAML sequence into a Perl array
495 sub _parse_inline_seq {
496     my $self = shift;
497     my ($anchor) = @_;
498     my $node = [];
499     $self->anchor2node->{$anchor} = $node;
500
501     $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE')
502       unless $self->{inline} =~ s/^\[\s*//;
503     while (not $self->{inline} =~ s/^\s*\]//) {
504         my $value = $self->_parse_inline();
505         push @$node, $value;
506         next if $self->inline =~ /^\s*\]/;
507         $self->die('YAML_PARSE_ERR_INLINE_SEQUENCE')
508           unless $self->{inline} =~ s/^\,\s*//;
509     }
510     return $node;
511 }
512
513 # Parse the inline double quoted string.
514 sub _parse_inline_double_quoted {
515     my $self = shift;
516     my $node;
517     # https://rt.cpan.org/Public/Bug/Display.html?id=90593
518     if ($self->inline =~ /^"((?:(?:\\"|[^"]){0,32766}){0,32766})"\s*(.*)$/) {
519         $node = $1;
520         $self->inline($2);
521         $node =~ s/\\"/"/g;
522     }
523     else {
524         $self->die('YAML_PARSE_ERR_BAD_DOUBLE');
525     }
526     return $node;
527 }
528
529
530 # Parse the inline single quoted string.
531 sub _parse_inline_single_quoted {
532     my $self = shift;
533     my $node;
534     if ($self->inline =~ /^'((?:(?:''|[^']){0,32766}){0,32766})'\s*(.*)$/) {
535         $node = $1;
536         $self->inline($2);
537         $node =~ s/''/'/g;
538     }
539     else {
540         $self->die('YAML_PARSE_ERR_BAD_SINGLE');
541     }
542     return $node;
543 }
544
545 # Parse the inline unquoted string and do implicit typing.
546 sub _parse_inline_simple {
547     my $self = shift;
548     my $value;
549     if ($self->inline =~ /^(|[^!@#%^&*].*?)(?=[\[\]\{\},]|, |: |- |:\s*$|$)/) {
550         $value = $1;
551         substr($self->{inline}, 0, length($1)) = '';
552     }
553     else {
554         $self->die('YAML_PARSE_ERR_BAD_INLINE_IMPLICIT', $value);
555     }
556     return $value;
557 }
558
559 sub _parse_implicit {
560     my $self = shift;
561     my ($value) = @_;
562     $value =~ s/\s*$//;
563     return $value if $value eq '';
564     return undef if $value =~ /^~$/;
565     return $value
566       unless $value =~ /^[\@\`]/ or
567              $value =~ /^[\-\?]\s/;
568     $self->die('YAML_PARSE_ERR_BAD_IMPLICIT', $value);
569 }
570
571 # Unfold a YAML multiline scalar into a single string.
572 sub _parse_unfold {
573     my $self = shift;
574     my ($chomp) = @_;
575     my $node = '';
576     my $space = 0;
577     while (not $self->done and $self->indent == $self->offset->[$self->level]) {
578         $node .= $self->content. "\n";
579         $self->_parse_next_line(LEAF);
580     }
581     $node =~ s/^(\S.*)\n(?=\S)/$1 /gm;
582     $node =~ s/^(\S.*)\n(\n+\S)/$1$2/gm;
583     $node =~ s/\n*\Z// unless $chomp eq '+';
584     $node .= "\n" unless $chomp;
585     return $node;
586 }
587
588 # Parse a YAML block style scalar. This is like a Perl here-document.
589 sub _parse_block {
590     my $self = shift;
591     my ($chomp) = @_;
592     my $node = '';
593     while (not $self->done and $self->indent == $self->offset->[$self->level]) {
594         $node .= $self->content . "\n";
595         $self->_parse_next_line(LEAF);
596     }
597     return $node if '+' eq $chomp;
598     $node =~ s/\n*\Z/\n/;
599     $node =~ s/\n\Z// if $chomp eq '-';
600     return $node;
601 }
602
603 # Handle Perl style '#' comments. Comments must be at the same indentation
604 # level as the collection line following them.
605 sub _parse_throwaway_comments {
606     my $self = shift;
607     while (@{$self->lines} and
608            $self->lines->[0] =~ m{^\s*(\#|$)}
609           ) {
610         shift @{$self->lines};
611         $self->{line}++;
612     }
613     $self->eos($self->{done} = not @{$self->lines});
614 }
615
616 # This is the routine that controls what line is being parsed. It gets called
617 # once for each line in the YAML stream.
618 #
619 # This routine must:
620 # 1) Skip past the current line
621 # 2) Determine the indentation offset for a new level
622 # 3) Find the next _content_ line
623 #   A) Skip over any throwaways (Comments/blanks)
624 #   B) Set $self->indent, $self->content, $self->line
625 # 4) Expand tabs appropriately
626 sub _parse_next_line {
627     my $self = shift;
628     my ($type) = @_;
629     my $level = $self->level;
630     my $offset = $self->offset->[$level];
631     $self->die('YAML_EMIT_ERR_BAD_LEVEL') unless defined $offset;
632     shift @{$self->lines};
633     $self->eos($self->{done} = not @{$self->lines});
634     return if $self->eos;
635     $self->{line}++;
636
637     # Determine the offset for a new leaf node
638     if ($self->preface =~
639         qr/(?:^|\s)(?:$FOLD_CHAR|$LIT_CHAR_RX)(?:-|\+)?(\d*)\s*$/
640        ) {
641         $self->die('YAML_PARSE_ERR_ZERO_INDENT')
642           if length($1) and $1 == 0;
643         $type = LEAF;
644         if (length($1)) {
645             $self->offset->[$level + 1] = $offset + $1;
646         }
647         else {
648             # First get rid of any comments.
649             while (@{$self->lines} && ($self->lines->[0] =~ /^\s*#/)) {
650                 $self->lines->[0] =~ /^( *)/;
651                 last unless length($1) <= $offset;
652                 shift @{$self->lines};
653                 $self->{line}++;
654             }
655             $self->eos($self->{done} = not @{$self->lines});
656             return if $self->eos;
657             if ($self->lines->[0] =~ /^( *)\S/ and length($1) > $offset) {
658                 $self->offset->[$level+1] = length($1);
659             }
660             else {
661                 $self->offset->[$level+1] = $offset + 1;
662             }
663         }
664         $offset = $self->offset->[++$level];
665     }
666     # Determine the offset for a new collection level
667     elsif ($type == COLLECTION and
668            $self->preface =~ /^(\s*(\!\S*|\&\S+))*\s*$/) {
669         $self->_parse_throwaway_comments();
670         if ($self->eos) {
671             $self->offset->[$level+1] = $offset + 1;
672             return;
673         }
674         else {
675             $self->lines->[0] =~ /^( *)\S/ or
676                 $self->die('YAML_PARSE_ERR_NONSPACE_INDENTATION');
677             if (length($1) > $offset) {
678                 $self->offset->[$level+1] = length($1);
679             }
680             else {
681                 $self->offset->[$level+1] = $offset + 1;
682             }
683         }
684         $offset = $self->offset->[++$level];
685     }
686
687     if ($type == LEAF) {
688         while (@{$self->lines} and
689                $self->lines->[0] =~ m{^( *)(\#)} and
690                length($1) < $offset
691               ) {
692             shift @{$self->lines};
693             $self->{line}++;
694         }
695         $self->eos($self->{done} = not @{$self->lines});
696     }
697     else {
698         $self->_parse_throwaway_comments();
699     }
700     return if $self->eos;
701
702     if ($self->lines->[0] =~ /^---(\s|$)/) {
703         $self->done(1);
704         return;
705     }
706     if ($type == LEAF and
707         $self->lines->[0] =~ /^ {$offset}(.*)$/
708        ) {
709         $self->indent($offset);
710         $self->content($1);
711     }
712     elsif ($self->lines->[0] =~ /^\s*$/) {
713         $self->indent($offset);
714         $self->content('');
715     }
716     else {
717         $self->lines->[0] =~ /^( *)(\S.*)$/;
718         while ($self->offset->[$level] > length($1)) {
719             $level--;
720         }
721         $self->die('YAML_PARSE_ERR_INCONSISTENT_INDENTATION')
722           if $self->offset->[$level] != length($1);
723         $self->indent(length($1));
724         $self->content($2);
725     }
726     $self->die('YAML_PARSE_ERR_INDENTATION')
727       if $self->indent - $offset > 1;
728 }
729
730 #==============================================================================
731 # Utility subroutines.
732 #==============================================================================
733
734 # Printable characters for escapes
735 my %unescapes = (
736    0 => "\x00",
737    a => "\x07",
738    t => "\x09",
739    n => "\x0a",
740    'v' => "\x0b", # Potential v-string error on 5.6.2 if not quoted
741    f => "\x0c",
742    r => "\x0d",
743    e => "\x1b",
744    '\\' => '\\',
745   );
746
747 # Transform all the backslash style escape characters to their literal meaning
748 sub _unescape {
749     my $self = shift;
750     my ($node) = @_;
751     $node =~ s/\\([never\\fart0]|x([0-9a-fA-F]{2}))/
752               (length($1)>1)?pack("H2",$2):$unescapes{$1}/gex;
753     return $node;
754 }
755
756 1;