Profile of CPAN/Meta/YAML.pm

Filename	C:/tmp64ng/perl/lib/CPAN/Meta/YAML.pm
Statements	Executed 4860 statements in 0s

Subroutines
Calls	P	F	Exclusive Time	Inclusive Time	Subroutine
1	1	1	0s	0s	CPAN::Meta::YAML::::BEGIN@201 CPAN::Meta::YAML::BEGIN@201
1	1	1	0s	0s	CPAN::Meta::YAML::::BEGIN@22 CPAN::Meta::YAML::BEGIN@22
1	1	1	0s	0s	CPAN::Meta::YAML::::BEGIN@49 CPAN::Meta::YAML::BEGIN@49
1	1	1	0s	0s	CPAN::Meta::YAML::::BEGIN@6 CPAN::Meta::YAML::BEGIN@6
1	1	1	0s	0s	CPAN::Meta::YAML::::BEGIN@804 CPAN::Meta::YAML::BEGIN@804
1	1	1	0s	0s	CPAN::Meta::YAML::::BEGIN@831 CPAN::Meta::YAML::BEGIN@831
468	2	1	0s	0s	CPAN::Meta::YAML::::CORE:match CPAN::Meta::YAML::CORE:match (opcode)
5	5	1	0s	0s	CPAN::Meta::YAML::::CORE:qr CPAN::Meta::YAML::CORE:qr (opcode)
48	1	1	0s	0s	CPAN::Meta::YAML::::CORE:sort CPAN::Meta::YAML::CORE:sort (opcode)
9	1	1	0s	0s	CPAN::Meta::YAML::::Dump CPAN::Meta::YAML::Dump
0	0	0	0s	0s	CPAN::Meta::YAML::::DumpFile CPAN::Meta::YAML::DumpFile
0	0	0	0s	0s	CPAN::Meta::YAML::::Load CPAN::Meta::YAML::Load
0	0	0	0s	0s	CPAN::Meta::YAML::::LoadFile CPAN::Meta::YAML::LoadFile
0	0	0	0s	0s	CPAN::Meta::YAML::::_can_flock CPAN::Meta::YAML::_can_flock
18	1	1	0s	0s	CPAN::Meta::YAML::::_dump_array CPAN::Meta::YAML::_dump_array
0	0	0	0s	0s	CPAN::Meta::YAML::::_dump_file CPAN::Meta::YAML::_dump_file
48	2	1	0s	0s	CPAN::Meta::YAML::::_dump_hash CPAN::Meta::YAML::_dump_hash (recurses: max depth 1, inclusive time 0s)
279	3	1	0s	0s	CPAN::Meta::YAML::::_dump_scalar CPAN::Meta::YAML::_dump_scalar
9	1	1	0s	0s	CPAN::Meta::YAML::::_dump_string CPAN::Meta::YAML::_dump_string
0	0	0	0s	0s	CPAN::Meta::YAML::::_error CPAN::Meta::YAML::_error
279	1	1	0s	0s	CPAN::Meta::YAML::_has_internal_string_value
0	0	0	0s	0s	CPAN::Meta::YAML::::_load_array CPAN::Meta::YAML::_load_array
0	0	0	0s	0s	CPAN::Meta::YAML::::_load_file CPAN::Meta::YAML::_load_file
0	0	0	0s	0s	CPAN::Meta::YAML::::_load_hash CPAN::Meta::YAML::_load_hash
0	0	0	0s	0s	CPAN::Meta::YAML::::_load_scalar CPAN::Meta::YAML::_load_scalar
0	0	0	0s	0s	CPAN::Meta::YAML::::_load_string CPAN::Meta::YAML::_load_string
0	0	0	0s	0s	CPAN::Meta::YAML::::_unquote_double CPAN::Meta::YAML::_unquote_double
0	0	0	0s	0s	CPAN::Meta::YAML::::_unquote_single CPAN::Meta::YAML::_unquote_single
0	0	0	0s	0s	CPAN::Meta::YAML::::errstr CPAN::Meta::YAML::errstr
9	1	1	0s	0s	CPAN::Meta::YAML::::new CPAN::Meta::YAML::new
0	0	0	0s	0s	CPAN::Meta::YAML::::read CPAN::Meta::YAML::read
0	0	0	0s	0s	CPAN::Meta::YAML::::read_string CPAN::Meta::YAML::read_string
0	0	0	0s	0s	CPAN::Meta::YAML::::write CPAN::Meta::YAML::write
0	0	0	0s	0s	CPAN::Meta::YAML::::write_string CPAN::Meta::YAML::write_string
1	1	1	0s	0s	Parse::CPAN::Meta::::BEGIN@1Parse::CPAN::Meta::BEGIN@1
1	1	1	0s	0s	Parse::CPAN::Meta::::BEGIN@2Parse::CPAN::Meta::BEGIN@2
1	1	1	0s	0s	Parse::CPAN::Meta::::BEGIN@3Parse::CPAN::Meta::BEGIN@3

