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