"Fossies" - the Fresh Open Source Software Archive

Member "install-tl-20200916/tlpkg/tlperl/lib/CPAN/Meta/YAML.pm" (18 Apr 2017, 26994 Bytes) of package /windows/misc/install-tl.zip:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) Perl source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file.

    1 use 5.008001; # sane UTF-8 support
    2 use strict;
    3 use warnings;
    4 package CPAN::Meta::YAML; # git description: v1.68-2-gcc5324e
    5 # XXX-INGY is 5.8.1 too old/broken for utf8?
    6 # XXX-XDG Lancaster consensus was that it was sufficient until
    7 # proven otherwise
    8 $CPAN::Meta::YAML::VERSION = '0.018';
    9 ; # original $VERSION removed by Doppelgaenger
   10 
   11 #####################################################################
   12 # The CPAN::Meta::YAML API.
   13 #
   14 # These are the currently documented API functions/methods and
   15 # exports:
   16 
   17 use Exporter;
   18 our @ISA       = qw{ Exporter  };
   19 our @EXPORT    = qw{ Load Dump };
   20 our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
   21 
   22 ###
   23 # Functional/Export API:
   24 
   25 sub Dump {
   26     return CPAN::Meta::YAML->new(@_)->_dump_string;
   27 }
   28 
   29 # XXX-INGY Returning last document seems a bad behavior.
   30 # XXX-XDG I think first would seem more natural, but I don't know
   31 # that it's worth changing now
   32 sub Load {
   33     my $self = CPAN::Meta::YAML->_load_string(@_);
   34     if ( wantarray ) {
   35         return @$self;
   36     } else {
   37         # To match YAML.pm, return the last document
   38         return $self->[-1];
   39     }
   40 }
   41 
   42 # XXX-INGY Do we really need freeze and thaw?
   43 # XXX-XDG I don't think so.  I'd support deprecating them.
   44 BEGIN {
   45     *freeze = \&Dump;
   46     *thaw   = \&Load;
   47 }
   48 
   49 sub DumpFile {
   50     my $file = shift;
   51     return CPAN::Meta::YAML->new(@_)->_dump_file($file);
   52 }
   53 
   54 sub LoadFile {
   55     my $file = shift;
   56     my $self = CPAN::Meta::YAML->_load_file($file);
   57     if ( wantarray ) {
   58         return @$self;
   59     } else {
   60         # Return only the last document to match YAML.pm,
   61         return $self->[-1];
   62     }
   63 }
   64 
   65 
   66 ###
   67 # Object Oriented API:
   68 
   69 # Create an empty CPAN::Meta::YAML object
   70 # XXX-INGY Why do we use ARRAY object?
   71 # NOTE: I get it now, but I think it's confusing and not needed.
   72 # Will change it on a branch later, for review.
   73 #
   74 # XXX-XDG I don't support changing it yet.  It's a very well-documented
   75 # "API" of CPAN::Meta::YAML.  I'd support deprecating it, but Adam suggested
   76 # we not change it until YAML.pm's own OO API is established so that
   77 # users only have one API change to digest, not two
   78 sub new {
   79     my $class = shift;
   80     bless [ @_ ], $class;
   81 }
   82 
   83 # XXX-INGY It probably doesn't matter, and it's probably too late to
   84 # change, but 'read/write' are the wrong names. Read and Write
   85 # are actions that take data from storage to memory
   86 # characters/strings. These take the data to/from storage to native
   87 # Perl objects, which the terms dump and load are meant. As long as
   88 # this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not
   89 # to add new {read,write}_* methods to this API.
   90 
   91 sub read_string {
   92     my $self = shift;
   93     $self->_load_string(@_);
   94 }
   95 
   96 sub write_string {
   97     my $self = shift;
   98     $self->_dump_string(@_);
   99 }
  100 
  101 sub read {
  102     my $self = shift;
  103     $self->_load_file(@_);
  104 }
  105 
  106 sub write {
  107     my $self = shift;
  108     $self->_dump_file(@_);
  109 }
  110 
  111 
  112 
  113 
  114 #####################################################################
  115 # Constants
  116 
  117 # Printed form of the unprintable characters in the lowest range
  118 # of ASCII characters, listed by ASCII ordinal position.
  119 my @UNPRINTABLE = qw(
  120     0    x01  x02  x03  x04  x05  x06  a
  121     b    t    n    v    f    r    x0E  x0F
  122     x10  x11  x12  x13  x14  x15  x16  x17
  123     x18  x19  x1A  e    x1C  x1D  x1E  x1F
  124 );
  125 
  126 # Printable characters for escapes
  127 my %UNESCAPES = (
  128     0 => "\x00", z => "\x00", N    => "\x85",
  129     a => "\x07", b => "\x08", t    => "\x09",
  130     n => "\x0a", v => "\x0b", f    => "\x0c",
  131     r => "\x0d", e => "\x1b", '\\' => '\\',
  132 );
  133 
  134 # XXX-INGY
  135 # I(ngy) need to decide if these values should be quoted in
  136 # CPAN::Meta::YAML or not. Probably yes.
  137 
  138 # These 3 values have special meaning when unquoted and using the
  139 # default YAML schema. They need quotes if they are strings.
  140 my %QUOTE = map { $_ => 1 } qw{
  141     null true false
  142 };
  143 
  144 # The commented out form is simpler, but overloaded the Perl regex
  145 # engine due to recursion and backtracking problems on strings
  146 # larger than 32,000ish characters. Keep it for reference purposes.
  147 # qr/\"((?:\\.|[^\"])*)\"/
  148 my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
  149 my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
  150 # unquoted re gets trailing space that needs to be stripped
  151 my $re_capture_unquoted_key  = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
  152 my $re_trailing_comment      = qr/(?:\s+\#.*)?/;
  153 my $re_key_value_separator   = qr/\s*:(?:\s+(?:\#.*)?|$)/;
  154 
  155 
  156 
  157 
  158 
  159 #####################################################################
  160 # CPAN::Meta::YAML Implementation.
  161 #
  162 # These are the private methods that do all the work. They may change
  163 # at any time.
  164 
  165 
  166 ###
  167 # Loader functions:
  168 
  169 # Create an object from a file
  170 sub _load_file {
  171     my $class = ref $_[0] ? ref shift : shift;
  172 
  173     # Check the file
  174     my $file = shift or $class->_error( 'You did not specify a file name' );
  175     $class->_error( "File '$file' does not exist" )
  176         unless -e $file;
  177     $class->_error( "'$file' is a directory, not a file" )
  178         unless -f _;
  179     $class->_error( "Insufficient permissions to read '$file'" )
  180         unless -r _;
  181 
  182     # Open unbuffered with strict UTF-8 decoding and no translation layers
  183     open( my $fh, "<:unix:encoding(UTF-8)", $file );
  184     unless ( $fh ) {
  185         $class->_error("Failed to open file '$file': $!");
  186     }
  187 
  188     # flock if available (or warn if not possible for OS-specific reasons)
  189     if ( _can_flock() ) {
  190         flock( $fh, Fcntl::LOCK_SH() )
  191             or warn "Couldn't lock '$file' for reading: $!";
  192     }
  193 
  194     # slurp the contents
  195     my $contents = eval {
  196         use warnings FATAL => 'utf8';
  197         local $/;
  198         <$fh>
  199     };
  200     if ( my $err = $@ ) {
  201         $class->_error("Error reading from file '$file': $err");
  202     }
  203 
  204     # close the file (release the lock)
  205     unless ( close $fh ) {
  206         $class->_error("Failed to close file '$file': $!");
  207     }
  208 
  209     $class->_load_string( $contents );
  210 }
  211 
  212 # Create an object from a string
  213 sub _load_string {
  214     my $class  = ref $_[0] ? ref shift : shift;
  215     my $self   = bless [], $class;
  216     my $string = $_[0];
  217     eval {
  218         unless ( defined $string ) {
  219             die \"Did not provide a string to load";
  220         }
  221 
  222         # Check if Perl has it marked as characters, but it's internally
  223         # inconsistent.  E.g. maybe latin1 got read on a :utf8 layer
  224         if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
  225             die \<<'...';
  226 Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
  227 Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
  228 ...
  229         }
  230 
  231         # Ensure Unicode character semantics, even for 0x80-0xff
  232         utf8::upgrade($string);
  233 
  234         # Check for and strip any leading UTF-8 BOM
  235         $string =~ s/^\x{FEFF}//;
  236 
  237         # Check for some special cases
  238         return $self unless length $string;
  239 
  240         # Split the file into lines
  241         my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
  242                 split /(?:\015{1,2}\012|\015|\012)/, $string;
  243 
  244         # Strip the initial YAML header
  245         @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
  246 
  247         # A nibbling parser
  248         my $in_document = 0;
  249         while ( @lines ) {
  250             # Do we have a document header?
  251             if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
  252                 # Handle scalar documents
  253                 shift @lines;
  254                 if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
  255                     push @$self,
  256                         $self->_load_scalar( "$1", [ undef ], \@lines );
  257                     next;
  258                 }
  259                 $in_document = 1;
  260             }
  261 
  262             if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
  263                 # A naked document
  264                 push @$self, undef;
  265                 while ( @lines and $lines[0] !~ /^---/ ) {
  266                     shift @lines;
  267                 }
  268                 $in_document = 0;
  269 
  270             # XXX The final '-+$' is to look for -- which ends up being an
  271             # error later.
  272             } elsif ( ! $in_document && @$self ) {
  273                 # only the first document can be explicit
  274                 die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
  275             } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) {
  276                 # An array at the root
  277                 my $document = [ ];
  278                 push @$self, $document;
  279                 $self->_load_array( $document, [ 0 ], \@lines );
  280 
  281             } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
  282                 # A hash at the root
  283                 my $document = { };
  284                 push @$self, $document;
  285                 $self->_load_hash( $document, [ length($1) ], \@lines );
  286 
  287             } else {
  288                 # Shouldn't get here.  @lines have whitespace-only lines
  289                 # stripped, and previous match is a line with any
  290                 # non-whitespace.  So this clause should only be reachable via
  291                 # a perlbug where \s is not symmetric with \S
  292 
  293                 # uncoverable statement
  294                 die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
  295             }
  296         }
  297     };
  298     my $err = $@;
  299     if ( ref $err eq 'SCALAR' ) {
  300         $self->_error(${$err});
  301     } elsif ( $err ) {
  302         $self->_error($err);
  303     }
  304 
  305     return $self;
  306 }
  307 
  308 sub _unquote_single {
  309     my ($self, $string) = @_;
  310     return '' unless length $string;
  311     $string =~ s/\'\'/\'/g;
  312     return $string;
  313 }
  314 
  315 sub _unquote_double {
  316     my ($self, $string) = @_;
  317     return '' unless length $string;
  318     $string =~ s/\\"/"/g;
  319     $string =~
  320         s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
  321          {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
  322     return $string;
  323 }
  324 
  325 # Load a YAML scalar string to the actual Perl scalar
  326 sub _load_scalar {
  327     my ($self, $string, $indent, $lines) = @_;
  328 
  329     # Trim trailing whitespace
  330     $string =~ s/\s*\z//;
  331 
  332     # Explitic null/undef
  333     return undef if $string eq '~';
  334 
  335     # Single quote
  336     if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
  337         return $self->_unquote_single($1);
  338     }
  339 
  340     # Double quote.
  341     if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
  342         return $self->_unquote_double($1);
  343     }
  344 
  345     # Special cases
  346     if ( $string =~ /^[\'\"!&]/ ) {
  347         die \"CPAN::Meta::YAML does not support a feature in line '$string'";
  348     }
  349     return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
  350     return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
  351 
  352     # Regular unquoted string
  353     if ( $string !~ /^[>|]/ ) {
  354         die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'"
  355             if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
  356                 $string =~ /:(?:\s|$)/;
  357         $string =~ s/\s+#.*\z//;
  358         return $string;
  359     }
  360 
  361     # Error
  362     die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;
  363 
  364     # Check the indent depth
  365     $lines->[0]   =~ /^(\s*)/;
  366     $indent->[-1] = length("$1");
  367     if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
  368         die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
  369     }
  370 
  371     # Pull the lines
  372     my @multiline = ();
  373     while ( @$lines ) {
  374         $lines->[0] =~ /^(\s*)/;
  375         last unless length($1) >= $indent->[-1];
  376         push @multiline, substr(shift(@$lines), length($1));
  377     }
  378 
  379     my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
  380     my $t = (substr($string, 1, 1) eq '-') ? ''  : "\n";
  381     return join( $j, @multiline ) . $t;
  382 }
  383 
  384 # Load an array
  385 sub _load_array {
  386     my ($self, $array, $indent, $lines) = @_;
  387 
  388     while ( @$lines ) {
  389         # Check for a new document
  390         if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
  391             while ( @$lines and $lines->[0] !~ /^---/ ) {
  392                 shift @$lines;
  393             }
  394             return 1;
  395         }
  396 
  397         # Check the indent level
  398         $lines->[0] =~ /^(\s*)/;
  399         if ( length($1) < $indent->[-1] ) {
  400             return 1;
  401         } elsif ( length($1) > $indent->[-1] ) {
  402             die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
  403         }
  404 
  405         if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
  406             # Inline nested hash
  407             my $indent2 = length("$1");
  408             $lines->[0] =~ s/-/ /;
  409             push @$array, { };
  410             $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
  411 
  412         } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
  413             shift @$lines;
  414             unless ( @$lines ) {
  415                 push @$array, undef;
  416                 return 1;
  417             }
  418             if ( $lines->[0] =~ /^(\s*)\-/ ) {
  419                 my $indent2 = length("$1");
  420                 if ( $indent->[-1] == $indent2 ) {
  421                     # Null array entry
  422                     push @$array, undef;
  423                 } else {
  424                     # Naked indenter
  425                     push @$array, [ ];
  426                     $self->_load_array(
  427                         $array->[-1], [ @$indent, $indent2 ], $lines
  428                     );
  429                 }
  430 
  431             } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
  432                 push @$array, { };
  433                 $self->_load_hash(
  434                     $array->[-1], [ @$indent, length("$1") ], $lines
  435                 );
  436 
  437             } else {
  438                 die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
  439             }
  440 
  441         } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
  442             # Array entry with a value
  443             shift @$lines;
  444             push @$array, $self->_load_scalar(
  445                 "$2", [ @$indent, undef ], $lines
  446             );
  447 
  448         } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
  449             # This is probably a structure like the following...
  450             # ---
  451             # foo:
  452             # - list
  453             # bar: value
  454             #
  455             # ... so lets return and let the hash parser handle it
  456             return 1;
  457 
  458         } else {
  459             die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
  460         }
  461     }
  462 
  463     return 1;
  464 }
  465 
  466 # Load a hash
  467 sub _load_hash {
  468     my ($self, $hash, $indent, $lines) = @_;
  469 
  470     while ( @$lines ) {
  471         # Check for a new document
  472         if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
  473             while ( @$lines and $lines->[0] !~ /^---/ ) {
  474                 shift @$lines;
  475             }
  476             return 1;
  477         }
  478 
  479         # Check the indent level
  480         $lines->[0] =~ /^(\s*)/;
  481         if ( length($1) < $indent->[-1] ) {
  482             return 1;
  483         } elsif ( length($1) > $indent->[-1] ) {
  484             die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
  485         }
  486 
  487         # Find the key
  488         my $key;
  489 
  490         # Quoted keys
  491         if ( $lines->[0] =~
  492             s/^\s*$re_capture_single_quoted$re_key_value_separator//
  493         ) {
  494             $key = $self->_unquote_single($1);
  495         }
  496         elsif ( $lines->[0] =~
  497             s/^\s*$re_capture_double_quoted$re_key_value_separator//
  498         ) {
  499             $key = $self->_unquote_double($1);
  500         }
  501         elsif ( $lines->[0] =~
  502             s/^\s*$re_capture_unquoted_key$re_key_value_separator//
  503         ) {
  504             $key = $1;
  505             $key =~ s/\s+$//;
  506         }
  507         elsif ( $lines->[0] =~ /^\s*\?/ ) {
  508             die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
  509         }
  510         else {
  511             die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
  512         }
  513 
  514         if ( exists $hash->{$key} ) {
  515             warn "CPAN::Meta::YAML found a duplicate key '$key' in line '$lines->[0]'";
  516         }
  517 
  518         # Do we have a value?
  519         if ( length $lines->[0] ) {
  520             # Yes
  521             $hash->{$key} = $self->_load_scalar(
  522                 shift(@$lines), [ @$indent, undef ], $lines
  523             );
  524         } else {
  525             # An indent
  526             shift @$lines;
  527             unless ( @$lines ) {
  528                 $hash->{$key} = undef;
  529                 return 1;
  530             }
  531             if ( $lines->[0] =~ /^(\s*)-/ ) {
  532                 $hash->{$key} = [];
  533                 $self->_load_array(
  534                     $hash->{$key}, [ @$indent, length($1) ], $lines
  535                 );
  536             } elsif ( $lines->[0] =~ /^(\s*)./ ) {
  537                 my $indent2 = length("$1");
  538                 if ( $indent->[-1] >= $indent2 ) {
  539                     # Null hash entry
  540                     $hash->{$key} = undef;
  541                 } else {
  542                     $hash->{$key} = {};
  543                     $self->_load_hash(
  544                         $hash->{$key}, [ @$indent, length($1) ], $lines
  545                     );
  546                 }
  547             }
  548         }
  549     }
  550 
  551     return 1;
  552 }
  553 
  554 
  555 ###
  556 # Dumper functions:
  557 
  558 # Save an object to a file
  559 sub _dump_file {
  560     my $self = shift;
  561 
  562     require Fcntl;
  563 
  564     # Check the file
  565     my $file = shift or $self->_error( 'You did not specify a file name' );
  566 
  567     my $fh;
  568     # flock if available (or warn if not possible for OS-specific reasons)
  569     if ( _can_flock() ) {
  570         # Open without truncation (truncate comes after lock)
  571         my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
  572         sysopen( $fh, $file, $flags );
  573         unless ( $fh ) {
  574             $self->_error("Failed to open file '$file' for writing: $!");
  575         }
  576 
  577         # Use no translation and strict UTF-8
  578         binmode( $fh, ":raw:encoding(UTF-8)");
  579 
  580         flock( $fh, Fcntl::LOCK_EX() )
  581             or warn "Couldn't lock '$file' for reading: $!";
  582 
  583         # truncate and spew contents
  584         truncate $fh, 0;
  585         seek $fh, 0, 0;
  586     }
  587     else {
  588         open $fh, ">:unix:encoding(UTF-8)", $file;
  589     }
  590 
  591     # serialize and spew to the handle
  592     print {$fh} $self->_dump_string;
  593 
  594     # close the file (release the lock)
  595     unless ( close $fh ) {
  596         $self->_error("Failed to close file '$file': $!");
  597     }
  598 
  599     return 1;
  600 }
  601 
  602 # Save an object to a string
  603 sub _dump_string {
  604     my $self = shift;
  605     return '' unless ref $self && @$self;
  606 
  607     # Iterate over the documents
  608     my $indent = 0;
  609     my @lines  = ();
  610 
  611     eval {
  612         foreach my $cursor ( @$self ) {
  613             push @lines, '---';
  614 
  615             # An empty document
  616             if ( ! defined $cursor ) {
  617                 # Do nothing
  618 
  619             # A scalar document
  620             } elsif ( ! ref $cursor ) {
  621                 $lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
  622 
  623             # A list at the root
  624             } elsif ( ref $cursor eq 'ARRAY' ) {
  625                 unless ( @$cursor ) {
  626                     $lines[-1] .= ' []';
  627                     next;
  628                 }
  629                 push @lines, $self->_dump_array( $cursor, $indent, {} );
  630 
  631             # A hash at the root
  632             } elsif ( ref $cursor eq 'HASH' ) {
  633                 unless ( %$cursor ) {
  634                     $lines[-1] .= ' {}';
  635                     next;
  636                 }
  637                 push @lines, $self->_dump_hash( $cursor, $indent, {} );
  638 
  639             } else {
  640                 die \("Cannot serialize " . ref($cursor));
  641             }
  642         }
  643     };
  644     if ( ref $@ eq 'SCALAR' ) {
  645         $self->_error(${$@});
  646     } elsif ( $@ ) {
  647         $self->_error($@);
  648     }
  649 
  650     join '', map { "$_\n" } @lines;
  651 }
  652 
  653 sub _has_internal_string_value {
  654     my $value = shift;
  655     my $b_obj = B::svref_2object(\$value);  # for round trip problem
  656     return $b_obj->FLAGS & B::SVf_POK();
  657 }
  658 
  659 sub _dump_scalar {
  660     my $string = $_[1];
  661     my $is_key = $_[2];
  662     # Check this before checking length or it winds up looking like a string!
  663     my $has_string_flag = _has_internal_string_value($string);
  664     return '~'  unless defined $string;
  665     return "''" unless length  $string;
  666     if (Scalar::Util::looks_like_number($string)) {
  667         # keys and values that have been used as strings get quoted
  668         if ( $is_key || $has_string_flag ) {
  669             return qq['$string'];
  670         }
  671         else {
  672             return $string;
  673         }
  674     }
  675     if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
  676         $string =~ s/\\/\\\\/g;
  677         $string =~ s/"/\\"/g;
  678         $string =~ s/\n/\\n/g;
  679         $string =~ s/[\x85]/\\N/g;
  680         $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
  681         $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
  682         return qq|"$string"|;
  683     }
  684     if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
  685         $QUOTE{$string}
  686     ) {
  687         return "'$string'";
  688     }
  689     return $string;
  690 }
  691 
  692 sub _dump_array {
  693     my ($self, $array, $indent, $seen) = @_;
  694     if ( $seen->{refaddr($array)}++ ) {
  695         die \"CPAN::Meta::YAML does not support circular references";
  696     }
  697     my @lines  = ();
  698     foreach my $el ( @$array ) {
  699         my $line = ('  ' x $indent) . '-';
  700         my $type = ref $el;
  701         if ( ! $type ) {
  702             $line .= ' ' . $self->_dump_scalar( $el );
  703             push @lines, $line;
  704 
  705         } elsif ( $type eq 'ARRAY' ) {
  706             if ( @$el ) {
  707                 push @lines, $line;
  708                 push @lines, $self->_dump_array( $el, $indent + 1, $seen );
  709             } else {
  710                 $line .= ' []';
  711                 push @lines, $line;
  712             }
  713 
  714         } elsif ( $type eq 'HASH' ) {
  715             if ( keys %$el ) {
  716                 push @lines, $line;
  717                 push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
  718             } else {
  719                 $line .= ' {}';
  720                 push @lines, $line;
  721             }
  722 
  723         } else {
  724             die \"CPAN::Meta::YAML does not support $type references";
  725         }
  726     }
  727 
  728     @lines;
  729 }
  730 
  731 sub _dump_hash {
  732     my ($self, $hash, $indent, $seen) = @_;
  733     if ( $seen->{refaddr($hash)}++ ) {
  734         die \"CPAN::Meta::YAML does not support circular references";
  735     }
  736     my @lines  = ();
  737     foreach my $name ( sort keys %$hash ) {
  738         my $el   = $hash->{$name};
  739         my $line = ('  ' x $indent) . $self->_dump_scalar($name, 1) . ":";
  740         my $type = ref $el;
  741         if ( ! $type ) {
  742             $line .= ' ' . $self->_dump_scalar( $el );
  743             push @lines, $line;
  744 
  745         } elsif ( $type eq 'ARRAY' ) {
  746             if ( @$el ) {
  747                 push @lines, $line;
  748                 push @lines, $self->_dump_array( $el, $indent + 1, $seen );
  749             } else {
  750                 $line .= ' []';
  751                 push @lines, $line;
  752             }
  753 
  754         } elsif ( $type eq 'HASH' ) {
  755             if ( keys %$el ) {
  756                 push @lines, $line;
  757                 push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
  758             } else {
  759                 $line .= ' {}';
  760                 push @lines, $line;
  761             }
  762 
  763         } else {
  764             die \"CPAN::Meta::YAML does not support $type references";
  765         }
  766     }
  767 
  768     @lines;
  769 }
  770 
  771 
  772 
  773 #####################################################################
  774 # DEPRECATED API methods:
  775 
  776 # Error storage (DEPRECATED as of 1.57)
  777 our $errstr    = '';
  778 
  779 # Set error
  780 sub _error {
  781     require Carp;
  782     $errstr = $_[1];
  783     $errstr =~ s/ at \S+ line \d+.*//;
  784     Carp::croak( $errstr );
  785 }
  786 
  787 # Retrieve error
  788 my $errstr_warned;
  789 sub errstr {
  790     require Carp;
  791     Carp::carp( "CPAN::Meta::YAML->errstr and \$CPAN::Meta::YAML::errstr is deprecated" )
  792         unless $errstr_warned++;
  793     $errstr;
  794 }
  795 
  796 
  797 
  798 
  799 #####################################################################
  800 # Helper functions. Possibly not needed.
  801 
  802 
  803 # Use to detect nv or iv
  804 use B;
  805 
  806 # XXX-INGY Is flock CPAN::Meta::YAML's responsibility?
  807 # Some platforms can't flock :-(
  808 # XXX-XDG I think it is.  When reading and writing files, we ought
  809 # to be locking whenever possible.  People (foolishly) use YAML
  810 # files for things like session storage, which has race issues.
  811 my $HAS_FLOCK;
  812 sub _can_flock {
  813     if ( defined $HAS_FLOCK ) {
  814         return $HAS_FLOCK;
  815     }
  816     else {
  817         require Config;
  818         my $c = \%Config::Config;
  819         $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/;
  820         require Fcntl if $HAS_FLOCK;
  821         return $HAS_FLOCK;
  822     }
  823 }
  824 
  825 
  826 # XXX-INGY Is this core in 5.8.1? Can we remove this?
  827 # XXX-XDG Scalar::Util 1.18 didn't land until 5.8.8, so we need this
  828 #####################################################################
  829 # Use Scalar::Util if possible, otherwise emulate it
  830 
  831 use Scalar::Util ();
  832 BEGIN {
  833     local $@;
  834     if ( eval { Scalar::Util->VERSION(1.18); } ) {
  835         *refaddr = *Scalar::Util::refaddr;
  836     }
  837     else {
  838         eval <<'END_PERL';
  839 # Scalar::Util failed to load or too old
  840 sub refaddr {
  841     my $pkg = ref($_[0]) or return undef;
  842     if ( !! UNIVERSAL::can($_[0], 'can') ) {
  843         bless $_[0], 'Scalar::Util::Fake';
  844     } else {
  845         $pkg = undef;
  846     }
  847     "$_[0]" =~ /0x(\w+)/;
  848     my $i = do { no warnings 'portable'; hex $1 };
  849     bless $_[0], $pkg if defined $pkg;
  850     $i;
  851 }
  852 END_PERL
  853     }
  854 }
  855 
  856 delete $CPAN::Meta::YAML::{refaddr};
  857 
  858 1;
  859 
  860 # XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong
  861 # but leaving grey area stuff up here.
  862 #
  863 # I would like to change Read/Write to Load/Dump below without
  864 # changing the actual API names.
  865 #
  866 # It might be better to put Load/Dump API in the SYNOPSIS instead of the
  867 # dubious OO API.
  868 #
  869 # null and bool explanations may be outdated.
  870 
  871 =pod
  872 
  873 =encoding UTF-8
  874 
  875 =head1 NAME
  876 
  877 CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files
  878 
  879 =head1 VERSION
  880 
  881 version 0.018
  882 
  883 =head1 SYNOPSIS
  884 
  885     use CPAN::Meta::YAML;
  886 
  887     # reading a META file
  888     open $fh, "<:utf8", "META.yml";
  889     $yaml_text = do { local $/; <$fh> };
  890     $yaml = CPAN::Meta::YAML->read_string($yaml_text)
  891       or die CPAN::Meta::YAML->errstr;
  892 
  893     # finding the metadata
  894     $meta = $yaml->[0];
  895 
  896     # writing a META file
  897     $yaml_text = $yaml->write_string
  898       or die CPAN::Meta::YAML->errstr;
  899     open $fh, ">:utf8", "META.yml";
  900     print $fh $yaml_text;
  901 
  902 =head1 DESCRIPTION
  903 
  904 This module implements a subset of the YAML specification for use in reading
  905 and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>.  It should
  906 not be used for any other general YAML parsing or generation task.
  907 
  908 NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded.  Users are
  909 responsible for proper encoding and decoding.  In particular, the C<read> and
  910 C<write> methods do B<not> support UTF-8 and should not be used.
  911 
  912 =head1 SUPPORT
  913 
  914 This module is currently derived from L<YAML::Tiny> by Adam Kennedy.  If
  915 there are bugs in how it parses a particular META.yml file, please file
  916 a bug report in the YAML::Tiny bugtracker:
  917 L<https://github.com/Perl-Toolchain-Gang/YAML-Tiny/issues>
  918 
  919 =head1 SEE ALSO
  920 
  921 L<YAML::Tiny>, L<YAML>, L<YAML::XS>
  922 
  923 =head1 AUTHORS
  924 
  925 =over 4
  926 
  927 =item *
  928 
  929 Adam Kennedy <adamk@cpan.org>
  930 
  931 =item *
  932 
  933 David Golden <dagolden@cpan.org>
  934 
  935 =back
  936 
  937 =head1 COPYRIGHT AND LICENSE
  938 
  939 This software is copyright (c) 2010 by Adam Kennedy.
  940 
  941 This is free software; you can redistribute it and/or modify it under
  942 the same terms as the Perl 5 programming language system itself.
  943 
  944 =cut
  945 
  946 __END__
  947 
  948 
  949 # ABSTRACT: Read and write a subset of YAML for CPAN Meta files
  950 
  951