modules/override/YAML/Loader.pm

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