local-lib5/lib/perl5/YAML/Loader.pm

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