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