home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / tsw / TSW_3.4.0.exe / Apache2 / perl / YAML.pm < prev    next >
Encoding:
Perl POD Document  |  2002-06-25  |  47.1 KB  |  1,580 lines
  1. package YAML; 
  2. $VERSION = '0.35';
  3.  
  4. # This module implements a Loader and Dumper for the YAML serialization
  5. # language, VERSION 1.0 TRIAL2. (http://www.yaml.org/spec/)
  6.  
  7. require Exporter;
  8. @ISA = qw(Exporter);
  9. # Basic interface is Load & Dump
  10. # Phasing out Store in favor of Dump XXX
  11. # Leave it in for now. XXX
  12. @EXPORT = qw(Load Dump Store);
  13. # Provide a bunch of aliases for TMTOWTDI's sake
  14. @EXPORT_OK = qw(LoadFile DumpFile
  15.                 Dumper Eval 
  16.                 freeze thaw
  17.                 VALUE COMMENT
  18.                 Bless Blessed
  19.                );
  20. # Export groups
  21. %EXPORT_TAGS = (all => [qw(Load Dump Store LoadFile DumpFile Bless Blessed)],
  22.                 constants => [qw(VALUE COMMENT)],
  23.                 Storable => [qw(freeze thaw)],
  24.                 POE => [qw(freeze thaw)],
  25.                );
  26.  
  27. use strict;
  28. use YAML::Node;
  29. use YAML::Transfer;
  30. use Carp;
  31.  
  32. sub PRINT { print STDERR @_, "\n" } # XXX
  33. sub DUMP { use Data::Dumper(); print STDERR Data::Dumper::Dumper(@_) } # XXX
  34.  
  35. # Context constants
  36. use constant LEAF => 1;
  37. use constant COLLECTION => 2;
  38. use constant KEY => 3;
  39. use constant BLESSED => 4;
  40. use constant FROMARRAY => 5;
  41. use constant VALUE => "\x07YAML\x07VALUE\x07";
  42. use constant COMMENT => "\x07YAML\x07COMMENT\x07";
  43.  
  44. # These are the user changable options
  45. {
  46.     no strict 'vars'; 
  47.     $Indent = 2 unless defined $Indent;
  48.     $UseHeader = 1 unless defined $UseHeader;
  49.     $UseVersion = 1 unless defined $UseVersion;
  50.     $SortKeys = 1 unless defined $SortKeys;
  51.     $AnchorPrefix = '' unless defined $AnchorPrefix;
  52.     $UseCode = 0 unless defined $UseCode;
  53.     $DumpCode = '' unless defined $DumpCode;
  54.     $LoadCode = '' unless defined $LoadCode;
  55.     $ForceBlock = 0 unless defined $ForceBlock;
  56.     $UseBlock = 0 unless defined $UseBlock;
  57.     $UseFold = 0 unless defined $UseFold;
  58.     $CompressSeries = 1 unless defined $CompressSeries;
  59.     $InlineSeries = 0 unless defined $InlineSeries;
  60.     $UseAliases = 1 unless defined $UseAliases;
  61.     $Purity = 0 unless defined $Purity;
  62.     $DateClass = '' unless defined $DateClass;
  63. }
  64.  
  65. # Common YAML character sets
  66. my $WORD_CHAR = '[A-Za-z-]';
  67. my $ESCAPE_CHAR = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f]';
  68. my $INDICATOR_CHAR = '[#-:?*&!|\\\\^@%]';
  69. my $FOLD_CHAR = '>';
  70. my $BLOCK_CHAR = '|';    
  71. my $BLOCK_CHAR_RX = "\\$BLOCK_CHAR";    
  72.  
  73. # $o is the YAML object. It contains the complete state of the YAML.pm
  74. # process. This is set at the file scope level so that I can avoid using
  75. # OO syntax or passing the object around in function calls.
  76. #
  77. # When callback are added to YAML.pm the calling code will have to save
  78. # the object so that it won't get clobbered. Also YAML.pm can't be subclassed.
  79. # 
  80. # The purpose of this is for efficiency and also for much simpler code.
  81. my $o;
  82.  
  83. # YAML OO constructor function
  84. sub new {
  85.     my $class = shift;
  86.     my $o = {
  87.              stream => '',
  88.              level => 0,
  89.              anchor => 1,
  90.              Indent => $YAML::Indent,
  91.              UseHeader => $YAML::UseHeader,
  92.              UseVersion => $YAML::UseVersion,
  93.              SortKeys => $YAML::SortKeys,
  94.              AnchorPrefix => $YAML::AnchorPrefix,
  95.              DumpCode => $YAML::DumpCode,
  96.              LoadCode => $YAML::LoadCode,
  97.              ForceBlock => $YAML::ForceBlock,
  98.              UseBlock => $YAML::UseBlock,
  99.              UseFold => $YAML::UseFold,
  100.              CompressSeries => $YAML::CompressSeries,
  101.              InlineSeries => $YAML::InlineSeries,
  102.              UseAliases => $YAML::UseAliases,
  103.              Purity => $YAML::Purity,
  104.              DateClass => $YAML::DateClass,
  105.             };
  106.     bless $o, $class;
  107.     set_default($o, 'DumpCode', $YAML::UseCode);
  108.     set_default($o, 'LoadCode', $YAML::UseCode);
  109.     return $o if is_valid($o);
  110. }
  111.  
  112. my $global = {}; # A global lookup
  113. sub Bless { YAML::bless($global, @_) }
  114. sub Blessed { YAML::blessed($global, @_) }
  115.  
  116. sub blessed {
  117.     my ($o, $ref) = @_;
  118.     $ref = \$_[0] unless ref $ref;
  119.     my (undef, undef, $node_id) = YAML::Node::info($ref);
  120.     $o->{blessed}{$node_id};
  121. }
  122.     
  123. sub bless {
  124.     my ($o, $ref, $blessing) = @_;
  125.     my $ynode;
  126.     $ref = \$_[0] unless ref $ref;
  127.     my (undef, undef, $node_id) = YAML::Node::info($ref);
  128.     if (not defined $blessing) {
  129.         $ynode = YAML::Node->new($ref);
  130.     }
  131.     elsif (ref $blessing) {
  132.         croak unless ynode($blessing);
  133.         $ynode = $blessing;
  134.     }
  135.     else {
  136.         no strict 'refs';
  137.         my $transfer = $blessing . "::yaml_dump";
  138.         croak unless defined &{$transfer};
  139.         $ynode = &{$transfer}($ref);
  140.         croak unless ynode($ynode);
  141.     }
  142.     $o->{blessed}{$node_id} = $ynode;
  143.     my $object = ynode($ynode) or croak;
  144.     return $object;
  145. }
  146.  
  147. sub stream {
  148.     my ($o, $stream) = @_;
  149.     if (not defined $stream) {
  150.         return $o->{$stream};
  151.     }
  152.     elsif (ref($stream) eq 'CODE') {
  153.         $o->{stream_fetch} = $stream;
  154.         $o->{stream_eos} = 0;
  155.     }
  156.     elsif ($stream eq '') {
  157.         $o->{stream} = '';
  158.     }
  159.     else {
  160.         $o->{stream} .= $stream;
  161.     }
  162. }
  163.  
  164. sub set_default {
  165.     my ($o, $option, $default) = (@_);
  166.     return if length $o->{$option};
  167.     if (length $default) {
  168.         $o->{$option} = $default;
  169.     }
  170.     else {
  171.         $o->{$option} = -1;
  172.     }
  173. }
  174.  
  175. sub is_valid { 
  176.     my ($o) = (@_);
  177.     croak YAML_DUMP_ERR_INVALID_INDENT($o->{Indent}) 
  178.       unless ($o->{Indent} =~ /^(\d+)$/) and $1 > 0;
  179.     # NOTE: Add more tests...
  180.     return 1;
  181. }
  182.  
  183. #==============================================================================
  184. # Save the contents of a Dump operation to a file. If the file exists
  185. # and has data, and a concatenation was requested, then verify the
  186. # existing header.
  187. sub DumpFile {
  188.     my $filename = shift;
  189.     local $/ = "\n"; # reset special to "sane"
  190.     my $mode = '>';
  191.     if ($filename =~ /^\s*(>{1,2})\s*(.*)$/) {
  192.         ($mode, $filename) = ($1, $2);
  193.     }
  194.     if ($mode eq '>>' && -f $filename && -s $filename) {
  195.         open MYYAML, "< $filename" 
  196.             or croak YAML_LOAD_ERR_FILE_INPUT($filename, $!);
  197.         my $line = <MYYAML>;
  198.         close MYYAML;
  199.         croak YAML_DUMP_ERR_FILE_CONCATENATE($filename)
  200.           unless $line =~ /^---(\s|$)/;
  201.     }
  202.     open MYYAML, "$mode $filename"
  203.       or croak YAML_DUMP_ERR_FILE_OUTPUT($filename, $!);
  204.     print MYYAML YAML::Dump(@_);
  205.     close MYYAML;
  206. }
  207.     
  208. # Serialize a list of elements
  209. sub Dump {
  210.     $o = YAML->new();
  211.     $o->dump(@_);
  212. }
  213.  
  214. sub Store {
  215.     warn YAML_DUMP_WARN_STORE() if $^W;
  216.     goto &Dump;
  217. }
  218.  
  219. # Aliases for Dump
  220. *freeze = *freeze = \&Dump;    # alias for Storable or POE users
  221.  
  222. # OO version of Dump. YAML->new->dump($foo); 
  223. sub dump {
  224.     $o = shift; 
  225.     # local $| = 1; # set buffering to "hot" (for testing) XXX
  226.     local $/ = "\n"; # reset special to "sane" XXX (danger) fix for callbacks
  227.     $o->{stream} = '';
  228.     $o->{document} = 0;
  229.     for my $document (@_) {
  230.         $o->{document}++;
  231.         $o->{transferred} = {};
  232.         $o->{id_refcnt} = {};
  233.         $o->{id_anchor} = {};
  234.         $o->{anchor} = 1;
  235.         $o->{level} = 0;
  236.         $o->{offset}[0] = 0 - $o->{Indent};
  237.         _prewalk($document);
  238.         _emit_header($document);
  239.         _emit_node($document);
  240.     }
  241.     return $o->{stream};
  242. }
  243.  
  244. # Every YAML document in the stream must begin with a YAML header, unless
  245. # there is only a single document and the user requests "no header".
  246. sub _emit_header {
  247.     my ($node) = @_;
  248.     if (not $o->{UseHeader} and 
  249.         $o->{document} == 1
  250.        ) {
  251.         croak YAML_DUMP_ERR_NO_HEADER() unless ref($node) =~ /^(HASH|ARRAY)$/;
  252.         croak YAML_DUMP_ERR_NO_HEADER() if ref($node) eq 'HASH' and 
  253.                                            keys(%$node) == 0;
  254.         croak YAML_DUMP_ERR_NO_HEADER() if ref($node) eq 'ARRAY' and 
  255.                                            @$node == 0;
  256.         # XXX Also croak if aliased, blessed, or ynode
  257.         $o->{headless} = 1;
  258.         return;
  259.     }
  260.     $o->{stream} .= '---';
  261.     if ($o->{UseVersion}) {
  262.         $o->{stream} .= " #YAML:1.0";
  263.     }
  264. }
  265.  
  266. # Walk the tree to be dumped and keep track of its reference counts.
  267. # This function is where the Dumper does all its work. All transfers
  268. # happen here.
  269. sub _prewalk {
  270.     my $value;
  271.     my ($class, $type, $node_id) = YAML::Node::info(\$_[0]);
  272.     # Handle typeglobs
  273.     if ($type eq 'GLOB') {
  274.         $value = $o->{transferred}{$node_id} = 
  275.           YAML::Transfer::glob::yaml_dump($_[0]);
  276.         return _prewalk($value);
  277.     }
  278.     # Handle regexps
  279.     if (ref($_[0]) eq 'Regexp') {  
  280.         $o->{transferred}{$node_id} = YAML::Transfer::regexp::yaml_dump($_[0]);
  281.         return;
  282.     }
  283.     # Handle Purity for scalars. XXX can't find a use case yet. Might be YAGNI.
  284.     if (not ref $_[0]) {
  285.         $o->{id_refcnt}{$node_id}++ if $o->{Purity};
  286.         return;
  287.     }
  288.     # Make a copy of original
  289.     $value = $_[0];
  290.     ($class, $type, $node_id) = YAML::Node::info($value);
  291.     # Look for things already transferred.
  292.     if ($o->{transferred}{$node_id}) {
  293.         (undef, undef, $node_id) = (ref $o->{transferred}{$node_id})
  294.           ? YAML::Node::info($o->{transferred}{$node_id})
  295.           : YAML::Node::info(\ $o->{transferred}{$node_id});
  296.         $o->{id_refcnt}{$node_id}++;
  297.         return;
  298.     }
  299.     # Handle code refs
  300.     if ($type eq 'CODE') {
  301.         $o->{transferred}{$node_id} = 'crufty tracking reference placeholder';
  302.         YAML::Transfer::code::yaml_dump($o->{DumpCode},
  303.                                         $_[0], 
  304.                                         $o->{transferred}{$node_id});
  305.         ($class, $type, $node_id) = 
  306.           YAML::Node::info(\ $o->{transferred}{$node_id});
  307.         $o->{id_refcnt}{$node_id}++;
  308.         return;
  309.     }
  310.     # Handle blessed things
  311.     elsif (defined $class) {
  312.         no strict 'refs';
  313.         if ($class eq $o->{DateClass}) {
  314.             $value = eval "&${class}::yaml_dump(\$value)";
  315.         }
  316.         elsif (defined &{$class . "::yaml_dump"}) {
  317.             $value = eval "&${class}::yaml_dump(\$value)";
  318.         }
  319.         elsif ($type eq 'SCALAR') {
  320.             $o->{transferred}{$node_id} = 'tracking reference placeholder';
  321.             YAML::Transfer::blessed::yaml_dump
  322.               ($_[0], $o->{transferred}{$node_id});
  323.             ($class, $type, $node_id) =
  324.               YAML::Node::info(\ $o->{transferred}{$node_id});
  325.             $o->{id_refcnt}{$node_id}++;
  326.             return;
  327.         }
  328.         else {
  329.             $value = YAML::Transfer::blessed::yaml_dump($value);
  330.         }
  331.         $o->{transferred}{$node_id} = $value;
  332.         (undef, $type, $node_id) = YAML::Node::info($value);
  333.     }
  334.     # Handle YAML Blessed things
  335.     if (defined $global->{blessed}{$node_id}) {
  336.         $value = $global->{blessed}{$node_id};
  337.         $o->{transferred}{$node_id} = $value;
  338.         ($class, $type, $node_id) = YAML::Node::info($value);
  339.         return _prewalk($value);
  340.     }
  341.     # Handle hard refs
  342.     if ($type eq 'REF' or $type eq 'SCALAR') {
  343.         $value = YAML::Transfer::ref::yaml_dump($value);
  344.         $o->{transferred}{$node_id} = $value;
  345.         (undef, $type, $node_id) = YAML::Node::info($value);
  346.     }
  347.     # Handle ref-to-glob's
  348.     elsif ($type eq 'GLOB') {
  349.         my $ref_ynode = $o->{transferred}{$node_id} =
  350.           YAML::Transfer::ref::yaml_dump($value);
  351.  
  352.         my $glob_ynode = $ref_ynode->{&VALUE} = 
  353.           YAML::Transfer::glob::yaml_dump($$value);
  354.  
  355.         (undef, undef, $node_id) = YAML::Node::info($glob_ynode);
  356.         $o->{transferred}{$node_id} = $glob_ynode;
  357.         return _prewalk($glob_ynode);
  358.     }
  359.       
  360.     # Increment ref count for node
  361.     return if ++($o->{id_refcnt}{$node_id}) > 1;
  362.  
  363.     # Continue walking
  364.     if ($type eq 'HASH') {
  365.         _prewalk($value->{$_}) for keys %{$value};
  366.     }
  367.     elsif ($type eq 'ARRAY') {
  368.         _prewalk($_) for @{$value};
  369.     }
  370. }
  371.  
  372. # Every data element and sub data element is a node. Everything emitted
  373. # goes through this function.
  374. sub _emit_node {
  375.     my ($type, $node_id);
  376.     my $ref = ref($_[0]);
  377.     if ($ref and $ref ne 'Regexp') {
  378.         (undef, $type, $node_id) = YAML::Node::info($_[0]);
  379.     }
  380.     else {
  381.         $type = $ref || 'SCALAR';
  382.         (undef, undef, $node_id) = YAML::Node::info(\$_[0]);
  383.     }
  384.  
  385.     my ($ynode, $family) = ('') x 2;
  386.     my ($value, $context) = (@_, 0); # XXX don't copy scalars
  387.     if (defined $o->{transferred}{$node_id}) {
  388.         $value = $o->{transferred}{$node_id};
  389.         $ynode = ynode($value);
  390.         if (ref $value) {
  391.             $family = defined $ynode ? $ynode->family->short : '';
  392.             (undef, $type, $node_id) = YAML::Node::info($value);
  393.         }
  394.         else {
  395.             $family = ynode($o->{transferred}{$node_id})->family->short;
  396.             $type = 'SCALAR';
  397.             (undef, undef, $node_id) = 
  398.               YAML::Node::info(\ $o->{transferred}{$node_id});
  399.         }
  400.     }
  401.     elsif ($ynode = ynode($value)) {
  402.         $family = $ynode->family->short;
  403.     }
  404.  
  405.     if ($o->{UseAliases}) {
  406.         $o->{id_refcnt}{$node_id} ||= 0;
  407.         if ($o->{id_refcnt}{$node_id} > 1) {
  408.             if (defined $o->{id_anchor}{$node_id}) {
  409.                 $o->{stream} .= ' *' . $o->{id_anchor}{$node_id} . "\n";
  410.                 return;
  411.             }
  412.             my $anchor = $o->{AnchorPrefix} . $o->{anchor}++;
  413.             $o->{stream} .= ' &' . $anchor;
  414.             $o->{id_anchor}{$node_id} = $anchor;
  415.         }
  416.     }
  417.  
  418.     return _emit_scalar($value, $family) if $type eq 'SCALAR' and $family;
  419.     return _emit_str($value) if $type eq 'SCALAR';
  420.     return _emit_mapping($value, $family, $node_id, $context) if $type eq 'HASH';
  421.     return _emit_sequence($value, $family) if $type eq 'ARRAY';
  422.     warn YAML_DUMP_WARN_BAD_NODE_TYPE($type) if $^W;
  423.     return _emit_str("$value");
  424. }
  425.  
  426. # A YAML mapping is akin to a Perl hash. 
  427. sub _emit_mapping {
  428.     my ($value, $family, $node_id, $context) = @_;
  429.     $o->{stream} .= " !$family" if $family;
  430.  
  431.     # Sometimes 'keys' fails. Like on a bad tie implementation.
  432.     my $empty_hash = not(eval {keys %$value});
  433.     warn YAML_EMIT_WARN_KEYS($@) if $^W and $@;
  434.     return ($o->{stream} .= " {}\n") if $empty_hash;
  435.         
  436.     # If CompressSeries is on (default) and legal is this context, then
  437.     # use it and make the indent level be 2 for this node.
  438.     if ($context == FROMARRAY and $o->{CompressSeries} and
  439.         not (defined $o->{id_anchor}{$node_id} or $family or $empty_hash)
  440.        ) {
  441.         $o->{stream} .= ' ';
  442.         $o->{offset}[$o->{level}+1] = $o->{offset}[$o->{level}] + 2;
  443.     }
  444.     else {
  445.         $context = 0;
  446.         $o->{stream} .= "\n" unless $o->{headless} && not($o->{headless} = 0);
  447.         $o->{offset}[$o->{level}+1] = $o->{offset}[$o->{level}] + $o->{Indent};
  448.     }
  449.  
  450.     $o->{level}++;
  451.     my @keys;
  452.     if ($o->{SortKeys} == 1) {
  453.         if (ynode($value)) {
  454.             @keys = keys %$value;
  455.         }
  456.         else {
  457.             @keys = sort keys %$value;
  458.         }
  459.     }
  460.     elsif ($o->{SortKeys} == 2) {
  461.         @keys = sort keys %$value;
  462.     }
  463.     # XXX This is hackish but sometimes handy. Not sure whether to leave it in.
  464.     elsif (ref($o->{SortKeys}) eq 'ARRAY') {
  465.         my $i = 1;
  466.         my %order = map { ($_, $i++) } @{$o->{SortKeys}};
  467.         @keys = sort {
  468.             (defined $order{$a} and defined $order{$b})
  469.               ? ($order{$a} <=> $order{$b})
  470.               : ($a cmp $b);
  471.         } keys %$value;
  472.     }
  473.     else {
  474.         @keys = keys %$value;
  475.     }
  476.     # Force the YAML::VALUE ('=') key to sort last.
  477.     if (exists $value->{&VALUE}) {
  478.         for (my $i = 0; $i < @keys; $i++) {
  479.             if ($keys[$i] eq &VALUE) {
  480.                 splice(@keys, $i, 1);
  481.                 push @keys, &VALUE;
  482.                 last;
  483.             }
  484.         }
  485.     }
  486.  
  487.     for my $key (@keys) {
  488.         _emit_key($key, $context);
  489.         $context = 0;
  490.         $o->{stream} .= ':';
  491.         _emit_node($value->{$key});
  492.     }
  493.     $o->{level}--;
  494. }
  495.  
  496. # A YAML series is akin to a Perl array.
  497. sub _emit_sequence {
  498.     my ($value, $family) = @_;
  499.     $o->{stream} .= " !$family" if $family;
  500.  
  501.     return ($o->{stream} .= " []\n") if @$value == 0;
  502.         
  503.     $o->{stream} .= "\n" unless $o->{headless} && not($o->{headless} = 0);
  504.  
  505.     # XXX Really crufty feature. Better implemented by ynodes.
  506.     if ($o->{InlineSeries} and
  507.         @$value <= $o->{InlineSeries} and
  508.         not (scalar grep {ref or /\n/} @$value)
  509.        ) {
  510.         $o->{stream} =~ s/\n\Z/ /;
  511.         $o->{stream} .= '[';
  512.         for (my $i = 0; $i < @$value; $i++) {
  513.             _emit_str($value->[$i], KEY);
  514.             last if $i == $#{$value};
  515.             $o->{stream} .= ', ';
  516.         }
  517.         $o->{stream} .= "]\n";
  518.         return;
  519.     }
  520.  
  521.     $o->{offset}[$o->{level} + 1] = $o->{offset}[$o->{level}] + $o->{Indent};
  522.     $o->{level}++;
  523.     for my $val (@$value) {
  524.         $o->{stream} .= ' ' x $o->{offset}[$o->{level}];
  525.         $o->{stream} .= '-';
  526.         _emit_node($val, FROMARRAY);
  527.     }
  528.     $o->{level}--;
  529. }
  530.  
  531. # Emit a mapping key
  532. sub _emit_key {
  533.     my ($value, $context) = @_;
  534.     $o->{stream} .= ' ' x $o->{offset}[$o->{level}]
  535.       unless $context == FROMARRAY;
  536.     _emit_str($value, KEY);
  537. }
  538.  
  539. # Emit a blessed SCALAR
  540. sub _emit_scalar {
  541.     my ($value, $family) = @_;
  542.     $o->{stream} .= " !$family";
  543.     _emit_str($value, BLESSED);
  544. }
  545.  
  546. # Emit a string value. YAML has many scalar styles. This routine attempts to
  547. # guess the best style for the text.
  548. sub _emit_str {
  549.     my $type = $_[1] || 0;
  550.  
  551.     # Use heuristics to find the best scalar emission style.
  552.     $o->{offset}[$o->{level} + 1] = $o->{offset}[$o->{level}] + $o->{Indent};
  553.     $o->{level}++;
  554.  
  555.     if (defined $_[0] and
  556.         $_[0] !~ /$ESCAPE_CHAR/ and
  557.         (length($_[0]) > 50 or $_[0] =~ /\n\s/ or
  558.          ($o->{ForceBlock} and $type != KEY)
  559.         ) 
  560.        ) {
  561.         $o->{stream} .= ($type == KEY) ? '? ' : ' ';
  562.         if (($o->{UseFold} and not $o->{ForceBlock}) or
  563.             ($_[0] =~ /^\S[^\n]{76}/m)
  564.            ) {  
  565.             if (is_valid_implicit($_[0]) && # XXX Check implicit check
  566.                 $type != BLESSED
  567.                ) {
  568.                 $o->{stream} .= '! ';
  569.             }
  570.             _emit_nested($FOLD_CHAR, $_[0]);
  571.         }
  572.         else {
  573.             _emit_nested($BLOCK_CHAR, $_[0]);
  574.         }
  575.         $o->{stream} .= "\n";
  576.     }
  577.     else {
  578.         $o->{stream} .= ' ' if $type != KEY;
  579.         if (defined $_[0] && $_[0] eq VALUE) {
  580.             $o->{stream} .= '=';
  581.         }
  582.         elsif (is_valid_implicit($_[0])) {
  583.             _emit_simple($_[0]);
  584.         }
  585.         elsif ($_[0] =~ /$ESCAPE_CHAR|\n|\'/) {
  586.             _emit_double($_[0]);
  587.         }
  588.         else {
  589.             _emit_single($_[0]);
  590.         }
  591.         $o->{stream} .= "\n" if $type != KEY;
  592.     }
  593.     
  594.     $o->{level}--;
  595.  
  596.     return;
  597. }
  598.  
  599. # Check whether or not a scalar should be emitted as an simple scalar.
  600. sub is_valid_implicit {
  601.     return 1 if not defined $_[0];
  602.     return 1 if $_[0] =~ /^(-?\d+)$/;                 # !int
  603.     return 1 if $_[0] =~ /^-?\d+\.\d+$/;              # !float
  604.     return 1 if $_[0] =~ /^-?\d+e[+-]\d+$/;           # !float
  605.     # XXX - Detect date objects someday (or not)
  606.     return 0 if $_[0] =~ /$ESCAPE_CHAR/;
  607.     return 0 if $_[0] =~ /(^\s|\:( |$)|\#( |$)|\s$)/;
  608.     return 1 if $_[0] =~ /^\w/;                       # !str
  609.     return 0;
  610. }
  611.  
  612. # A nested scalar is either block or folded 
  613. sub _emit_nested {
  614.     my ($indicator, $value) = @_;
  615.     $o->{stream} .= $indicator;
  616.     $value =~ /(\n*)\Z/;
  617.     my $chomp = length $1 ? (length $1 > 1) ? '+' : '' : '-';
  618.     $value = '~' if not defined $value;
  619.     $o->{stream} .= $chomp;
  620.     $o->{stream} .= $o->{Indent} if $value =~ /^\s/;
  621.     if ($indicator eq $FOLD_CHAR) {
  622.         $value = fold($value);
  623.         chop $value unless $chomp eq '+';
  624.     }
  625.     $o->{stream} .= indent($value);
  626. }
  627.  
  628. # Simple means that the scalar is unquoted. It is analyzed for its type
  629. # implicitly using regexes.
  630. sub _emit_simple {
  631.     $o->{stream} .= defined $_[0] ? $_[0] : '~';
  632. }
  633.  
  634. # Double quoting is for single lined escaped strings.
  635. sub _emit_double {
  636.     (my $escaped = escape($_[0])) =~ s/"/\\"/g;
  637.     $o->{stream} .= qq{"$escaped"};
  638. }
  639.  
  640. # Single quoting is for single lined unescaped strings.
  641. sub _emit_single {
  642.     $o->{stream} .= "'$_[0]'";
  643. }
  644.  
  645. #==============================================================================
  646. # Read a YAML stream from a file and call Load on it.
  647. sub LoadFile {
  648.     my $filename = shift;
  649.     local $/ = "\n"; # reset special to "sane"
  650.     open MYYAML, $filename or croak YAML_LOAD_ERR_FILE_INPUT($filename, $!);
  651.     my $yaml = join '', <MYYAML>;
  652.     close MYYAML;
  653.     return Load($yaml);
  654. }
  655.  
  656. # Deserialize a YAML stream into a list of data elements
  657. sub Load {
  658.     croak YAML_LOAD_USAGE() unless @_ == 1;
  659.     $o = YAML->new;
  660.     $o->{stream} = defined $_[0] ? $_[0] : '';
  661.     return load();
  662. }
  663.  
  664. # Aliases for Load
  665. *Undent = *Undent = \&Load;
  666. *Eval = *Eval = \&Load;
  667. *thaw = *thaw = \&Load;
  668.  
  669. # OO version of Load
  670. sub load {
  671.     # local $| = 1; # set buffering to "hot" (for testing)
  672.     local $/ = "\n"; # reset special to "sane"
  673.     return _parse();
  674. }
  675.  
  676. # Top level function for parsing. Parse each document in order and
  677. # handle processing for YAML headers.
  678. sub _parse {
  679.     my (%directives, $preface);
  680.     $o->{stream} =~ s|\015\012|\012|g;
  681.     $o->{stream} =~ s|\015|\012|g;
  682.     $o->{line} = 0;
  683.     croak YAML_PARSE_ERR_BAD_CHARS() 
  684.       if $o->{stream} =~ /$ESCAPE_CHAR/;
  685.     croak YAML_PARSE_ERR_NO_FINAL_NEWLINE() 
  686.       if length($o->{stream}) and 
  687.          $o->{stream} !~ s/(.)\n\Z/$1/s;
  688.     @{$o->{lines}} = split /\x0a/, $o->{stream}, -1;
  689.     $o->{line} = 1;
  690.     # Throw away any comments or blanks before the header (or start of
  691.     # content for headerless streams)
  692.     _parse_throwaway_comments();
  693.     $o->{document} = 0;
  694.     $o->{documents} = [];
  695.     # Add an "assumed" header if there is no header and the stream is
  696.     # not empty (after initial throwaways).
  697.     if (not $o->{eos}) {
  698.         if ($o->{lines}[0] !~ /^---(\s|$)/) {
  699.             unshift @{$o->{lines}}, '--- #YAML:1.0';
  700.             $o->{line}--;
  701.         }
  702.     }
  703.  
  704.     # Main Loop. Parse out all the top level nodes and return them.
  705.     while (not $o->{eos}) {
  706.         $o->{anchor2node} = {};
  707.         $o->{document}++;
  708.         $o->{done} = 0;
  709.         $o->{level} = 0;
  710.         $o->{offset}[0] = -1;
  711.  
  712.         if ($o->{lines}[0] =~ /^---\s*(.*)$/) {
  713.             my @words = split /\s+/, $1;
  714.             %directives = ();
  715.             while (@words && $words[0] =~ /^#(\w+):(\S.*)$/) {
  716.                 my ($key, $value) = ($1, $2);
  717.                 shift(@words);
  718.                 if (defined $directives{$key}) {
  719.                     warn YAML_PARSE_WARN_MULTIPLE_DIRECTIVES
  720.                       ($key, $o->{document}) if $^W;
  721.                     next;
  722.                 }
  723.                 $directives{$key} = $value;
  724.             }
  725.             $o->{preface} = join ' ', @words;
  726.         }
  727.         else {
  728.             croak YAML_PARSE_ERR_NO_SEPARATOR();
  729.         }
  730.  
  731.         if (not $o->{done}) {
  732.             _parse_next_line(COLLECTION);
  733.         }
  734.         if ($o->{done}) {
  735.             $o->{indent} = -1;
  736.             $o->{content} = '';
  737.         }
  738.  
  739.         $directives{YAML} ||= '1.0';
  740.         $directives{TAB} ||= 'NONE';
  741.         ($o->{major_version}, $o->{minor_version}) = 
  742.           split /\./, $directives{YAML}, 2;
  743.         croak YAML_PARSE_ERR_BAD_MAJOR_VERSION($directives{YAML})
  744.           if ($o->{major_version} ne '1');
  745.         warn YAML_PARSE_WARN_BAD_MINOR_VERSION($directives{YAML})
  746.           if ($^W and $o->{minor_version} ne '0');
  747.         croak "Unrecognized TAB policy"  # XXX add to ::Error
  748.           unless $directives{TAB} =~ /^(NONE|\d+)(:HARD)?$/;
  749.         
  750.  
  751.         push @{$o->{documents}}, _parse_node();
  752.     }
  753.     return wantarray ? @{$o->{documents}} : $o->{documents}[-1];
  754. }
  755.  
  756. # This function is the dispatcher for parsing each node. Every node
  757. # recurses back through here. (Inlines are an exception as they have
  758. # their own sub-parser.)
  759. sub _parse_node {
  760. # ??????????????????????????????????????    
  761. # $|=1;
  762. # print <<END;
  763. # _parse_node ${\++$YAML::x}
  764. # indent  - $o->{indent}
  765. # preface - $o->{preface}
  766. # content - $o->{content}
  767. # level   - $o->{level}
  768. # offsets - @{$o->{offset}}
  769. # END
  770. # ??????????????????????????????????????    
  771.     my $preface = $o->{preface};
  772.     $o->{preface} = '';
  773.     my ($node, $type, $indicator, $escape, $chomp) = ('') x 5;
  774.     my ($anchor, $alias, $explicit, $implicit, $class) = ('') x 5;
  775.     ($anchor, $alias, $explicit, $implicit, $class, $preface) = 
  776.       _parse_qualifiers($preface);
  777.     if ($anchor) {
  778.         $o->{anchor2node}{$anchor} = CORE::bless [], 'YAML-anchor2node';
  779.     }
  780.     $o->{inline} = '';
  781.     while (length $preface) {
  782.         my $line = $o->{line} - 1;
  783.         # XXX rking suggests refactoring the following regex and its evil twin
  784.         if ($preface =~ s/^($FOLD_CHAR|$BLOCK_CHAR_RX)(-|\+)?\d*\s*//) { 
  785.             $indicator = $1;
  786.             $chomp = $2 if defined($2);
  787.         }
  788.         else {
  789.             croak YAML_PARSE_ERR_TEXT_AFTER_INDICATOR() if $indicator;
  790.             $o->{inline} = $preface;
  791.             $preface = '';
  792.         }
  793.     }
  794.     if ($alias) {
  795.         croak YAML_PARSE_ERR_NO_ANCHOR($alias) 
  796.           unless defined $o->{anchor2node}{$alias};
  797.         if (ref($o->{anchor2node}{$alias}) ne 'YAML-anchor2node') {
  798.             $node = $o->{anchor2node}{$alias};
  799.         }
  800.         else {
  801.             $node = do {my $sv = "*$alias"};
  802.             push @{$o->{anchor2node}{$alias}}, [\$node, $o->{line}]; 
  803.         }
  804.     }
  805.     elsif (length $o->{inline}) {
  806.         $node = _parse_inline(1, $implicit, $explicit, $class);
  807.         if (length $o->{inline}) {
  808.             croak YAML_PARSE_ERR_SINGLE_LINE(); 
  809.         }
  810.     }
  811.     elsif ($indicator eq $BLOCK_CHAR) {
  812.         $o->{level}++;
  813.         $node = _parse_block($chomp);
  814.         $node = _parse_implicit($node) if $implicit;
  815.         $o->{level}--; 
  816.     }
  817.     elsif ($indicator eq $FOLD_CHAR) {
  818.         $o->{level}++;
  819.         $node = _parse_unfold($chomp);
  820.         $node = _parse_implicit($node) if $implicit;
  821.         $o->{level}--;
  822.     }
  823.     else {
  824.         $o->{level}++;
  825.         $o->{offset}[$o->{level}] ||= 0;
  826.         if ($o->{indent} == $o->{offset}[$o->{level}]) {
  827.             if ($o->{content} =~ /^-( |$)/) {
  828.                 $node = _parse_seq($anchor);
  829.             }
  830.             elsif ($o->{content} =~ /(^\?|\:( |$))/) {
  831.                 $node = _parse_mapping($anchor);
  832.             }
  833.             elsif ($preface =~ /^\s*$/) {
  834.                 $node = _parse_implicit('');
  835.             }
  836.             else {
  837.                 croak YAML_PARSE_ERR_BAD_NODE();
  838.             }
  839.         }
  840.         else {
  841.             $node = '';
  842.         }
  843.         $o->{level}--;
  844.     }
  845.     $#{$o->{offset}} = $o->{level};
  846.  
  847.     if ($explicit) {
  848.         if ($class) {
  849.             if (not ref $node) {
  850.                 my $copy = $node;
  851.                 undef $node;
  852.                 $node = \$copy;
  853.             }
  854.             CORE::bless $node, $class;
  855.         }
  856.         else {
  857.             $node = _parse_explicit($node, $explicit);
  858.         }
  859.     }
  860.     if ($anchor) {
  861.         if (ref($o->{anchor2node}{$anchor}) eq 'YAML-anchor2node') {
  862.             # XXX Can't remember what this code actually does
  863.             for my $ref (@{$o->{anchor2node}{$anchor}}) {
  864.                 ${$ref->[0]} = $node;
  865.                 warn YAML_LOAD_WARN_UNRESOLVED_ALIAS($anchor, $ref->[1]) if $^W;
  866.             }
  867.         }
  868.         $o->{anchor2node}{$anchor} = $node;
  869.     }
  870.     return $node;
  871. }
  872.  
  873. # Preprocess the qualifiers that may be attached to any node.
  874. sub _parse_qualifiers {
  875.     my ($preface) = @_;
  876.     my ($anchor, $alias, $explicit, $implicit, $class, $token) = ('') x 6;
  877.     $o->{inline} = '';
  878.     while ($preface =~ /^[&*!]/) {
  879.         my $line = $o->{line} - 1;
  880.         if ($preface =~ s/^\!(\S+)\s*//) {
  881.             croak YAML_PARSE_ERR_MANY_EXPLICIT() if $explicit;
  882.             $explicit = $1;
  883.         }
  884.         elsif ($preface =~ s/^\!\s*//) {
  885.             croak YAML_PARSE_ERR_MANY_IMPLICIT() if $implicit;
  886.             $implicit = 1;
  887.         }
  888.         elsif ($preface =~ s/^\&([^ ,:]+)\s*//) {
  889.             $token = $1;
  890.             croak YAML_PARSE_ERR_BAD_ANCHOR() 
  891.               unless $token =~ /^[a-zA-Z0-9]+$/;
  892.             croak YAML_PARSE_ERR_MANY_ANCHOR() if $anchor;
  893.             croak YAML_PARSE_ERR_ANCHOR_ALIAS() if $alias;
  894.             $anchor = $token;
  895.         }
  896.         elsif ($preface =~ s/^\*([^ ,:]+)\s*//) {
  897.             $token = $1;
  898.             croak YAML_PARSE_ERR_BAD_ALIAS() unless $token =~ /^[a-zA-Z0-9]+$/;
  899.             croak YAML_PARSE_ERR_MANY_ALIAS() if $alias;
  900.             croak YAML_PARSE_ERR_ANCHOR_ALIAS() if $anchor;
  901.             $alias = $token;
  902.         }
  903.     }
  904.     return ($anchor, $alias, $explicit, $implicit, $class, $preface); 
  905. }
  906.  
  907. # Morph a node to it's explicit type  
  908. sub _parse_explicit {
  909.     my ($node, $explicit) = @_;
  910.     if ($explicit =~ m{^(int|float|bool|date|time|datetime|binary)$}) {
  911.         my $handler = "YAML::_load_$1";
  912.         no strict 'refs';
  913.         return &$handler($node);
  914.     }
  915.     elsif ($explicit =~ m{^perl/(glob|regexp|code|ref)\:(\w(\w|\:\:)*)?$}) {
  916.         my ($type, $class) = (($1 || ''), ($2 || ''));
  917.         my $handler = "YAML::_load_perl_$type";
  918.         no strict 'refs';
  919.         if (defined &$handler) {
  920.             return &$handler($node, $class);
  921.         }
  922.         else {
  923.             croak YAML_LOAD_ERR_NO_CONVERT('XXX', $explicit);
  924.         }
  925.     }
  926.     elsif ($explicit =~ m{^perl/(\@|\$)?([a-zA-Z](\w|::)+)$}) {
  927.         my ($package) = ($2);
  928.         my $handler = "${package}::yaml_load";
  929.         no strict 'refs';
  930.         if (defined &$handler) {
  931.             return &$handler(YAML::Node->new($node, $explicit));
  932.         }
  933.         else {
  934.             return CORE::bless $node, $package;
  935.         }
  936.     }
  937.     elsif ($explicit !~ m|/|) {
  938.         croak YAML_LOAD_ERR_NO_CONVERT('XXX', $explicit);
  939.     }
  940.     else {
  941.         return YAML::Node->new($node, $explicit);
  942.     }
  943. }
  944.  
  945. # Morph to a perl reference
  946. sub _load_perl_ref {
  947.     my ($node) = @_;
  948.     croak YAML_LOAD_ERR_NO_DEFAULT_VALUE('ptr') unless exists $node->{&VALUE};
  949.     return \$node->{&VALUE};
  950. }
  951.  
  952. # Morph to a perl regexp
  953. sub _load_perl_regexp {
  954.     my ($node) = @_;
  955.     my ($regexp, $modifiers);
  956.     if (defined $node->{REGEXP}) {
  957.         $regexp = $node->{REGEXP};
  958.         delete $node->{REGEXP};
  959.     }
  960.     else {
  961.         warn YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP() if $^W;
  962.         return undef;
  963.     }
  964.     if (defined $node->{MODIFIERS}) {
  965.         $modifiers = $node->{MODIFIERS};
  966.         delete $node->{MODIFIERS};
  967.     } else {
  968.         $modifiers = '';
  969.     }
  970.     for my $elem (sort keys %$node) {
  971.         warn YAML_LOAD_WARN_BAD_REGEXP_ELEM($elem) if $^W;
  972.     }
  973.     my $value = eval "qr($regexp)$modifiers";
  974.     if ($@) {
  975.         warn YAML_LOAD_WARN_REGEXP_CREATE($regexp, $modifiers, $@) if $^W;
  976.         return undef;
  977.     }
  978.     return $value;
  979. }
  980.  
  981. # Morph to a perl glob
  982. sub _load_perl_glob {
  983.     my ($node) = @_;
  984.     my ($name, $package);
  985.     if (defined $node->{NAME}) {
  986.         $name = $node->{NAME};
  987.         delete $node->{NAME};
  988.     }
  989.     else {
  990.         warn YAML_LOAD_WARN_GLOB_NAME() if $^W;
  991.         return undef;
  992.     }
  993.     if (defined $node->{PACKAGE}) {
  994.         $package = $node->{PACKAGE};
  995.         delete $node->{PACKAGE};
  996.     } else {
  997.         $package = 'main';
  998.     }
  999.     no strict 'refs';
  1000.     if (exists $node->{SCALAR}) {
  1001.         *{"${package}::$name"} = \$node->{SCALAR};
  1002.         delete $node->{SCALAR};
  1003.     }
  1004.     for my $elem (qw(ARRAY HASH CODE IO)) {
  1005.         if (exists $node->{$elem}) {
  1006.             if ($elem eq 'IO') {
  1007.                 warn YAML_LOAD_WARN_GLOB_IO() if $^W;
  1008.                 delete $node->{IO};
  1009.                 next;
  1010.             }
  1011.             *{"${package}::$name"} = $node->{$elem};
  1012.             delete $node->{$elem};
  1013.         }
  1014.     }
  1015.     for my $elem (sort keys %$node) {
  1016.         warn YAML_LOAD_WARN_BAD_GLOB_ELEM($elem) if $^W;
  1017.     }
  1018.     return *{"${package}::$name"};
  1019. }
  1020.  
  1021. # Special support for an empty mapping
  1022. #sub _parse_str_to_map {
  1023. #    my ($node) = @_;
  1024. #    croak YAML_LOAD_ERR_NON_EMPTY_STRING('mapping') unless $node eq '';
  1025. #    return {};
  1026. #}
  1027.  
  1028. # Special support for an empty sequence
  1029. #sub _parse_str_to_seq {
  1030. #    my ($node) = @_;
  1031. #    croak YAML_LOAD_ERR_NON_EMPTY_STRING('sequence') unless $node eq '';
  1032. #    return [];
  1033. #}
  1034.  
  1035. # Support for sparse sequences
  1036. #sub _parse_map_to_seq {
  1037. #    my ($node) = @_;
  1038. #    my $seq = [];
  1039. #    for my $index (keys %$node) {
  1040. #        croak YAML_LOAD_ERR_BAD_MAP_TO_SEQ($index) unless $index =~ /^\d+/;
  1041. #        $seq->[$index] = $node->{$index};
  1042. #    }
  1043. #    return $seq;
  1044. #}
  1045.  
  1046. # Support for !int
  1047. sub _load_int {
  1048.     my ($node) = @_;
  1049.     croak YAML_LOAD_ERR_BAD_STR_TO_INT() unless $node =~ /^-?\d+$/;
  1050.     return $node;
  1051. }
  1052.  
  1053. # Support for !date
  1054. sub _load_date {
  1055.     my ($node) = @_;
  1056.     croak YAML_LOAD_ERR_BAD_STR_TO_DATE() unless $node =~ /^\d\d\d\d-\d\d-\d\d$/;
  1057.     return $node;
  1058. }
  1059.  
  1060. # Support for !time
  1061. sub _load_time {
  1062.     my ($node) = @_;
  1063.     croak YAML_LOAD_ERR_BAD_STR_TO_TIME() unless $node =~ /^\d\d:\d\d:\d\d$/;
  1064.     return $node;
  1065. }
  1066.  
  1067. # Support for !perl/code;deparse
  1068. sub _load_perl_code {
  1069.     my ($node, $class) = @_;
  1070.     if ($o->{LoadCode}) {
  1071.         my $code = eval "package main; sub $node";
  1072.         if ($@) {
  1073.             warn YAML_LOAD_WARN_PARSE_CODE($@) if $^W;
  1074.             return sub {};
  1075.         }
  1076.         else {
  1077.             CORE::bless $code, $class if $class;
  1078.             return $code;
  1079.         }
  1080.     }
  1081.     else {
  1082.         return sub {};
  1083.     }
  1084. }
  1085.  
  1086. # Parse a YAML mapping into a Perl hash
  1087. sub _parse_mapping {
  1088.     my ($anchor) = @_;
  1089.     my $mapping = {};
  1090.     $o->{anchor2node}{$anchor} = $mapping;
  1091.     my $key;
  1092.     while (not $o->{done} and $o->{indent} == $o->{offset}[$o->{level}]) {
  1093.         # If structured key:
  1094.         if ($o->{content} =~ s/^\?\s*//) {
  1095.             $o->{preface} = $o->{content};
  1096.             _parse_next_line(COLLECTION);
  1097.             $key = _parse_node();
  1098.             $key = "$key";
  1099.         }
  1100.         # If "default" key (equals sign) 
  1101.         elsif ($o->{content} =~ s/^\=\s*//) {
  1102.             $key = VALUE;
  1103.         }
  1104.         # If "comment" key (slash slash)
  1105.         elsif ($o->{content} =~ s/^\=\s*//) {
  1106.             $key = COMMENT;
  1107.         }
  1108.         # Regular scalar key:
  1109.         else {
  1110.             $o->{inline} = $o->{content};
  1111.             $key = _parse_inline();
  1112.             $key = "$key";
  1113.             $o->{content} = $o->{inline};
  1114.             $o->{inline} = '';
  1115.         }
  1116.             
  1117.         unless ($o->{content} =~ s/^:\s*//) {
  1118.             croak YAML_LOAD_ERR_BAD_MAP_ELEMENT();
  1119.         }
  1120.         $o->{preface} = $o->{content};
  1121.         my $line = $o->{line};
  1122.         _parse_next_line(COLLECTION);
  1123.         my $value = _parse_node();
  1124.         if (exists $mapping->{$key}) {
  1125.             warn YAML_LOAD_WARN_DUPLICATE_KEY() if $^W;
  1126.         }
  1127.         else {
  1128.             $mapping->{$key} = $value;
  1129.         }
  1130.     }
  1131.     return $mapping;
  1132. }
  1133.  
  1134. # Parse a YAML sequence into a Perl array
  1135. sub _parse_seq {
  1136.     my ($anchor) = @_;
  1137.     my $seq = [];
  1138.     $o->{anchor2node}{$anchor} = $seq;
  1139.     while (not $o->{done} and $o->{indent} == $o->{offset}[$o->{level}]) {
  1140.         if ($o->{content} =~ /^-(?: (.*))?$/) {
  1141.             $o->{preface} = defined($1) ? $1 : '';
  1142.         }
  1143.         else {
  1144.             croak YAML_LOAD_ERR_BAD_SEQ_ELEMENT();
  1145.         }
  1146.         if ($o->{preface} =~ /^(\s*)(\w.*\:(?: |$).*)$/) {
  1147.             $o->{indent} = $o->{offset}[$o->{level}] + 2 + length($1);
  1148.             $o->{content} = $2;
  1149.             $o->{offset}[++$o->{level}] = $o->{indent};
  1150.             $o->{preface} = '';
  1151.             push @$seq, _parse_mapping('');
  1152.             $o->{level}--;
  1153.             $#{$o->{offset}} = $o->{level};
  1154.         }
  1155.         else {
  1156.             _parse_next_line(COLLECTION);
  1157.             push @$seq, _parse_node();
  1158.         }
  1159.     }
  1160.     return $seq;
  1161. }
  1162.  
  1163. # Parse an inline value. Since YAML supports inline collections, this is
  1164. # the top level of a sub parsing.
  1165. sub _parse_inline {
  1166.     my ($top, $top_implicit, $top_explicit, $top_class) = (@_, '', '', '', '');
  1167.     $o->{inline} =~ s/^\s*(.*)\s*$/$1/;
  1168.     my ($node, $anchor, $alias, $explicit, $implicit, $class) = ('') x 6;
  1169.     ($anchor, $alias, $explicit, $implicit, $class, $o->{inline}) = 
  1170.       _parse_qualifiers($o->{inline});
  1171.     if ($anchor) {
  1172.         $o->{anchor2node}{$anchor} = CORE::bless [], 'YAML-anchor2node';
  1173.     }
  1174.     $implicit ||= $top_implicit;
  1175.     $explicit ||= $top_explicit;
  1176.     $class ||= $top_class;
  1177.     ($top_implicit, $top_explicit, $top_class) = ('', '', '');
  1178.     if ($alias) {
  1179.         croak YAML_PARSE_ERR_NO_ANCHOR($alias) 
  1180.           unless defined $o->{anchor2node}{$alias};
  1181.         if (ref($o->{anchor2node}{$alias}) ne 'YAML-anchor2node') {
  1182.             $node = $o->{anchor2node}{$alias};
  1183.         }
  1184.         else {
  1185.             $node = do {my $sv = "*$alias"};
  1186.             push @{$o->{anchor2node}{$alias}}, [\$node, $o->{line}]; 
  1187.         }
  1188.     }
  1189.     elsif ($o->{inline} =~ /^\{/) {
  1190.         $node = _parse_inline_mapping($anchor);
  1191.     }
  1192.     elsif ($o->{inline} =~ /^\[/) {
  1193.         $node = _parse_inline_seq($anchor);
  1194.     }
  1195.     elsif ($o->{inline} =~ /^"/) {
  1196.         $node = _parse_inline_double_quoted();
  1197.         $node = _unescape($node);
  1198.         $node = _parse_implicit($node) if $implicit;
  1199.     }
  1200.     elsif ($o->{inline} =~ /^'/) {
  1201.         $node = _parse_inline_single_quoted();
  1202.         $node = _parse_implicit($node) if $implicit;
  1203.     }
  1204.     else {
  1205.         if ($top) {
  1206.             $node = $o->{inline};
  1207.             $o->{inline} = '';
  1208.         }
  1209.         else {
  1210.             $node = _parse_inline_simple();
  1211.         }
  1212.         $node = _parse_implicit($node) unless $explicit;
  1213.     }
  1214.     if ($explicit) {
  1215.         if ($class) {
  1216.             if (not ref $node) {
  1217.                 my $copy = $node;
  1218.                 undef $node;
  1219.                 $node = \$copy;
  1220.             }
  1221.             CORE::bless $node, $class;
  1222.         }
  1223.         else {
  1224.             $node = _parse_explicit($node, $explicit);
  1225.         }
  1226.     }
  1227.     if ($anchor) {
  1228.         if (ref($o->{anchor2node}{$anchor}) eq 'YAML-anchor2node') {
  1229.             for my $ref (@{$o->{anchor2node}{$anchor}}) {
  1230.                 ${$ref->[0]} = $node;
  1231.                 warn YAML_LOAD_WARN_UNRESOLVED_ALIAS($anchor, $ref->[1]) if $^W;
  1232.             }
  1233.         }
  1234.         $o->{anchor2node}{$anchor} = $node;
  1235.     }
  1236.     return $node;
  1237. }
  1238.  
  1239. # Parse the inline YAML mapping into a Perl hash
  1240. sub _parse_inline_mapping {
  1241.     my ($anchor) = @_;
  1242.     my $node = {};
  1243.     $o->{anchor2node}{$anchor} = $node;
  1244.  
  1245.     croak YAML_PARSE_ERR_INLINE_MAP() unless $o->{inline} =~ s/^\{\s*//;
  1246.     while (not $o->{inline} =~ s/^\}//) {
  1247.         my $key = _parse_inline();
  1248.         croak YAML_PARSE_ERR_INLINE_MAP() unless $o->{inline} =~ s/^\: \s*//;
  1249.         my $value = _parse_inline();
  1250.         if (exists $node->{$key}) {
  1251.             warn YAML_LOAD_WARN_DUPLICATE_KEY() if $^W;
  1252.         }
  1253.         else {
  1254.             $node->{$key} = $value;
  1255.         }
  1256.         next if $o->{inline} =~ /^\}/;
  1257.         croak YAML_PARSE_ERR_INLINE_MAP() unless $o->{inline} =~ s/^\,\s*//;
  1258.     }
  1259.     return $node;
  1260. }
  1261.  
  1262. # Parse the inline YAML sequence into a Perl array
  1263. sub _parse_inline_seq {
  1264.     my ($anchor) = @_;
  1265.     my $node = [];
  1266.     $o->{anchor2node}{$anchor} = $node;
  1267.  
  1268.     croak YAML_PARSE_ERR_INLINE_SEQUENCE() unless $o->{inline} =~ s/^\[\s*//;
  1269.     while (not $o->{inline} =~ s/^\]//) {
  1270.         my $value = _parse_inline();
  1271.         push @$node, $value;
  1272.         next if $o->{inline} =~ /^\]/;
  1273.         croak YAML_PARSE_ERR_INLINE_SEQUENCE() 
  1274.           unless $o->{inline} =~ s/^\,\s*//;
  1275.     }
  1276.     return $node;
  1277. }
  1278.  
  1279. # Parse the inline double quoted string.
  1280. sub _parse_inline_double_quoted {
  1281.     my $node;
  1282.     if ($o->{inline} =~ /^"((?:\\"|[^"])*)"\s*(.*)$/) {
  1283.         $node = $1;
  1284.         $o->{inline} = $2;
  1285.         $node =~ s/\\"/"/g;
  1286.     } else {
  1287.         croak YAML_PARSE_ERR_BAD_DOUBLE();
  1288.     }
  1289.     return $node;
  1290. }
  1291.  
  1292.  
  1293. # Parse the inline single quoted string.
  1294. sub _parse_inline_single_quoted {
  1295.     my $node;
  1296.     if ($o->{inline} =~ /^'((?:''|[^'])*)'\s*(.*)$/) {
  1297.         $node = $1;
  1298.         $o->{inline} = $2;
  1299.         $node =~ s/''/'/g;
  1300.     } else {
  1301.         croak YAML_PARSE_ERR_BAD_SINGLE();
  1302.     }
  1303.     return $node;
  1304. }
  1305.  
  1306. # Parse the inline unquoted string and do implicit typing.
  1307. sub _parse_inline_simple {
  1308.     my $value;
  1309.     if ($o->{inline} =~ /^(|[^!@#%^&*].*?)(?=[,[\]{}]|: |- |:\s*$|$)/) {
  1310.         $value = $1;
  1311.         substr($o->{inline}, 0, length($1)) = '';
  1312.     }
  1313.     else {
  1314.         croak YAML_PARSE_ERR_BAD_INLINE_IMPLICIT($value);
  1315.     }
  1316.     return $value;
  1317. }
  1318.  
  1319. # Apply regex matching for YAML's implicit types. !str, !int, !real,
  1320. # !null, !date and !time
  1321. sub _parse_implicit {
  1322.     my ($value) = @_;
  1323.     $value =~ s/\s*$//;
  1324.     return $value if $value eq '';
  1325.     return $value + 0 if $value =~ /^-?\d+$/;
  1326.     return $value * 1.0
  1327.       if ($value =~ /^[+-]?(\d*)(?:\.(\d*))?([Ee][+-]?\d+)?$/) and
  1328.          (defined($3) ? defined($1) : defined($1) || defined($2));
  1329.     return "$value" if $value =~  # XXX Change this to a Time::Object
  1330.       /^\d{4}\-\d\d\-\d\d(T\d\d:\d\d:\d\d(\.\d*[1-9])?(Z|[-+]\d\d(:\d\d)?))?$/;
  1331.     return "$value" if $value =~ /^\w/;
  1332.     return undef if $value =~ /^~$/;
  1333.     return 1 if $value =~ /^\+$/;
  1334.     return 0 if $value =~ /^-$/;
  1335.     croak YAML_PARSE_ERR_BAD_IMPLICIT($value);
  1336. }
  1337.  
  1338. # Unfold a YAML multiline scalar into a single string.
  1339. sub _parse_unfold {
  1340.     my ($chomp) = @_;
  1341.     my $node = '';
  1342.     my $space = 0;
  1343.     while (not $o->{done} and $o->{indent} == $o->{offset}[$o->{level}]) {
  1344.         $node .= "$o->{content}\n";
  1345.         _parse_next_line(LEAF);
  1346.     }
  1347.     $node =~ s/^(\S.*)\n(?=\S)/$1 /gm;
  1348.     $node =~ s/^(\S.*)\n(\n+\S)/$1$2/gm;
  1349.     $node =~ s/\n*\Z// unless $chomp eq '+';
  1350.     $node .= "\n" unless $chomp;
  1351.     return $node;
  1352. }
  1353.  
  1354. # Parse a YAML block style scalar. This is like a Perl here-document.
  1355. sub _parse_block {
  1356.     my ($chomp) = @_;
  1357.     my $node = '';
  1358.     while (not $o->{done} and $o->{indent} == $o->{offset}[$o->{level}]) {
  1359.         $node .= $o->{content} . "\n";
  1360.         _parse_next_line(LEAF);
  1361.     }
  1362.     return $node if '+' eq $chomp;
  1363.     $node =~ s/\n*\Z/\n/;
  1364.     $node =~ s/\n\Z// if $chomp eq '-';
  1365.     return $node;
  1366. }
  1367.  
  1368. # Handle Perl style '#' comments. Comments must be at the same indentation
  1369. # level as the collection line following them.
  1370. sub _parse_throwaway_comments {
  1371.     while (@{$o->{lines}} and
  1372.            $o->{lines}[0] =~ m{^\s*(\#|$)}
  1373.           ) {
  1374.         shift @{$o->{lines}};
  1375.         $o->{line}++;
  1376.     }
  1377.     $o->{eos} = $o->{done} = not @{$o->{lines}};
  1378. }
  1379.  
  1380. # This is the routine that controls what line is being parsed. It gets called
  1381. # once for each line in the YAML stream.
  1382. #
  1383. # This routine must:
  1384. # 1) Skip past the current line
  1385. # 2) Determine the indentation offset for a new level
  1386. # 3) Find the next _content_ line
  1387. #   A) Skip over any throwaways (Comments/blanks)
  1388. #   B) Set $o->{indent}, $o->{content}, $o->{line}
  1389. # 4) Expand tabs appropriately  
  1390. sub _parse_next_line {
  1391.     my ($type) = @_;
  1392.     my $level = $o->{level};
  1393.     my $offset = $o->{offset}[$level];
  1394.     croak YAML_EMIT_ERR_BAD_LEVEL() unless defined $offset;
  1395.     shift @{$o->{lines}};
  1396.     $o->{eos} = $o->{done} = not @{$o->{lines}};
  1397.     return if $o->{eos};
  1398.     $o->{line}++;
  1399.  
  1400.     # Determine the offset for a new leaf node
  1401.     if ($o->{preface} =~ qr/(?:$FOLD_CHAR|$BLOCK_CHAR_RX)(?:-|\+)?(\d*)\s*$/) {
  1402.         croak YAML_PARSE_ERR_ZERO_INDENT() if length($1) and $1 == 0;
  1403.         $type = LEAF;
  1404.         if (length($1)) {
  1405.             $o->{offset}[$level + 1] = $offset + $1;
  1406.         }
  1407.         else {
  1408.             # First get rid of any comments.
  1409.             while (@{$o->{lines}} && ($o->{lines}[0] =~ /^\s*#/)) {
  1410.                 $o->{lines}[0] =~ /^( *)/ or die;
  1411.                 last unless length($1) <= $offset;
  1412.                 shift @{$o->{lines}};
  1413.                 $o->{line}++;
  1414.             }
  1415.             $o->{eos} = $o->{done} = not @{$o->{lines}};
  1416.             return if $o->{eos};
  1417.             if ($o->{lines}[0] =~ /^( *)\S/ and length($1) > $offset) {
  1418.                 $o->{offset}[$level+1] = length($1);
  1419.             }
  1420.             else {
  1421.                 $o->{offset}[$level+1] = $offset + 1;
  1422.             }
  1423.         }
  1424.         $offset = $o->{offset}[++$level];
  1425.     }
  1426.     # Determine the offset for a new collection level
  1427.     elsif ($type == COLLECTION and 
  1428.            $o->{preface} =~ /^(\s*(\!\S*|\&\S+))*\s*$/) {
  1429.         _parse_throwaway_comments();
  1430.         if ($o->{eos}) {
  1431.             $o->{offset}[$level+1] = $offset + 1;
  1432.             return;
  1433.         }
  1434.         else {
  1435.             $o->{lines}[0] =~ /^( *)\S/ or die;
  1436.             if (length($1) > $offset) {
  1437.                 $o->{offset}[$level+1] = length($1);
  1438.             }
  1439.             else {
  1440.                 $o->{offset}[$level+1] = $offset + 1;
  1441.             }
  1442.         }
  1443.         $offset = $o->{offset}[++$level];
  1444.     }
  1445.         
  1446.     if ($type == LEAF) {
  1447.         while (@{$o->{lines}} and
  1448.                $o->{lines}[0] =~ m{^( *)(\#)} and
  1449.                length($1) < $offset
  1450.               ) {
  1451.             shift @{$o->{lines}};
  1452.             $o->{line}++;
  1453.         }
  1454.         $o->{eos} = $o->{done} = not @{$o->{lines}};
  1455.     }
  1456.     else {
  1457.         _parse_throwaway_comments();
  1458.     }
  1459.     return if $o->{eos}; 
  1460.     
  1461.     if ($o->{lines}[0] =~ /^---(\s|$)/) {
  1462.         $o->{done} = 1;
  1463.         return;
  1464.     }
  1465.     if ($type == LEAF and 
  1466.         $o->{lines}[0] =~ /^ {$offset}(.*)$/
  1467.        ) {
  1468.         $o->{indent} = $offset;
  1469.         $o->{content} = $1;
  1470.     }
  1471.     elsif ($o->{lines}[0] =~ /^\s*$/) {
  1472.         $o->{indent} = $offset;
  1473.         $o->{content} = '';
  1474.     }
  1475.     else {
  1476.         $o->{lines}[0] =~ /^( *)(\S.*)$/;
  1477. # print "   indent(${\length($1)})  offsets(@{$o->{offset}}) \n";
  1478.         while ($o->{offset}[$level] > length($1)) {
  1479.             $level--;
  1480.         }
  1481.         croak YAML_PARSE_ERR_INCONSISTENT_INDENTATION() 
  1482.           if $o->{offset}[$level] != length($1);
  1483.         $o->{indent} = length($1);
  1484.         $o->{content} = $2;
  1485.     }
  1486.     croak YAML_PARSE_ERR_INDENTATION() if $o->{indent} - $offset > 1;
  1487. }
  1488.  
  1489. #==============================================================================
  1490. # Utility subroutines.
  1491. #==============================================================================
  1492.  
  1493. # Indent a scalar to the current indentation level.
  1494. sub indent {
  1495.     my ($text) = @_;
  1496.     return $text unless length $text;
  1497.     $text =~ s/\n\Z//;
  1498.     my $indent = ' ' x $o->{offset}[$o->{level}];
  1499.     $text =~ s/^/$indent/gm;
  1500.     $text = "\n$text";
  1501.     return $text;
  1502. }
  1503.  
  1504. # Fold a paragraph to fit within a certain columnar restraint.
  1505. sub fold {
  1506.     my ($text) = @_;
  1507.     my $folded = '';
  1508.     $text =~ s/^(\S.*)\n(?=\S)/$1\n\n/gm;
  1509.     while (length $text > 0) {
  1510.         if ($text =~ s/^([^\n]{0,76})(\n|\Z)//) {
  1511.             $folded .= $1;
  1512.         }
  1513.         elsif ($text =~ s/^(.{0,76})\s//) { 
  1514.             $folded .= $1;
  1515.         }
  1516.         else {
  1517.             croak "bad news" unless $text =~ s/(.*?)(\s|\Z)//;
  1518.             $folded .= $1;
  1519.         }
  1520.         $folded .= "\n";
  1521.     }
  1522.     return $folded;
  1523. }
  1524.  
  1525. # Escapes for unprintable characters
  1526. my @escapes = qw(\z   \x01 \x02 \x03 \x04 \x05 \x06 \a
  1527.                  \x08 \t   \n   \v   \f   \r   \x0e \x0f
  1528.                  \x10 \x11 \x12 \x13 \x14 \x15 \x16 \x17
  1529.                  \x18 \x19 \x1a \e   \x1c \x1d \x1e \x1f
  1530.                 );
  1531.  
  1532. # Escape the unprintable characters
  1533. sub escape {
  1534.     my ($text) = @_;
  1535.     $text =~ s/\\/\\\\/g;
  1536.     $text =~ s/([\x00-\x1f])/$escapes[ord($1)]/ge;
  1537.     return $text;
  1538. }
  1539.  
  1540. # Printable characters for escapes
  1541. my %unescapes = 
  1542.   (
  1543.    z => "\x00", a => "\x07", t => "\x09",
  1544.    n => "\x0a", v => "\x0b", f => "\x0c",
  1545.    r => "\x0d", e => "\x1b", '\\' => '\\',
  1546.   );
  1547.    
  1548. # Transform all the backslash style escape characters to their literal meaning
  1549. sub _unescape {
  1550.     my ($node) = @_;
  1551.     $node =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/
  1552.               (length($1)>1)?pack("H2",$2):$unescapes{$1}/gex;
  1553.     return $node;
  1554. }
  1555.  
  1556. sub DESTROY () {}
  1557.  
  1558. sub AUTOLOAD {
  1559.     (my $autoload = $YAML::AUTOLOAD) =~ s/^YAML:://;
  1560.     if ($autoload =~ /^[A-Z]/ and 
  1561.         ref($_[0]) eq 'YAML' and
  1562.         defined $_[0]->{$autoload}
  1563.        ) {
  1564.         defined($_[1]) ? (($_[0]->{$autoload} = $_[1]), return $_[0]) 
  1565.                        : return $_[0]->{$autoload};
  1566.         return;
  1567.     }
  1568.         
  1569.     croak "Can't autoload '$YAML::AUTOLOAD'\n"
  1570.       unless $autoload =~ /^YAML_(PARSE|LOAD|DUMP|EMIT)_(ERR|WARN|USAGE)/;
  1571.     require YAML::Error;  
  1572.     $o->{error} = YAML::Error->new($autoload, $o->{line}, $o->{document}, @_);
  1573.     my $o_save = $o;
  1574.     my $dump = $o->{error}->dump;
  1575.     $o = $o_save;
  1576.     return "$dump...\n";
  1577. }
  1578.  
  1579. 1;
  1580.