Call graph for these subroutines as a Graphviz dot language file.

Line	State ments	Time on line	Calls	Time in subs	Code
1	2	0s	1	0s	# spent 0s within Parse::CPAN::Meta::BEGIN@1 which was called: # once (0s+0s) by Parse::CPAN::Meta::_can_load at line 1 use 5.008001; # sane UTF-8 support # spent 0s making 1 call to Parse::CPAN::Meta::BEGIN@1
2	2	0s	2	0s	# spent 0s within Parse::CPAN::Meta::BEGIN@2 which was called: # once (0s+0s) by Parse::CPAN::Meta::_can_load at line 2 use strict; # spent 0s making 1 call to Parse::CPAN::Meta::BEGIN@2 # spent 0s making 1 call to strict::import
3	2	0s	2	0s	# spent 0s within Parse::CPAN::Meta::BEGIN@3 which was called: # once (0s+0s) by Parse::CPAN::Meta::_can_load at line 3 use warnings; # spent 0s making 1 call to Parse::CPAN::Meta::BEGIN@3 # spent 0s making 1 call to warnings::import
4					package CPAN::Meta::YAML;
5	1	0s			$CPAN::Meta::YAML::VERSION = '0.012';
6					# spent 0s within CPAN::Meta::YAML::BEGIN@6 which was called: # once (0s+0s) by Parse::CPAN::Meta::_can_load at line 8 BEGIN {
7	1	0s			$CPAN::Meta::YAML::AUTHORITY = 'cpan:ADAMK';
8	1	0s	1	0s	} # spent 0s making 1 call to CPAN::Meta::YAML::BEGIN@6
9					# git description: v1.60-1-g1c16a0a
10					; # original $VERSION removed by Doppelgaenger
11					# XXX-INGY is 5.8.1 too old/broken for utf8?
12					# XXX-XDG Lancaster consensus was that it was sufficient until
13					# proven otherwise
14
15
16					#####################################################################
17					# The CPAN::Meta::YAML API.
18					#
19					# These are the currently documented API functions/methods and
20					# exports:
21
22	2	0s	2	0s	# spent 0s within CPAN::Meta::YAML::BEGIN@22 which was called: # once (0s+0s) by Parse::CPAN::Meta::_can_load at line 22 use Exporter; # spent 0s making 1 call to CPAN::Meta::YAML::BEGIN@22 # spent 0s making 1 call to Exporter::import
23	1	0s			our @ISA = qw{ Exporter };
24	1	0s			our @EXPORT = qw{ Load Dump };
25	1	0s			our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
26
27					###
28					# Functional/Export API:
29
30					# spent 0s within CPAN::Meta::YAML::Dump which was called 9 times, avg 0s/call: # 9 times (0s+0s) by CPAN::Meta::as_string at line 616 of CPAN/Meta.pm, avg 0s/call sub Dump {
31	9	0s	18	0s	return CPAN::Meta::YAML->new(@_)->_dump_string; # spent 0s making 9 calls to CPAN::Meta::YAML::_dump_string, avg 0s/call # spent 0s making 9 calls to CPAN::Meta::YAML::new, avg 0s/call
32					}
33
34					# XXX-INGY Returning last document seems a bad behavior.
35					# XXX-XDG I think first would seem more natural, but I don't know
36					# that it's worth changing now
37					sub Load {
38					my $self = CPAN::Meta::YAML->_load_string(@_);
39					if ( wantarray ) {
40					return @$self;
41					} else {
42					# To match YAML.pm, return the last document
43					return $self->[-1];
44					}
45					}
46
47					# XXX-INGY Do we really need freeze and thaw?
48					# XXX-XDG I don't think so. I'd support deprecating them.
49					# spent 0s within CPAN::Meta::YAML::BEGIN@49 which was called: # once (0s+0s) by Parse::CPAN::Meta::_can_load at line 52 BEGIN {
50	1	0s			*freeze = \&Dump;
51	1	0s			*thaw = \&Load;
52	1	0s	1	0s	} # spent 0s making 1 call to CPAN::Meta::YAML::BEGIN@49
53
54					sub DumpFile {
55					my $file = shift;
56					return CPAN::Meta::YAML->new(@_)->_dump_file($file);
57					}
58
59					sub LoadFile {
60					my $file = shift;
61					my $self = CPAN::Meta::YAML->_load_file($file);
62					if ( wantarray ) {
63					return @$self;
64					} else {
65					# Return only the last document to match YAML.pm,
66					return $self->[-1];
67					}
68					}
69
70
71					###
72					# Object Oriented API:
73
74					# Create an empty CPAN::Meta::YAML object
75					# XXX-INGY Why do we use ARRAY object?
76					# NOTE: I get it now, but I think it's confusing and not needed.
77					# Will change it on a branch later, for review.
78					#
79					# XXX-XDG I don't support changing it yet. It's a very well-documented
80					# "API" of CPAN::Meta::YAML. I'd support deprecating it, but Adam suggested
81					# we not change it until YAML.pm's own OO API is established so that
82					# users only have one API change to digest, not two
83					# spent 0s within CPAN::Meta::YAML::new which was called 9 times, avg 0s/call: # 9 times (0s+0s) by CPAN::Meta::YAML::Dump at line 31, avg 0s/call sub new {
84	9	0s			my $class = shift;
85	9	0s			bless [ @_ ], $class;
86					}
87
88					# XXX-INGY It probably doesn't matter, and it's probably too late to
89					# change, but 'read/write' are the wrong names. Read and Write
90					# are actions that take data from storage to memory
91					# characters/strings. These take the data to/from storage to native
92					# Perl objects, which the terms dump and load are meant. As long as
93					# this is a legacy quirk to CPAN::Meta::YAML it's ok, but I'd prefer not
94					# to add new {read,write}_* methods to this API.
95
96					sub read_string {
97					my $self = shift;
98					$self->_load_string(@_);
99					}
100
101					sub write_string {
102					my $self = shift;
103					$self->_dump_string(@_);
104					}
105
106					sub read {
107					my $self = shift;
108					$self->_load_file(@_);
109					}
110
111					sub write {
112					my $self = shift;
113					$self->_dump_file(@_);
114					}
115
- -
119					#####################################################################
120					# Constants
121
122					# Printed form of the unprintable characters in the lowest range
123					# of ASCII characters, listed by ASCII ordinal position.
124	1	0s			my @UNPRINTABLE = qw(
125					0 x01 x02 x03 x04 x05 x06 a
126					b t n v f r x0E x0F
127					x10 x11 x12 x13 x14 x15 x16 x17
128					x18 x19 x1A e x1C x1D x1E x1F
129					);
130
131					# Printable characters for escapes
132	1	0s			my %UNESCAPES = (
133					0 => "\x00", z => "\x00", N => "\x85",
134					a => "\x07", b => "\x08", t => "\x09",
135					n => "\x0a", v => "\x0b", f => "\x0c",
136					r => "\x0d", e => "\x1b", '\\' => '\\',
137					);
138
139					# XXX-INGY
140					# I(ngy) need to decide if these values should be quoted in
141					# CPAN::Meta::YAML or not. Probably yes.
142
143					# These 3 values have special meaning when unquoted and using the
144					# default YAML schema. They need quotes if they are strings.
145	1	0s			my %QUOTE = map { $_ => 1 } qw{
146					null true false
147					};
148
149					# The commented out form is simpler, but overloaded the Perl regex
150					# engine due to recursion and backtracking problems on strings
151					# larger than 32,000ish characters. Keep it for reference purposes.
152					# qr/\"((?:\\.\|[^\"])*)\"/
153	1	0s	1	0s	my $re_capture_double_quoted = qr/\"([^\\"](?:\\.[^\\"])*)\"/; # spent 0s making 1 call to CPAN::Meta::YAML::CORE:qr
154	1	0s	1	0s	my $re_capture_single_quoted = qr/\'([^\'](?:\'\'[^\'])*)\'/; # spent 0s making 1 call to CPAN::Meta::YAML::CORE:qr
155					# unquoted re gets trailing space that needs to be stripped
156	1	0s	1	0s	my $re_capture_unquoted_key = qr/([^:]+(?::+\S[^:]))(?=\s*\:(?:\s+\|$))/; # spent 0s making 1 call to CPAN::Meta::YAML::CORE:qr
157	1	0s	1	0s	my $re_trailing_comment = qr/(?:\s+\#.*)?/; # spent 0s making 1 call to CPAN::Meta::YAML::CORE:qr
158	1	0s	1	0s	my $re_key_value_separator = qr/\s:(?:\s+(?:\#.)?\|$)/; # spent 0s making 1 call to CPAN::Meta::YAML::CORE:qr
159
- -
164					#####################################################################
165					# CPAN::Meta::YAML Implementation.
166					#
167					# These are the private methods that do all the work. They may change
168					# at any time.
169
170
171					###
172					# Loader functions:
173
174					# Create an object from a file
175					sub _load_file {
176					my $class = ref $_[0] ? ref shift : shift;
177
178					# Check the file
179					my $file = shift or $class->_error( 'You did not specify a file name' );
180					$class->_error( "File '$file' does not exist" )
181					unless -e $file;
182					$class->_error( "'$file' is a directory, not a file" )
183					unless -f _;
184					$class->_error( "Insufficient permissions to read '$file'" )
185					unless -r _;
186
187					# Open unbuffered with strict UTF-8 decoding and no translation layers
188					open( my $fh, "<:unix:encoding(UTF-8)", $file );
189					unless ( $fh ) {
190					$class->_error("Failed to open file '$file': $!");
191					}
192
193					# flock if available (or warn if not possible for OS-specific reasons)
194					if ( _can_flock() ) {
195					flock( $fh, Fcntl::LOCK_SH() )
196					or warn "Couldn't lock '$file' for reading: $!";
197					}
198
199					# slurp the contents
200					my $contents = eval {
201	2	0s	2	0s	# spent 0s within CPAN::Meta::YAML::BEGIN@201 which was called: # once (0s+0s) by Parse::CPAN::Meta::_can_load at line 201 use warnings FATAL => 'utf8'; # spent 0s making 1 call to CPAN::Meta::YAML::BEGIN@201 # spent 0s making 1 call to warnings::import
202					local $/;
203					<$fh>
204					};
205					if ( my $err = $@ ) {
206					$class->_error("Error reading from file '$file': $err");
207					}
208
209					# close the file (release the lock)
210					unless ( close $fh ) {
211					$class->_error("Failed to close file '$file': $!");
212					}
213
214					$class->_load_string( $contents );
215					}
216
217					# Create an object from a string
218					sub _load_string {
219					my $class = ref $_[0] ? ref shift : shift;
220					my $self = bless [], $class;
221					my $string = $_[0];
222					eval {
223					unless ( defined $string ) {
224					die \"Did not provide a string to load";
225					}
226
227					# Check if Perl has it marked as characters, but it's internally
228					# inconsistent. E.g. maybe latin1 got read on a :utf8 layer
229					if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
230					die \<<'...';
231					Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
232					Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
233					...
234					}
235
236					# Ensure Unicode character semantics, even for 0x80-0xff
237					utf8::upgrade($string);
238
239					# Check for and strip any leading UTF-8 BOM
240					$string =~ s/^\x{FEFF}//;
241
242					# Check for some special cases
243					return $self unless length $string;
244
245					# Split the file into lines
246					my @lines = grep { ! /^\s(?:\#.)?\z/ }
247					split /(?:\015{1,2}\012\|\015\|\012)/, $string;
248
249					# Strip the initial YAML header
250					@lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
251
252					# A nibbling parser
253					my $in_document = 0;
254					while ( @lines ) {
255					# Do we have a document header?
256					if ( $lines[0] =~ /^---\s(?:(.+)\s)?\z/ ) {
257					# Handle scalar documents
258					shift @lines;
259					if ( defined $1 and $1 !~ /^(?:\#.+\|\%YAML[: ][\d\.]+)\z/ ) {
260					push @$self,
261					$self->_load_scalar( "$1", [ undef ], \@lines );
262					next;
263					}
264					$in_document = 1;
265					}
266
267					if ( ! @lines or $lines[0] =~ /^(?:---\|\.\.\.)/ ) {
268					# A naked document
269					push @$self, undef;
270					while ( @lines and $lines[0] !~ /^---/ ) {
271					shift @lines;
272					}
273					$in_document = 0;
274
275					# XXX The final '-+$' is to look for -- which ends up being an
276					# error later.
277					} elsif ( ! $in_document && @$self ) {
278					# only the first document can be explicit
279					die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
280					} elsif ( $lines[0] =~ /^\s*\-(?:\s\|$\|-+$)/ ) {
281					# An array at the root
282					my $document = [ ];
283					push @$self, $document;
284					$self->_load_array( $document, [ 0 ], \@lines );
285
286					} elsif ( $lines[0] =~ /^(\s*)\S/ ) {
287					# A hash at the root
288					my $document = { };
289					push @$self, $document;
290					$self->_load_hash( $document, [ length($1) ], \@lines );
291
292					} else {
293					# Shouldn't get here. @lines have whitespace-only lines
294					# stripped, and previous match is a line with any
295					# non-whitespace. So this clause should only be reachable via
296					# a perlbug where \s is not symmetric with \S
297
298					# uncoverable statement
299					die \"CPAN::Meta::YAML failed to classify the line '$lines[0]'";
300					}
301					}
302					};
303					if ( ref $@ eq 'SCALAR' ) {
304					$self->_error(${$@});
305					} elsif ( $@ ) {
306					$self->_error($@);
307					}
308
309					return $self;
310					}
311
312					sub _unquote_single {
313					my ($self, $string) = @_;
314					return '' unless length $string;
315					$string =~ s/\'\'/\'/g;
316					return $string;
317					}
318
319					sub _unquote_double {
320					my ($self, $string) = @_;
321					return '' unless length $string;
322					$string =~ s/\\"/"/g;
323					$string =~
324					s{\\([Nnever\\fartz0b]\|x([0-9a-fA-F]{2}))}
325					{(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
326					return $string;
327					}
328
329					# Load a YAML scalar string to the actual Perl scalar
330					sub _load_scalar {
331					my ($self, $string, $indent, $lines) = @_;
332
333					# Trim trailing whitespace
334					$string =~ s/\s*\z//;
335
336					# Explitic null/undef
337					return undef if $string eq '~';
338
339					# Single quote
340					if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
341					return $self->_unquote_single($1);
342					}
343
344					# Double quote.
345					if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
346					return $self->_unquote_double($1);
347					}
348
349					# Special cases
350					if ( $string =~ /^[\'\"!&]/ ) {
351					die \"CPAN::Meta::YAML does not support a feature in line '$string'";
352					}
353					return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
354					return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
355
356					# Regular unquoted string
357					if ( $string !~ /^[>\|]/ ) {
358					die \"CPAN::Meta::YAML found illegal characters in plain scalar: '$string'"
359					if $string =~ /^(?:-(?:\s\|$)\|[\@\%\`])/ or
360					$string =~ /:(?:\s\|$)/;
361					$string =~ s/\s+#.*\z//;
362					return $string;
363					}
364
365					# Error
366					die \"CPAN::Meta::YAML failed to find multi-line scalar content" unless @$lines;
367
368					# Check the indent depth
369					$lines->[0] =~ /^(\s*)/;
370					$indent->[-1] = length("$1");
371					if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
372					die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
373					}
374
375					# Pull the lines
376					my @multiline = ();
377					while ( @$lines ) {
378					$lines->[0] =~ /^(\s*)/;
379					last unless length($1) >= $indent->[-1];
380					push @multiline, substr(shift(@$lines), length($1));
381					}
382
383					my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
384					my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
385					return join( $j, @multiline ) . $t;
386					}
387
388					# Load an array
389					sub _load_array {
390					my ($self, $array, $indent, $lines) = @_;
391
392					while ( @$lines ) {
393					# Check for a new document
394					if ( $lines->[0] =~ /^(?:---\|\.\.\.)/ ) {
395					while ( @$lines and $lines->[0] !~ /^---/ ) {
396					shift @$lines;
397					}
398					return 1;
399					}
400
401					# Check the indent level
402					$lines->[0] =~ /^(\s*)/;
403					if ( length($1) < $indent->[-1] ) {
404					return 1;
405					} elsif ( length($1) > $indent->[-1] ) {
406					die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
407					}
408
409					if ( $lines->[0] =~ /^(\s\-\s+)[^\'\"]\S\s*:(?:\s+\|$)/ ) {
410					# Inline nested hash
411					my $indent2 = length("$1");
412					$lines->[0] =~ s/-/ /;
413					push @$array, { };
414					$self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
415
416					} elsif ( $lines->[0] =~ /^\s\-\s\z/ ) {
417					shift @$lines;
418					unless ( @$lines ) {
419					push @$array, undef;
420					return 1;
421					}
422					if ( $lines->[0] =~ /^(\s*)\-/ ) {
423					my $indent2 = length("$1");
424					if ( $indent->[-1] == $indent2 ) {
425					# Null array entry
426					push @$array, undef;
427					} else {
428					# Naked indenter
429					push @$array, [ ];
430					$self->_load_array(
431					$array->[-1], [ @$indent, $indent2 ], $lines
432					);
433					}
434
435					} elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
436					push @$array, { };
437					$self->_load_hash(
438					$array->[-1], [ @$indent, length("$1") ], $lines
439					);
440
441					} else {
442					die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
443					}
444
445					} elsif ( $lines->[0] =~ /^\s\-(\s)(.+?)\s*\z/ ) {
446					# Array entry with a value
447					shift @$lines;
448					push @$array, $self->_load_scalar(
449					"$2", [ @$indent, undef ], $lines
450					);
451
452					} elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
453					# This is probably a structure like the following...
454					# ---
455					# foo:
456					# - list
457					# bar: value
458					#
459					# ... so lets return and let the hash parser handle it
460					return 1;
461
462					} else {
463					die \"CPAN::Meta::YAML failed to classify line '$lines->[0]'";
464					}
465					}
466
467					return 1;
468					}
469
470					# Load a hash
471					sub _load_hash {
472					my ($self, $hash, $indent, $lines) = @_;
473
474					while ( @$lines ) {
475					# Check for a new document
476					if ( $lines->[0] =~ /^(?:---\|\.\.\.)/ ) {
477					while ( @$lines and $lines->[0] !~ /^---/ ) {
478					shift @$lines;
479					}
480					return 1;
481					}
482
483					# Check the indent level
484					$lines->[0] =~ /^(\s*)/;
485					if ( length($1) < $indent->[-1] ) {
486					return 1;
487					} elsif ( length($1) > $indent->[-1] ) {
488					die \"CPAN::Meta::YAML found bad indenting in line '$lines->[0]'";
489					}
490
491					# Find the key
492					my $key;
493
494					# Quoted keys
495					if ( $lines->[0] =~
496					s/^\s*$re_capture_single_quoted$re_key_value_separator//
497					) {
498					$key = $self->_unquote_single($1);
499					}
500					elsif ( $lines->[0] =~
501					s/^\s*$re_capture_double_quoted$re_key_value_separator//
502					) {
503					$key = $self->_unquote_double($1);
504					}
505					elsif ( $lines->[0] =~
506					s/^\s*$re_capture_unquoted_key$re_key_value_separator//
507					) {
508					$key = $1;
509					$key =~ s/\s+$//;
510					}
511					elsif ( $lines->[0] =~ /^\s*\?/ ) {
512					die \"CPAN::Meta::YAML does not support a feature in line '$lines->[0]'";
513					}
514					else {
515					die \"CPAN::Meta::YAML failed to classify 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
559					sub _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
603					# spent 0s within CPAN::Meta::YAML::_dump_string which was called 9 times, avg 0s/call: # 9 times (0s+0s) by CPAN::Meta::YAML::Dump at line 31, avg 0s/call sub _dump_string {
604	9	0s			my $self = shift;
605	9	0s			return '' unless ref $self && @$self;
606
607					# Iterate over the documents
608	9	0s			my $indent = 0;
609	9	0s			my @lines = ();
610
611	9	0s			eval {
612	9	0s			foreach my $cursor ( @$self ) {
613	9	0s			push @lines, '---';
614
615					# An empty document
616	9	0s			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	9	0s			unless ( %$cursor ) {
634					$lines[-1] .= ' {}';
635					next;
636					}
637	9	0s	9	0s	push @lines, $self->_dump_hash( $cursor, $indent, {} ); # spent 0s making 9 calls to CPAN::Meta::YAML::_dump_hash, avg 0s/call
638
639					} else {
640					die \("Cannot serialize " . ref($cursor));
641					}
642					}
643					};
644	9	0s			if ( ref $@ eq 'SCALAR' ) {
645					$self->_error(${$@});
646					} elsif ( $@ ) {
647					$self->_error($@);
648					}
649
650	9	0s			join '', map { "$_\n" } @lines;
651					}
652
653					# spent 0s within CPAN::Meta::YAML::_has_internal_string_value which was called 279 times, avg 0s/call: # 279 times (0s+0s) by CPAN::Meta::YAML::_dump_scalar at line 663, avg 0s/call sub _has_internal_string_value {
654	279	0s			my $value = shift;
655	279	0s	279	0s	my $b_obj = B::svref_2object(\$value); # for round trip problem # spent 0s making 279 calls to B::svref_2object, avg 0s/call
656	279	0s	279	0s	return $b_obj->FLAGS & B::SVf_POK(); # spent 0s making 279 calls to B::SV::FLAGS, avg 0s/call
657					}
658
659					# spent 0s within CPAN::Meta::YAML::_dump_scalar which was called 279 times, avg 0s/call: # 159 times (0s+0s) by CPAN::Meta::YAML::_dump_hash at line 739, avg 0s/call # 93 times (0s+0s) by CPAN::Meta::YAML::_dump_hash at line 742, avg 0s/call # 27 times (0s+0s) by CPAN::Meta::YAML::_dump_array at line 702, avg 0s/call sub _dump_scalar {
660	279	0s			my $string = $_[1];
661	279	0s			my $is_key = $_[2];
662					# Check this before checking length or it winds up looking like a string!
663	279	0s	279	0s	my $has_string_flag = _has_internal_string_value($string); # spent 0s making 279 calls to CPAN::Meta::YAML::_has_internal_string_value, avg 0s/call
664	279	0s			return '~' unless defined $string;
665	279	0s			return "''" unless length $string;
666	279	0s	279	0s	if (Scalar::Util::looks_like_number($string)) { # spent 0s making 279 calls to Scalar::Util::looks_like_number, avg 0s/call
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	9	0s			return $string;
673					}
674					}
675	234	0s	234	0s	if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) { # spent 0s making 234 calls to CPAN::Meta::YAML::CORE:match, avg 0s/call
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	234	0s	234	0s	if ( $string =~ /(?:^[~!@#%&*\|>?:,'"`{}\[\]]\|^-+$\|\s\|:\z)/ or # spent 0s making 234 calls to CPAN::Meta::YAML::CORE:match, avg 0s/call
685					$QUOTE{$string}
686					) {
687					return "'$string'";
688					}
689	219	0s			return $string;
690					}
691
692					# spent 0s within CPAN::Meta::YAML::_dump_array which was called 18 times, avg 0s/call: # 18 times (0s+0s) by CPAN::Meta::YAML::_dump_hash at line 748, avg 0s/call sub _dump_array {
693	18	0s			my ($self, $array, $indent, $seen) = @_;
694	18	0s	18	0s	if ( $seen->{refaddr($array)}++ ) { # spent 0s making 18 calls to Scalar::Util::refaddr, avg 0s/call
695					die \"CPAN::Meta::YAML does not support circular references";
696					}
697	18	0s			my @lines = ();
698	18	0s			foreach my $el ( @$array ) {
699	27	0s			my $line = (' ' x $indent) . '-';
700	27	0s			my $type = ref $el;
701	27	0s			if ( ! $type ) {
702	27	0s	27	0s	$line .= ' ' . $self->_dump_scalar( $el ); # spent 0s making 27 calls to CPAN::Meta::YAML::_dump_scalar, avg 0s/call
703	27	0s			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	18	0s			@lines;
729					}
730
731					# spent 0s within CPAN::Meta::YAML::_dump_hash which was called 48 times, avg 0s/call: # 39 times (0s+0s) by CPAN::Meta::YAML::_dump_hash at line 757, avg 0s/call # 9 times (0s+0s) by CPAN::Meta::YAML::_dump_string at line 637, avg 0s/call sub _dump_hash {
732	48	0s			my ($self, $hash, $indent, $seen) = @_;
733	48	0s	48	0s	if ( $seen->{refaddr($hash)}++ ) { # spent 0s making 48 calls to Scalar::Util::refaddr, avg 0s/call
734					die \"CPAN::Meta::YAML does not support circular references";
735					}
736	48	0s			my @lines = ();
737	48	0s	48	0s	foreach my $name ( sort keys %$hash ) { # spent 0s making 48 calls to CPAN::Meta::YAML::CORE:sort, avg 0s/call
738	159	0s			my $el = $hash->{$name};
739	159	0s	159	0s	my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":"; # spent 0s making 159 calls to CPAN::Meta::YAML::_dump_scalar, avg 0s/call
740	159	0s			my $type = ref $el;
741	159	0s			if ( ! $type ) {
742	93	0s	93	0s	$line .= ' ' . $self->_dump_scalar( $el ); # spent 0s making 93 calls to CPAN::Meta::YAML::_dump_scalar, avg 0s/call
743	93	0s			push @lines, $line;
744
745					} elsif ( $type eq 'ARRAY' ) {
746	18	0s			if ( @$el ) {
747	18	0s			push @lines, $line;
748	18	0s	18	0s	push @lines, $self->_dump_array( $el, $indent + 1, $seen ); # spent 0s making 18 calls to CPAN::Meta::YAML::_dump_array, avg 0s/call
749					} else {
750					$line .= ' []';
751					push @lines, $line;
752					}
753
754					} elsif ( $type eq 'HASH' ) {
755	48	0s			if ( keys %$el ) {
756	39	0s			push @lines, $line;
757	39	0s	39	0s	push @lines, $self->_dump_hash( $el, $indent + 1, $seen ); # spent 0s making 39 calls to CPAN::Meta::YAML::_dump_hash, avg 0s/call, recursion: max depth 1, sum of overlapping time 0s
758					} else {
759	9	0s			$line .= ' {}';
760	9	0s			push @lines, $line;
761					}
762
763					} else {
764					die \"CPAN::Meta::YAML does not support $type references";
765					}
766					}
767
768	48	0s			@lines;
769					}
770
- -
773					#####################################################################
774					# DEPRECATED API methods:
775
776					# Error storage (DEPRECATED as of 1.57)
777	1	0s			our $errstr = '';
778
779					# Set error
780					sub _error {
781					require Carp;
782					$errstr = $_[1];
783					$errstr =~ s/ at \S+ line \d+.*//;
784					Carp::croak( $errstr );
785					}
786
787					# Retrieve error
788	1	0s			my $errstr_warned;
789					sub 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
- -
799					#####################################################################
800					# Helper functions. Possibly not needed.
801
802
803					# Use to detect nv or iv
804	2	0s	2	0s	# spent 0s within CPAN::Meta::YAML::BEGIN@804 which was called: # once (0s+0s) by Parse::CPAN::Meta::_can_load at line 804 use B; # spent 0s making 1 call to CPAN::Meta::YAML::BEGIN@804 # spent 0s making 1 call to Exporter::import
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.
811					my $HAS_FLOCK;
812					sub _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
831					# spent 0s within CPAN::Meta::YAML::BEGIN@831 which was called: # once (0s+0s) by Parse::CPAN::Meta::_can_load at line 856 BEGIN {
832	1	0s			local $@;
833	2	0s			if ( eval { require Scalar::Util } # spent 0s executing statements in string eval
834					&& $Scalar::Util::VERSION
835					&& eval($Scalar::Util::VERSION) >= 1.18
836					) {
837					refaddr = Scalar::Util::refaddr;
838					}
839					else {
840					eval <<'END_PERL';
841					# Scalar::Util failed to load or too old
842					sub refaddr {
843					my $pkg = ref($_[0]) or return undef;
844					if ( !! UNIVERSAL::can($_[0], 'can') ) {
845					bless $_[0], 'Scalar::Util::Fake';
846					} else {
847					$pkg = undef;
848					}
849					"$_[0]" =~ /0x(\w+)/;
850					my $i = do { no warnings 'portable'; hex $1 };
851					bless $_[0], $pkg if defined $pkg;
852					$i;
853					}
854					END_PERL
855					}
856	1	0s	1	0s	} # spent 0s making 1 call to CPAN::Meta::YAML::BEGIN@831
857
- -
861	1	0s			1;
862
863					# XXX-INGY Doc notes I'm putting up here. Changing the doc when it's wrong
864					# but leaving grey area stuff up here.
865					#
866					# I would like to change Read/Write to Load/Dump below without
867					# changing the actual API names.
868					#
869					# It might be better to put Load/Dump API in the SYNOPSIS instead of the
870					# dubious OO API.
871					#
872					# null and bool explanations may be outdated.
873
874					=pod
875
876					=encoding UTF-8
877
878					=head1 NAME
879
880					CPAN::Meta::YAML - Read and write a subset of YAML for CPAN Meta files
881
882					=head1 VERSION
883
884					version 0.012
885
886					=head1 SYNOPSIS
887
888					use CPAN::Meta::YAML;
889
890					# reading a META file
891					open $fh, "<:utf8", "META.yml";
892					$yaml_text = do { local $/; <$fh> };
893					$yaml = CPAN::Meta::YAML->read_string($yaml_text)
894					or die CPAN::Meta::YAML->errstr;
895
896					# finding the metadata
897					$meta = $yaml->[0];
898
899					# writing a META file
900					$yaml_text = $yaml->write_string
901					or die CPAN::Meta::YAML->errstr;
902					open $fh, ">:utf8", "META.yml";
903					print $fh $yaml_text;
904
905					=head1 DESCRIPTION
906
907					This module implements a subset of the YAML specification for use in reading
908					and writing CPAN metadata files like F<META.yml> and F<MYMETA.yml>. It should
909					not be used for any other general YAML parsing or generation task.
910
911					NOTE: F<META.yml> (and F<MYMETA.yml>) files should be UTF-8 encoded. Users are
912					responsible for proper encoding and decoding. In particular, the C<read> and
913					C<write> methods do B<not> support UTF-8 and should not be used.
914
915					=head1 SUPPORT
916
917					This module is currently derived from L<YAML::Tiny> by Adam Kennedy. If
918					there are bugs in how it parses a particular META.yml file, please file
919					a bug report in the YAML::Tiny bugtracker:
920					L<https://rt.cpan.org/Public/Dist/Display.html?Name=YAML-Tiny>
921
922					=head1 SEE ALSO
923
924					L<YAML::Tiny>, L<YAML>, L<YAML::XS>
925
926					=for :stopwords cpan testmatrix url annocpan anno bugtracker rt cpants kwalitee diff irc mailto metadata placeholders metacpan
927
928					=head1 SUPPORT
929
930					=head2 Bugs / Feature Requests
931
932					Please report any bugs or feature requests through the issue tracker
933					at L<https://github.com/dagolden/CPAN-Meta-YAML/issues>.
934					You will be notified automatically of any progress on your issue.
935
936					=head2 Source Code
937
938					This is open source software. The code repository is available for
939					public review and contribution under the terms of the license.
940
941					L<https://github.com/dagolden/CPAN-Meta-YAML>
942
943					git clone https://github.com/dagolden/CPAN-Meta-YAML.git
944
945					=head1 AUTHORS
946
947					=over 4
948
949					=item *
950
951					Adam Kennedy <adamk@cpan.org>
952
953					=item *
954
955					David Golden <dagolden@cpan.org>
956
957					=back
958
959					=head1 COPYRIGHT AND LICENSE
960
961					This software is copyright (c) 2010 by Adam Kennedy.
962
963					This is free software; you can redistribute it and/or modify it under
964					the same terms as the Perl 5 programming language system itself.
965
966					=cut
967
968					__END__

					# spent 0s within CPAN::Meta::YAML::CORE:match which was called 468 times, avg 0s/call: # 234 times (0s+0s) by CPAN::Meta::YAML::_dump_scalar at line 684, avg 0s/call # 234 times (0s+0s) by CPAN::Meta::YAML::_dump_scalar at line 675, avg 0s/call sub CPAN::Meta::YAML::CORE:match; # opcode
					# spent 0s within CPAN::Meta::YAML::CORE:qr which was called 5 times, avg 0s/call: # once (0s+0s) by Parse::CPAN::Meta::_can_load at line 153 # once (0s+0s) by Parse::CPAN::Meta::_can_load at line 157 # once (0s+0s) by Parse::CPAN::Meta::_can_load at line 156 # once (0s+0s) by Parse::CPAN::Meta::_can_load at line 154 # once (0s+0s) by Parse::CPAN::Meta::_can_load at line 158 sub CPAN::Meta::YAML::CORE:qr; # opcode
					# spent 0s within CPAN::Meta::YAML::CORE:sort which was called 48 times, avg 0s/call: # 48 times (0s+0s) by CPAN::Meta::YAML::_dump_hash at line 737, avg 0s/call sub CPAN::Meta::YAML::CORE:sort; # opcode