This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Update CPAN-Meta-YAML to CPAN version 0.010
[perl5.git] / cpan / CPAN-Meta-YAML / lib / CPAN / Meta / YAML.pm
1 package CPAN::Meta::YAML;
2 {
3   $CPAN::Meta::YAML::VERSION = '0.010';
4 }
5 BEGIN {
6   $CPAN::Meta::YAML::AUTHORITY = 'cpan:ADAMK';
7 }
8 {
9 ; # original $VERSION removed by Doppelgaenger
10 }
11 # git description: v1.54-8-g4c3002d
12
13
14 use strict;
15 use warnings;
16
17 # UTF Support?
18 sub HAVE_UTF8 () { $] >= 5.007003 }
19 BEGIN {
20     if ( HAVE_UTF8 ) {
21         # The string eval helps hide this from Test::MinimumVersion
22         eval "require utf8;";
23         die "Failed to load UTF-8 support" if $@;
24     }
25
26     # Class structure
27     require 5.004;
28     require Exporter;
29     require Carp;
30     @CPAN::Meta::YAML::ISA       = qw{ Exporter  };
31     @CPAN::Meta::YAML::EXPORT    = qw{ Load Dump };
32     @CPAN::Meta::YAML::EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
33
34     # Error storage
35     $CPAN::Meta::YAML::errstr    = '';
36 }
37
38 # The character class of all characters we need to escape
39 # NOTE: Inlined, since it's only used once
40 # my $RE_ESCAPE = '[\\x00-\\x08\\x0b-\\x0d\\x0e-\\x1f\"\n]';
41
42 # Printed form of the unprintable characters in the lowest range
43 # of ASCII characters, listed by ASCII ordinal position.
44 my @UNPRINTABLE = qw(
45     z    x01  x02  x03  x04  x05  x06  a
46     x08  t    n    v    f    r    x0e  x0f
47     x10  x11  x12  x13  x14  x15  x16  x17
48     x18  x19  x1a  e    x1c  x1d  x1e  x1f
49 );
50
51 # Printable characters for escapes
52 my %UNESCAPES = (
53     z => "\x00", a => "\x07", t    => "\x09",
54     n => "\x0a", v => "\x0b", f    => "\x0c",
55     r => "\x0d", e => "\x1b", '\\' => '\\',
56 );
57
58 # Special magic boolean words
59 my %QUOTE = map { $_ => 1 } qw{
60     null Null NULL
61     y Y yes Yes YES n N no No NO
62     true True TRUE false False FALSE
63     on On ON off Off OFF
64 };
65
66
67
68
69
70 #####################################################################
71 # Implementation
72
73 # Create an empty CPAN::Meta::YAML object
74 sub new {
75     my $class = shift;
76     bless [ @_ ], $class;
77 }
78
79 # Create an object from a file
80 sub read {
81     my $class = ref $_[0] ? ref shift : shift;
82
83     # Check the file
84     my $file = shift or return $class->_error( 'You did not specify a file name' );
85     return $class->_error( "File '$file' does not exist" )              unless -e $file;
86     return $class->_error( "'$file' is a directory, not a file" )       unless -f _;
87     return $class->_error( "Insufficient permissions to read '$file'" ) unless -r _;
88
89     # Slurp in the file
90     local $/ = undef;
91     local *CFG;
92     unless ( open(CFG, $file) ) {
93         return $class->_error("Failed to open file '$file': $!");
94     }
95     my $contents = <CFG>;
96     unless ( close(CFG) ) {
97         return $class->_error("Failed to close file '$file': $!");
98     }
99
100     $class->read_string( $contents );
101 }
102
103 # Create an object from a string
104 sub read_string {
105     my $class  = ref $_[0] ? ref shift : shift;
106     my $self   = bless [], $class;
107     my $string = $_[0];
108     eval {
109         unless ( defined $string ) {
110             die \"Did not provide a string to load";
111         }
112
113         # Byte order marks
114         # NOTE: Keeping this here to educate maintainers
115         # my %BOM = (
116         #     "\357\273\277" => 'UTF-8',
117         #     "\376\377"     => 'UTF-16BE',
118         #     "\377\376"     => 'UTF-16LE',
119         #     "\377\376\0\0" => 'UTF-32LE'
120         #     "\0\0\376\377" => 'UTF-32BE',
121         # );
122         if ( $string =~ /^(?:\376\377|\377\376|\377\376\0\0|\0\0\376\377)/ ) {
123             die \"Stream has a non UTF-8 BOM";
124         } else {
125             # Strip UTF-8 bom if found, we'll just ignore it
126             $string =~ s/^\357\273\277//;
127         }
128
129         # Try to decode as utf8
130         utf8::decode($string) if HAVE_UTF8;
131
132         # Check for some special cases
133         return $self unless length $string;
134         unless ( $string =~ /[\012\015]+\z/ ) {
135             die \"Stream does not end with newline character";
136         }
137
138         # Split the file into lines
139         my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
140                 split /(?:\015{1,2}\012|\015|\012)/, $string;
141
142         # Strip the initial YAML header
143         @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
144
145         # A nibbling parser
146         while ( @lines ) {
147             # Do we have a document header?
148             if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
149                 # Handle scalar documents
150                 shift @lines;
151                 if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
152                     push @$self, $self->_read_scalar( "$1", [ undef ], \@lines );
153                     next;
154                 }
155             }
156
157             if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
158                 # A naked document
159                 push @$self, undef;
160                 while ( @lines and $lines[0] !~ /^---/ ) {
161                     shift @lines;
162                 }
163
164             } elsif ( $lines[0] =~ /^\s*\-/ ) {
165                 # An array at the root
166                 my $document = [ ];
167                 push @$self, $document;
168                 $self->_read_array( $document, [ 0 ], \@lines );
169
170             } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
171                 # A hash at the root
172                 my $document = { };
173                 push @$self, $document;
174                 $self->_read_hash( $document, [ length($1) ], \@lines );
175
176             } else {
177                 die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
178             }
179         }
180     };
181     if ( ref $@ eq 'SCALAR' ) {
182         return $self->_error(${$@});
183     } elsif ( $@ ) {
184         require Carp;
185         Carp::croak($@);
186     }
187
188     return $self;
189 }
190
191 # Deparse a scalar string to the actual scalar
192 sub _read_scalar {
193     my ($self, $string, $indent, $lines) = @_;
194
195     # Trim trailing whitespace
196     $string =~ s/\s*\z//;
197
198     # Explitic null/undef
199     return undef if $string eq '~';
200
201     # Single quote
202     if ( $string =~ /^\'(.*?)\'(?:\s+\#.*)?\z/ ) {
203         return '' unless defined $1;
204         $string = $1;
205         $string =~ s/\'\'/\'/g;
206         return $string;
207     }
208
209     # Double quote.
210     # The commented out form is simpler, but overloaded the Perl regex
211     # engine due to recursion and backtracking problems on strings
212     # larger than 32,000ish characters. Keep it for reference purposes.
213     # if ( $string =~ /^\"((?:\\.|[^\"])*)\"\z/ ) {
214     if ( $string =~ /^\"([^\\"]*(?:\\.[^\\"]*)*)\"(?:\s+\#.*)?\z/ ) {
215         # Reusing the variable is a little ugly,
216         # but avoids a new variable and a string copy.
217         $string = $1;
218         $string =~ s/\\"/"/g;
219         $string =~ s/\\([never\\fartz]|x([0-9a-fA-F]{2}))/(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}/gex;
220         return $string;
221     }
222
223     # Special cases
224     if ( $string =~ /^[\'\"!&]/ ) {
225         die \"CPAN::Meta::YAML does not support a feature in line '$string'";
226     }
227     return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
228     return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
229
230     # Regular unquoted string
231     if ( $string !~ /^[>|]/ ) {
232         if (
233             $string =~ /^(?:-(?:\s|$)|[\@\%\`])/
234             or
235             $string =~ /:(?:\s|$)/
236         ) {
237             die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'";
238         }
239         $string =~ s/\s+#.*\z//;
240         return $string;
241     }
242
243     # Error
244     die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;
245
246     # Check the indent depth
247     $lines->[0]   =~ /^(\s*)/;
248     $indent->[-1] = length("$1");
249     if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
250         die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
251     }
252
253     # Pull the lines
254     my @multiline = ();
255     while ( @$lines ) {
256         $lines->[0] =~ /^(\s*)/;
257         last unless length($1) >= $indent->[-1];
258         push @multiline, substr(shift(@$lines), length($1));
259     }
260
261     my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
262     my $t = (substr($string, 1, 1) eq '-') ? ''  : "\n";
263     return join( $j, @multiline ) . $t;
264 }
265
266 # Parse an array
267 sub _read_array {
268     my ($self, $array, $indent, $lines) = @_;
269
270     while ( @$lines ) {
271         # Check for a new document
272         if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
273             while ( @$lines and $lines->[0] !~ /^---/ ) {
274                 shift @$lines;
275             }
276             return 1;
277         }
278
279         # Check the indent level
280         $lines->[0] =~ /^(\s*)/;
281         if ( length($1) < $indent->[-1] ) {
282             return 1;
283         } elsif ( length($1) > $indent->[-1] ) {
284             die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
285         }
286
287         if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
288             # Inline nested hash
289             my $indent2 = length("$1");
290             $lines->[0] =~ s/-/ /;
291             push @$array, { };
292             $self->_read_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
293
294         } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
295             # Array entry with a value
296             shift @$lines;
297             push @$array, $self->_read_scalar( "$2", [ @$indent, undef ], $lines );
298
299         } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
300             shift @$lines;
301             unless ( @$lines ) {
302                 push @$array, undef;
303                 return 1;
304             }
305             if ( $lines->[0] =~ /^(\s*)\-/ ) {
306                 my $indent2 = length("$1");
307                 if ( $indent->[-1] == $indent2 ) {
308                     # Null array entry
309                     push @$array, undef;
310                 } else {
311                     # Naked indenter
312                     push @$array, [ ];
313                     $self->_read_array( $array->[-1], [ @$indent, $indent2 ], $lines );
314                 }
315
316             } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
317                 push @$array, { };
318                 $self->_read_hash( $array->[-1], [ @$indent, length("$1") ], $lines );
319
320             } else {
321                 die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
322             }
323
324         } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
325             # This is probably a structure like the following...
326             # ---
327             # foo:
328             # - list
329             # bar: value
330             #
331             # ... so lets return and let the hash parser handle it
332             return 1;
333
334         } else {
335             die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
336         }
337     }
338
339     return 1;
340 }
341
342 # Parse an array
343 sub _read_hash {
344     my ($self, $hash, $indent, $lines) = @_;
345
346     while ( @$lines ) {
347         # Check for a new document
348         if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
349             while ( @$lines and $lines->[0] !~ /^---/ ) {
350                 shift @$lines;
351             }
352             return 1;
353         }
354
355         # Check the indent level
356         $lines->[0] =~ /^(\s*)/;
357         if ( length($1) < $indent->[-1] ) {
358             return 1;
359         } elsif ( length($1) > $indent->[-1] ) {
360             die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
361         }
362
363         # Get the key
364         unless ( $lines->[0] =~ s/^\s*([^\'\" ][^\n]*?)\s*:(\s+(?:\#.*)?|$)// ) {
365             if ( $lines->[0] =~ /^\s*[?\'\"]/ ) {
366                 die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
367             }
368             die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
369         }
370         my $key = $1;
371
372         # Do we have a value?
373         if ( length $lines->[0] ) {
374             # Yes
375             $hash->{$key} = $self->_read_scalar( shift(@$lines), [ @$indent, undef ], $lines );
376         } else {
377             # An indent
378             shift @$lines;
379             unless ( @$lines ) {
380                 $hash->{$key} = undef;
381                 return 1;
382             }
383             if ( $lines->[0] =~ /^(\s*)-/ ) {
384                 $hash->{$key} = [];
385                 $self->_read_array( $hash->{$key}, [ @$indent, length($1) ], $lines );
386             } elsif ( $lines->[0] =~ /^(\s*)./ ) {
387                 my $indent2 = length("$1");
388                 if ( $indent->[-1] >= $indent2 ) {
389                     # Null hash entry
390                     $hash->{$key} = undef;
391                 } else {
392                     $hash->{$key} = {};
393                     $self->_read_hash( $hash->{$key}, [ @$indent, length($1) ], $lines );
394                 }
395             }
396         }
397     }
398
399     return 1;
400 }
401
402 # Save an object to a file
403 sub write {
404     my $self = shift;
405     my $file = shift or return $self->_error('No file name provided');
406
407     # Write it to the file
408     open( CFG, '>' . $file ) or return $self->_error(
409         "Failed to open file '$file' for writing: $!"
410         );
411     print CFG $self->write_string;
412     close CFG;
413
414     return 1;
415 }
416
417 # Save an object to a string
418 sub write_string {
419     my $self = shift;
420     return '' unless @$self;
421
422     # Iterate over the documents
423     my $indent = 0;
424     my @lines  = ();
425     foreach my $cursor ( @$self ) {
426         push @lines, '---';
427
428         # An empty document
429         if ( ! defined $cursor ) {
430             # Do nothing
431
432         # A scalar document
433         } elsif ( ! ref $cursor ) {
434             $lines[-1] .= ' ' . $self->_write_scalar( $cursor, $indent );
435
436         # A list at the root
437         } elsif ( ref $cursor eq 'ARRAY' ) {
438             unless ( @$cursor ) {
439                 $lines[-1] .= ' []';
440                 next;
441             }
442             push @lines, $self->_write_array( $cursor, $indent, {} );
443
444         # A hash at the root
445         } elsif ( ref $cursor eq 'HASH' ) {
446             unless ( %$cursor ) {
447                 $lines[-1] .= ' {}';
448                 next;
449             }
450             push @lines, $self->_write_hash( $cursor, $indent, {} );
451
452         } else {
453             Carp::croak("Cannot serialize " . ref($cursor));
454         }
455     }
456
457     join '', map { "$_\n" } @lines;
458 }
459
460 sub _write_scalar {
461     my $string = $_[1];
462     return '~'  unless defined $string;
463     return "''" unless length  $string;
464     if ( $string =~ /[\x00-\x08\x0b-\x0d\x0e-\x1f\"\'\n]/ ) {
465         $string =~ s/\\/\\\\/g;
466         $string =~ s/"/\\"/g;
467         $string =~ s/\n/\\n/g;
468         $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
469         return qq|"$string"|;
470     }
471     if ( $string =~ /(?:^\W|\s|:\z)/ or $QUOTE{$string} ) {
472         return "'$string'";
473     }
474     return $string;
475 }
476
477 sub _write_array {
478     my ($self, $array, $indent, $seen) = @_;
479     if ( $seen->{refaddr($array)}++ ) {
480         die "CPAN::Meta::YAML does not support circular references";
481     }
482     my @lines  = ();
483     foreach my $el ( @$array ) {
484         my $line = ('  ' x $indent) . '-';
485         my $type = ref $el;
486         if ( ! $type ) {
487             $line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
488             push @lines, $line;
489
490         } elsif ( $type eq 'ARRAY' ) {
491             if ( @$el ) {
492                 push @lines, $line;
493                 push @lines, $self->_write_array( $el, $indent + 1, $seen );
494             } else {
495                 $line .= ' []';
496                 push @lines, $line;
497             }
498
499         } elsif ( $type eq 'HASH' ) {
500             if ( keys %$el ) {
501                 push @lines, $line;
502                 push @lines, $self->_write_hash( $el, $indent + 1, $seen );
503             } else {
504                 $line .= ' {}';
505                 push @lines, $line;
506             }
507
508         } else {
509             die "CPAN::Meta::YAML does not support $type references";
510         }
511     }
512
513     @lines;
514 }
515
516 sub _write_hash {
517     my ($self, $hash, $indent, $seen) = @_;
518     if ( $seen->{refaddr($hash)}++ ) {
519         die "CPAN::Meta::YAML does not support circular references";
520     }
521     my @lines  = ();
522     foreach my $name ( sort keys %$hash ) {
523         my $el   = $hash->{$name};
524         my $line = ('  ' x $indent) . "$name:";
525         my $type = ref $el;
526         if ( ! $type ) {
527             $line .= ' ' . $self->_write_scalar( $el, $indent + 1 );
528             push @lines, $line;
529
530         } elsif ( $type eq 'ARRAY' ) {
531             if ( @$el ) {
532                 push @lines, $line;
533                 push @lines, $self->_write_array( $el, $indent + 1, $seen );
534             } else {
535                 $line .= ' []';
536                 push @lines, $line;
537             }
538
539         } elsif ( $type eq 'HASH' ) {
540             if ( keys %$el ) {
541                 push @lines, $line;
542                 push @lines, $self->_write_hash( $el, $indent + 1, $seen );
543             } else {
544                 $line .= ' {}';
545                 push @lines, $line;
546             }
547
548         } else {
549             die "CPAN::Meta::YAML does not support $type references";
550         }
551     }
552
553     @lines;
554 }
555
556 # Set error
557 sub _error {
558     $CPAN::Meta::YAML::errstr = $_[1];
559     undef;
560 }
561
562 # Retrieve error
563 sub errstr {
564     $CPAN::Meta::YAML::errstr;
565 }
566
567
568
569
570
571 #####################################################################
572 # YAML Compatibility
573
574 sub Dump {
575     CPAN::Meta::YAML->new(@_)->write_string;
576 }
577
578 sub Load {
579     my $self = CPAN::Meta::YAML->read_string(@_);
580     unless ( $self ) {
581         Carp::croak("Failed to load YAML document from string");
582     }
583     if ( wantarray ) {
584         return @$self;
585     } else {
586         # To match YAML.pm, return the last document
587         return $self->[-1];
588     }
589 }
590
591 BEGIN {
592     *freeze = *Dump;
593     *thaw   = *Load;
594 }
595
596 sub DumpFile {
597     my $file = shift;
598     CPAN::Meta::YAML->new(@_)->write($file);
599 }
600
601 sub LoadFile {
602     my $self = CPAN::Meta::YAML->read($_[0]);
603     unless ( $self ) {
604         Carp::croak("Failed to load YAML document from '" . ($_[0] || '') . "'");
605     }
606     if ( wantarray ) {
607         return @$self;
608     } else {
609         # Return only the last document to match YAML.pm,
610         return $self->[-1];
611     }
612 }
613
614
615
616
617
618 #####################################################################
619 # Use Scalar::Util if possible, otherwise emulate it
620
621 BEGIN {
622     local $@;
623     eval {
624         require Scalar::Util;
625     };
626     my $v = eval("$Scalar::Util::VERSION") || 0;
627     if ( $@ or $v < 1.18 ) {
628         eval <<'END_PERL';
629 # Scalar::Util failed to load or too old
630 sub refaddr {
631     my $pkg = ref($_[0]) or return undef;
632     if ( !! UNIVERSAL::can($_[0], 'can') ) {
633         bless $_[0], 'Scalar::Util::Fake';
634     } else {
635         $pkg = undef;
636     }
637     "$_[0]" =~ /0x(\w+)/;
638     my $i = do { local $^W; hex $1 };
639     bless $_[0], $pkg if defined $pkg;
640     $i;
641 }
642 END_PERL
643     } else {
644         *refaddr = *Scalar::Util::refaddr;
645     }
646 }
647
648 1;
649
650 =pod
651
652 =encoding utf-8
653
654 =head1 NAME
655
656 CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files
657
658 =head1 VERSION
659
660 version 0.010
661
662 =head1 SYNOPSIS
663
664     use CPAN::Meta::YAML;
665
666     # reading a META file
667     open $fh, "<:utf8", "META.yml";
668     $yaml_text = do { local $/; <$fh> };
669     $yaml = CPAN::Meta::YAML->read_string($yaml_text)
670       or die CPAN::Meta::YAML->errstr;
671
672     # finding the metadata
673     $meta = $yaml->[0];
674
675     # writing a META file
676     $yaml_text = $yaml->write_string
677       or die CPAN::Meta::YAML->errstr;
678     open $fh, ">:utf8", "META.yml";
679     print $fh $yaml_text;
680
681 =head1 DESCRIPTION
682
683 This module implements a subset of the YAML specification for use in reading
684 and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>.  It should
685 not be used for any other general YAML parsing or generation task.
686
687 NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded.  Users are
688 responsible for proper encoding and decoding.  In particular, the C<read> and
689 C<write> methods do B<not> support UTF-8 and should not be used.
690
691 =head1 SUPPORT
692
693 This module is currently derived from L<YAML::Tiny> by Adam Kennedy.  If
694 there are bugs in how it parses a particular META.yml file, please file
695 a bug report in the YAML::Tiny bugtracker:
696 L<https://rt.cpan.org/Public/Dist/Display.html?Name=YAML-Tiny>
697
698 =head1 SEE ALSO
699
700 L<YAML::Tiny>, L<YAML>, L<YAML::XS>
701
702 =for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
703
704 =head1 SUPPORT
705
706 =head2 Bugs / Feature Requests
707
708 Please report any bugs or feature requests through the issue tracker
709 at L<https://github.com/dagolden/CPAN-Meta-YAML/issues>.
710 You will be notified automatically of any progress on your issue.
711
712 =head2 Source Code
713
714 This is open source software.  The code repository is available for
715 public review and contribution under the terms of the license.
716
717 L<https://github.com/dagolden/CPAN-Meta-YAML>
718
719   git clone https://github.com/dagolden/CPAN-Meta-YAML.git
720
721 =head1 AUTHORS
722
723 =over 4
724
725 =item *
726
727 Adam Kennedy <adamk@cpan.org>
728
729 =item *
730
731 David Golden <dagolden@cpan.org>
732
733 =back
734
735 =head1 COPYRIGHT AND LICENSE
736
737 This software is copyright (c) 2010 by Adam Kennedy.
738
739 This is free software; you can redistribute it and/or modify it under
740 the same terms as the Perl 5 programming language system itself.
741
742 =cut
743
744 __END__
745
746
747 # ABSTRACT: Read and write a subset of YAML for CPAN Meta files
748
749