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