1use 5.008001; # sane UTF-8 support
2use strict;
3use warnings;
4package 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
17use Exporter;
18our @ISA       = qw{ Exporter  };
19our @EXPORT    = qw{ Load Dump };
20our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
21
22###
23# Functional/Export API:
24
25sub 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
32sub 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.
44BEGIN {
45    *freeze = \&Dump;
46    *thaw   = \&Load;
47}
48
49sub DumpFile {
50    my $file = shift;
51    return CPAN::Meta::YAML->new(@_)->_dump_file($file);
52}
53
54sub 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
78sub 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
91sub read_string {
92    my $self = shift;
93    $self->_load_string(@_);
94}
95
96sub write_string {
97    my $self = shift;
98    $self->_dump_string(@_);
99}
100
101sub read {
102    my $self = shift;
103    $self->_load_file(@_);
104}
105
106sub 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.
119my @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
127my %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.
140my %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/\"((?:\\.|[^\"])*)\"/
148my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
149my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
150# unquoted re gets trailing space that needs to be stripped
151my $re_capture_unquoted_key  = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
152my $re_trailing_comment      = qr/(?:\s+\#.*)?/;
153my $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
170sub _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
213sub _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 \<<'...';
226Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
227Did 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
308sub _unquote_single {
309    my ($self, $string) = @_;
310    return '' unless length $string;
311    $string =~ s/\'\'/\'/g;
312    return $string;
313}
314
315sub _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
326sub _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
385sub _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
467sub _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
559sub _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
603sub _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
653sub _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
659sub _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
692sub _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
731sub _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)
777our $errstr    = '';
778
779# Set error
780sub _error {
781    require Carp;
782    $errstr = $_[1];
783    $errstr =~ s/ at \S+ line \d+.*//;
784    Carp::croak( $errstr );
785}
786
787# Retrieve error
788my $errstr_warned;
789sub 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
804use 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.
811my $HAS_FLOCK;
812sub _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
831use Scalar::Util ();
832BEGIN {
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
840sub 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}
852END_PERL
853    }
854}
855
856delete $CPAN::Meta::YAML::{refaddr};
857
8581;
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
877CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files
878
879=head1 VERSION
880
881version 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
904This module implements a subset of the YAML specification for use in reading
905and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>.  It should
906not be used for any other general YAML parsing or generation task.
907
908NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded.  Users are
909responsible for proper encoding and decoding.  In particular, the C<read> and
910C<write> methods do B<not> support UTF-8 and should not be used.
911
912=head1 SUPPORT
913
914This module is currently derived from L<YAML::Tiny> by Adam Kennedy.  If
915there are bugs in how it parses a particular META.yml file, please file
916a bug report in the YAML::Tiny bugtracker:
917L<https://github.com/Perl-Toolchain-Gang/YAML-Tiny/issues>
918
919=head1 SEE ALSO
920
921L<YAML::Tiny>, L<YAML>, L<YAML::XS>
922
923=head1 AUTHORS
924
925=over 4
926
927=item *
928
929Adam Kennedy <adamk@cpan.org>
930
931=item *
932
933David Golden <dagolden@cpan.org>
934
935=back
936
937=head1 COPYRIGHT AND LICENSE
938
939This software is copyright (c) 2010 by Adam Kennedy.
940
941This is free software; you can redistribute it and/or modify it under
942the 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
952