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;