"Fossies" - the Fresh Open Source Software Archive

Member "RT-Extension-Assets-1.05/inc/YAML/Tiny.pm" (6 May 2015, 24978 Bytes) of package /linux/misc/RT-Extension-Assets-1.05.tar.gz:


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. For more information about "Tiny.pm" see the Fossies "Dox" file reference documentation and the last Fossies "Diffs" side-by-side code changes report: 1.02_vs_1.04.

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