File Coverage

blib/lib/YAML/As/Parsed.pm
Criterion Covered Total %
statement 109 345 31.8
branch 44 202 21.7
condition 6 42 14.2
subroutine 16 36 44.4
pod 0 11 0.0
total 175 636 27.6


line stmt bran cond sub pod time code
1 2     2   119041 use 5.008001; # sane UTF-8 support
  2         16  
2 2     2   10 use strict;
  2         3  
  2         59  
3 2     2   10 use warnings;
  2         4  
  2         120  
4             package YAML::As::Parsed; # git description: v1.72-7-g8682f63
5              
6             our $VERSION = '0.04';
7              
8 2     2   837 use Tie::IxHash;
  2         7623  
  2         116  
9              
10             sub ordered_hash {
11 9     9 0 15 my %hash = ();
12 9         33 tie(%hash, 'Tie::IxHash');
13 9         134 return \%hash;
14             }
15              
16 2     2   13 use Exporter;
  2         3  
  2         269  
17             our @ISA = qw{ Exporter };
18             our @EXPORT = qw{ Load Dump };
19             our @EXPORT_OK = qw{ LoadFile DumpFile freeze thaw };
20              
21              
22             sub Dump {
23 0     0 0 0 return __PACKAGE__->new(@_)->_dump_string;
24             }
25              
26             sub Load {
27 0     0 0 0 my $self = __PACKAGE__->_load_string(@_);
28 0 0       0 if ( wantarray ) {
29 0         0 return @$self;
30             } else {
31             # To match YAML.pm, return the last document
32 0         0 return $self->[-1];
33             }
34             }
35              
36             BEGIN {
37 2     2   7 *freeze = \&Dump;
38 2         1243 *thaw = \&Load;
39             }
40              
41             sub DumpFile {
42 0     0 0 0 my $file = shift;
43 0         0 return __PACKAGE__->new(@_)->_dump_file($file);
44             }
45              
46             sub LoadFile {
47 0     0 0 0 my $file = shift;
48 0         0 my $self = __PACKAGE__->_load_file($file);
49 0 0       0 if ( wantarray ) {
50 0         0 return @$self;
51             } else {
52             # Return only the last document to match YAML.pm,
53 0         0 return $self->[-1];
54             }
55             }
56              
57             sub new {
58 0     0 0 0 my $class = shift;
59 0         0 bless [ @_ ], $class;
60             }
61              
62              
63             sub read_string {
64 3     3 0 3748 my $self = shift;
65 3         11 $self->_load_string(@_);
66             }
67              
68             sub write_string {
69 0     0 0 0 my $self = shift;
70 0         0 $self->_dump_string(@_);
71             }
72              
73             sub read {
74 0     0 0 0 my $self = shift;
75 0         0 $self->_load_file(@_);
76             }
77              
78             sub write {
79 0     0 0 0 my $self = shift;
80 0         0 $self->_dump_file(@_);
81             }
82              
83             my @UNPRINTABLE = qw(
84             0 x01 x02 x03 x04 x05 x06 a
85             b t n v f r x0E x0F
86             x10 x11 x12 x13 x14 x15 x16 x17
87             x18 x19 x1A e x1C x1D x1E x1F
88             );
89              
90             my %UNESCAPES = (
91             0 => "\x00", z => "\x00", N => "\x85",
92             a => "\x07", b => "\x08", t => "\x09",
93             n => "\x0a", v => "\x0b", f => "\x0c",
94             r => "\x0d", e => "\x1b", '\\' => '\\',
95             );
96              
97              
98             my %QUOTE = map { $_ => 1 } qw{
99             null true false
100             };
101              
102             my $re_capture_double_quoted = qr/\"([^\\"]*(?:\\.[^\\"]*)*)\"/;
103             my $re_capture_single_quoted = qr/\'([^\']*(?:\'\'[^\']*)*)\'/;
104             my $re_capture_unquoted_key = qr/([^:]+(?::+\S(?:[^:]*|.*?(?=:)))*)(?=\s*\:(?:\s+|$))/;
105             my $re_trailing_comment = qr/(?:\s+\#.*)?/;
106             my $re_key_value_separator = qr/\s*:(?:\s+(?:\#.*)?|$)/;
107              
108             sub _load_file {
109 0 0   0   0 my $class = ref $_[0] ? ref shift : shift;
110              
111             # Check the file
112 0 0       0 my $file = shift or $class->_error( 'You did not specify a file name' );
113 0 0       0 $class->_error( "File '$file' does not exist" )
114             unless -e $file;
115 0 0       0 $class->_error( "'$file' is a directory, not a file" )
116             unless -f _;
117 0 0       0 $class->_error( "Insufficient permissions to read '$file'" )
118             unless -r _;
119              
120             # Open unbuffered with strict UTF-8 decoding and no translation layers
121 0         0 open( my $fh, "<:unix:encoding(UTF-8)", $file );
122 0 0       0 unless ( $fh ) {
123 0         0 $class->_error("Failed to open file '$file': $!");
124             }
125              
126             # flock if available (or warn if not possible for OS-specific reasons)
127 0 0       0 if ( _can_flock() ) {
128 0 0       0 flock( $fh, Fcntl::LOCK_SH() )
129             or warn "Couldn't lock '$file' for reading: $!";
130             }
131              
132             # slurp the contents
133 0         0 my $contents = eval {
134 2     2   13 use warnings FATAL => 'utf8';
  2         3  
  2         7071  
135 0         0 local $/;
136             <$fh>
137 0         0 };
138 0 0       0 if ( my $err = $@ ) {
139 0         0 $class->_error("Error reading from file '$file': $err");
140             }
141              
142             # close the file (release the lock)
143 0 0       0 unless ( close $fh ) {
144 0         0 $class->_error("Failed to close file '$file': $!");
145             }
146              
147 0         0 $class->_load_string( $contents );
148             }
149              
150             sub _load_string {
151 3 50   3   8 my $class = ref $_[0] ? ref shift : shift;
152 3         6 my $self = bless [], $class;
153 3         4 my $string = $_[0];
154 3         5 eval {
155 3 50       7 unless ( defined $string ) {
156 0         0 die \"Did not provide a string to load";
157             }
158              
159             # Check if Perl has it marked as characters, but it's internally
160             # inconsistent. E.g. maybe latin1 got read on a :utf8 layer
161 3 50 33     9 if ( utf8::is_utf8($string) && ! utf8::valid($string) ) {
162 0         0 die \<<'...';
163             Read an invalid UTF-8 string (maybe mixed UTF-8 and 8-bit character set).
164             Did you decode with lax ":utf8" instead of strict ":encoding(UTF-8)"?
165             ...
166             }
167              
168             # Ensure Unicode character semantics, even for 0x80-0xff
169 3         10 utf8::upgrade($string);
170              
171             # Check for and strip any leading UTF-8 BOM
172 3         8 $string =~ s/^\x{FEFF}//;
173              
174             # Check for some special cases
175 3 50       10 return $self unless length $string;
176              
177             # Split the file into lines
178 3         81 my @lines = grep { ! /^\s*(?:\#.*)?\z/ }
  37         101  
179             split /(?:\015{1,2}\012|\015|\012)/, $string;
180              
181             # Strip the initial YAML header
182 3 50 33     16 @lines and $lines[0] =~ /^\%YAML[: ][\d\.]+.*\z/ and shift @lines;
183              
184             # A nibbling parser
185 3         5 my $in_document = 0;
186 3         8 while ( @lines ) {
187             # Do we have a document header?
188 3 50       12 if ( $lines[0] =~ /^---\s*(?:(.+)\s*)?\z/ ) {
189             # Handle scalar documents
190 3         4 shift @lines;
191 3 50 33     10 if ( defined $1 and $1 !~ /^(?:\#.+|\%YAML[: ][\d\.]+)\z/ ) {
192 0         0 push @$self,
193             $self->_load_scalar( "$1", [ undef ], \@lines );
194 0         0 next;
195             }
196 3         5 $in_document = 1;
197             }
198              
199 3 50 33     26 if ( ! @lines or $lines[0] =~ /^(?:---|\.\.\.)/ ) {
    50 33        
    100          
    50          
200             # A naked document
201 0         0 push @$self, undef;
202 0   0     0 while ( @lines and $lines[0] !~ /^---/ ) {
203 0         0 shift @lines;
204             }
205 0         0 $in_document = 0;
206              
207             # XXX The final '-+$' is to look for -- which ends up being an
208             # error later.
209             } elsif ( ! $in_document && @$self ) {
210             # only the first document can be explicit
211 0         0 die \"YAML::As::Parsed failed to classify the line '$lines[0]'";
212             } elsif ( $lines[0] =~ /^\s*\-(?:\s|$|-+$)/ ) {
213             # An array at the root
214 2         5 my $document = [ ];
215 2         3 push @$self, $document;
216 2         8 $self->_load_array( $document, [ 0 ], \@lines );
217              
218             } elsif ( $lines[0] =~ /^(\s*)\S/ ) {
219             # A hash at the root
220 1         3 my $document = ordered_hash;
221 1         6 push @$self, $document;
222 1         17 $self->_load_hash( $document, [ length($1) ], \@lines );
223              
224             } else {
225             # Shouldn't get here. @lines have whitespace-only lines
226             # stripped, and previous match is a line with any
227             # non-whitespace. So this clause should only be reachable via
228             # a perlbug where \s is not symmetric with \S
229              
230             # uncoverable statement
231 0         0 die \"YAML::As::Parsed failed to classify the line '$lines[0]'";
232             }
233             }
234             };
235 3         5 my $err = $@;
236 3 50       8 if ( ref $err eq 'SCALAR' ) {
    50          
237 0         0 $self->_error(${$err});
  0         0  
238             } elsif ( $err ) {
239 0         0 $self->_error($err);
240             }
241              
242 3         23 return $self;
243             }
244              
245             sub _unquote_single {
246 0     0   0 my ($self, $string) = @_;
247 0 0       0 return '' unless length $string;
248 0         0 $string =~ s/\'\'/\'/g;
249 0         0 return $string;
250             }
251              
252             sub _unquote_double {
253 0     0   0 my ($self, $string) = @_;
254 0 0       0 return '' unless length $string;
255 0         0 $string =~ s/\\"/"/g;
256 0         0 $string =~
257 0 0       0 s{\\([Nnever\\fartz0b]|x([0-9a-fA-F]{2}))}
258 0         0 {(length($1)>1)?pack("H2",$2):$UNESCAPES{$1}}gex;
259             return $string;
260             }
261              
262 30     30   52 sub _load_scalar {
263             my ($self, $string, $indent, $lines) = @_;
264              
265 30         93 # Trim trailing whitespace
266             $string =~ s/\s*\z//;
267              
268 30 100       73 # Explitic null/undef
269             return undef if $string eq '~';
270              
271 23 50       83 # Single quote
272 0         0 if ( $string =~ /^$re_capture_single_quoted$re_trailing_comment\z/ ) {
273             return $self->_unquote_single($1);
274             }
275              
276 23 50       82 # Double quote.
277 0         0 if ( $string =~ /^$re_capture_double_quoted$re_trailing_comment\z/ ) {
278             return $self->_unquote_double($1);
279             }
280              
281 23 50       44 # Special cases
282 0         0 if ( $string =~ /^[\'\"!&]/ ) {
283             die \"YAML::As::Parsed does not support a feature in line '$string'";
284 23 50       46 }
285 23 50       36 return {} if $string =~ /^{}(?:\s+\#.*)?\z/;
286             return [] if $string =~ /^\[\](?:\s+\#.*)?\z/;
287              
288 23 50       44 # Regular unquoted string
289 23 50 33     83 if ( $string !~ /^[>|]/ ) {
290             die \"YAML::As::Parsed found illegal characters in plain scalar: '$string'"
291             if $string =~ /^(?:-(?:\s|$)|[\@\%\`])/ or
292 23         32 $string =~ /:(?:\s|$)/;
293 23         100 $string =~ s/\s+#.*\z//;
294             return $string;
295             }
296              
297 0 0       0 # Error
298             die \"YAML::As::Parsed failed to find multi-line scalar content" unless @$lines;
299              
300 0         0 # Check the indent depth
301 0         0 $lines->[0] =~ /^(\s*)/;
302 0 0 0     0 $indent->[-1] = length("$1");
303 0         0 if ( defined $indent->[-2] and $indent->[-1] <= $indent->[-2] ) {
304             die \"YAML::As::Parsed found bad indenting in line '$lines->[0]'";
305             }
306              
307 0         0 # Pull the lines
308 0         0 my @multiline = ();
309 0         0 while ( @$lines ) {
310 0 0       0 $lines->[0] =~ /^(\s*)/;
311 0         0 last unless length($1) >= $indent->[-1];
312             push @multiline, substr(shift(@$lines), $indent->[-1]);
313             }
314 0 0       0  
315 0 0       0 my $j = (substr($string, 0, 1) eq '>') ? ' ' : "\n";
316 0         0 my $t = (substr($string, 1, 1) eq '-') ? '' : "\n";
317             return join( $j, @multiline ) . $t;
318             }
319              
320 4     4   11 sub _load_array {
321             my ($self, $array, $indent, $lines) = @_;
322 4         19  
323             while ( @$lines ) {
324 8 50       19 # Check for a new document
325 0   0     0 if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
326 0         0 while ( @$lines and $lines->[0] !~ /^---/ ) {
327             shift @$lines;
328 0         0 }
329             return 1;
330             }
331              
332 8         15 # Check the indent level
333 8 100       22 $lines->[0] =~ /^(\s*)/;
    50          
334 2         7 if ( length($1) < $indent->[-1] ) {
335             return 1;
336 0         0 } elsif ( length($1) > $indent->[-1] ) {
337             die \"YAML::As::Parsed found bad indenting in line '$lines->[0]'";
338             }
339 6 50 0     23  
    0          
    0          
    0          
340             if ( $lines->[0] =~ /^(\s*\-\s+)[^\'\"]\S*\s*:(?:\s+|$)/ ) {
341 6         15 # Inline nested hash
342 6         19 my $indent2 = length("$1");
343 6         14 $lines->[0] =~ s/-/ /;
344 6         33 push @$array, ordered_hash;
345             $self->_load_hash( $array->[-1], [ @$indent, $indent2 ], $lines );
346              
347 0         0 } elsif ( $lines->[0] =~ /^\s*\-\s*\z/ ) {
348 0 0       0 shift @$lines;
349 0         0 unless ( @$lines ) {
350 0         0 push @$array, undef;
351             return 1;
352 0 0       0 }
    0          
353 0         0 if ( $lines->[0] =~ /^(\s*)\-/ ) {
354 0 0       0 my $indent2 = length("$1");
355             if ( $indent->[-1] == $indent2 ) {
356 0         0 # Null array entry
357             push @$array, undef;
358             } else {
359 0         0 # Naked indenter
360 0         0 push @$array, [ ];
361             $self->_load_array(
362             $array->[-1], [ @$indent, $indent2 ], $lines
363             );
364             }
365              
366 0         0 } elsif ( $lines->[0] =~ /^(\s*)\S/ ) {
367 0         0 push @$array, ordered_hash;
368             $self->_load_hash(
369             $array->[-1], [ @$indent, length("$1") ], $lines
370             );
371              
372 0         0 } else {
373             die \"YAML::As::Parsed failed to classify line '$lines->[0]'";
374             }
375              
376             } elsif ( $lines->[0] =~ /^\s*\-(\s*)(.+?)\s*\z/ ) {
377 0         0 # Array entry with a value
378 0         0 shift @$lines;
379             push @$array, $self->_load_scalar(
380             "$2", [ @$indent, undef ], $lines
381             );
382              
383             } elsif ( defined $indent->[-2] and $indent->[-1] == $indent->[-2] ) {
384             # This is probably a structure like the following...
385             # ---
386             # foo:
387             # - list
388             # bar: value
389             #
390 0         0 # ... so lets return and let the hash parser handle it
391             return 1;
392              
393 0         0 } else {
394             die \"YAML::As::Parsed failed to classify line '$lines->[0]'";
395             }
396             }
397 2         6  
398             return 1;
399             }
400              
401 9     9   21 sub _load_hash {
402             my ($self, $hash, $indent, $lines) = @_;
403 9         24  
404             while ( @$lines ) {
405 38 50       457 # Check for a new document
406 0   0     0 if ( $lines->[0] =~ /^(?:---|\.\.\.)/ ) {
407 0         0 while ( @$lines and $lines->[0] !~ /^---/ ) {
408             shift @$lines;
409 0         0 }
410             return 1;
411             }
412              
413 38         70 # Check the indent level
414 38 100       107 $lines->[0] =~ /^(\s*)/;
    50          
415 4         9 if ( length($1) < $indent->[-1] ) {
416             return 1;
417 0         0 } elsif ( length($1) > $indent->[-1] ) {
418             die \"YAML::As::Parsed found bad indenting in line '$lines->[0]'";
419             }
420              
421 34         36 # Find the key
422             my $key;
423              
424 34 50       429 # Quoted keys
    50          
    50          
    0          
425             if ( $lines->[0] =~
426             s/^\s*$re_capture_single_quoted$re_key_value_separator//
427 0         0 ) {
428             $key = $self->_unquote_single($1);
429             }
430             elsif ( $lines->[0] =~
431             s/^\s*$re_capture_double_quoted$re_key_value_separator//
432 0         0 ) {
433             $key = $self->_unquote_double($1);
434             }
435             elsif ( $lines->[0] =~
436             s/^\s*$re_capture_unquoted_key$re_key_value_separator//
437 34         62 ) {
438 34         60 $key = $1;
439             $key =~ s/\s+$//;
440             }
441 0         0 elsif ( $lines->[0] =~ /^\s*\?/ ) {
442             die \"YAML::As::Parsed does not support a feature in line '$lines->[0]'";
443             }
444 0         0 else {
445             die \"YAML::As::Parsed failed to classify line '$lines->[0]'";
446             }
447 34 50       113  
448 0         0 if ( exists $hash->{$key} ) {
449             warn "YAML::As::Parsed found a duplicate key '$key' in line '$lines->[0]'";
450             }
451              
452 34 100       179 # Do we have a value?
453             if ( length $lines->[0] ) {
454 30         68 # Yes
455             $hash->{$key} = $self->_load_scalar(
456             shift(@$lines), [ @$indent, undef ], $lines
457             );
458             } else {
459 4         6 # An indent
460 4 50       10 shift @$lines;
461 0         0 unless ( @$lines ) {
462 0         0 $hash->{$key} = undef;
463             return 1;
464 4 100       16 }
    50          
465 2         7 if ( $lines->[0] =~ /^(\s*)-/ ) {
466             $hash->{$key} = [];
467 2         48 $self->_load_array(
468             $hash->{$key}, [ @$indent, length($1) ], $lines
469             );
470 2         5 } elsif ( $lines->[0] =~ /^(\s*)./ ) {
471 2 50       5 my $indent2 = length("$1");
472             if ( $indent->[-1] >= $indent2 ) {
473 0         0 # Null hash entry
474             $hash->{$key} = undef;
475 2         14 } else {
476             $hash->{$key} = ordered_hash;
477 2         32 $self->_load_hash(
478             $hash->{$key}, [ @$indent, length($1) ], $lines
479             );
480             }
481             }
482             }
483             }
484 5         53  
485             return 1;
486             }
487              
488              
489              
490 0     0     sub _dump_file {
491             my $self = shift;
492 0            
493             require Fcntl;
494              
495 0 0         # Check the file
496             my $file = shift or $self->_error( 'You did not specify a file name' );
497 0            
498             my $fh;
499 0 0         # flock if available (or warn if not possible for OS-specific reasons)
500             if ( _can_flock() ) {
501 0           # Open without truncation (truncate comes after lock)
502 0 0         my $flags = Fcntl::O_WRONLY()|Fcntl::O_CREAT();
503             sysopen( $fh, $file, $flags )
504             or $self->_error("Failed to open file '$file' for writing: $!");
505              
506 0           # Use no translation and strict UTF-8
507             binmode( $fh, ":raw:encoding(UTF-8)");
508 0 0          
509             flock( $fh, Fcntl::LOCK_EX() )
510             or warn "Couldn't lock '$file' for reading: $!";
511              
512 0           # truncate and spew contents
513 0           truncate $fh, 0;
514             seek $fh, 0, 0;
515             }
516 0           else {
517             open $fh, ">:unix:encoding(UTF-8)", $file;
518             }
519              
520 0           # serialize and spew to the handle
  0            
521             print {$fh} $self->_dump_string;
522              
523 0 0         # close the file (release the lock)
524 0           unless ( close $fh ) {
525             $self->_error("Failed to close file '$file': $!");
526             }
527 0            
528             return 1;
529             }
530              
531 0     0     sub _dump_string {
532 0 0 0       my $self = shift;
533             return '' unless ref $self && @$self;
534              
535 0           # Iterate over the documents
536 0           my $indent = 0;
537             my @lines = ();
538 0            
539 0           eval {
540 0           foreach my $cursor ( @$self ) {
541             push @lines, '---';
542              
543 0 0         # An empty document
    0          
    0          
    0          
544             if ( ! defined $cursor ) {
545             # Do nothing
546              
547             # A scalar document
548 0           } elsif ( ! ref $cursor ) {
549             $lines[-1] .= ' ' . $self->_dump_scalar( $cursor );
550              
551             # A list at the root
552 0 0         } elsif ( ref $cursor eq 'ARRAY' ) {
553 0           unless ( @$cursor ) {
554 0           $lines[-1] .= ' []';
555             next;
556 0           }
557             push @lines, $self->_dump_array( $cursor, $indent, {} );
558              
559             # A hash at the root
560 0 0         } elsif ( ref $cursor eq 'HASH' ) {
561 0           unless ( %$cursor ) {
562 0           $lines[-1] .= ' {}';
563             next;
564 0           }
565             push @lines, $self->_dump_hash( $cursor, $indent, {} );
566              
567 0           } else {
568             die \("Cannot serialize " . ref($cursor));
569             }
570             }
571 0 0         };
    0          
572 0           if ( ref $@ eq 'SCALAR' ) {
  0            
573             $self->_error(${$@});
574 0           } elsif ( $@ ) {
575             $self->_error($@);
576             }
577 0            
  0            
578             join '', map { "$_\n" } @lines;
579             }
580              
581 0     0     sub _has_internal_string_value {
582 0           my $value = shift;
583 0           my $b_obj = B::svref_2object(\$value); # for round trip problem
584             return $b_obj->FLAGS & B::SVf_POK();
585             }
586              
587 0     0     sub _dump_scalar {
588 0           my $string = $_[1];
589             my $is_key = $_[2];
590 0           # Check this before checking length or it winds up looking like a string!
591 0 0         my $has_string_flag = _has_internal_string_value($string);
592 0 0         return '~' unless defined $string;
593 0 0         return "''" unless length $string;
594             if (Scalar::Util::looks_like_number($string)) {
595 0 0 0       # keys and values that have been used as strings get quoted
596 0           if ( $is_key || $has_string_flag ) {
597             return qq['$string'];
598             }
599 0           else {
600             return $string;
601             }
602 0 0         }
603 0           if ( $string =~ /[\x00-\x09\x0b-\x0d\x0e-\x1f\x7f-\x9f\'\n]/ ) {
604 0           $string =~ s/\\/\\\\/g;
605 0           $string =~ s/"/\\"/g;
606 0           $string =~ s/\n/\\n/g;
607 0           $string =~ s/[\x85]/\\N/g;
608 0           $string =~ s/([\x00-\x1f])/\\$UNPRINTABLE[ord($1)]/g;
  0            
609 0           $string =~ s/([\x7f-\x9f])/'\x' . sprintf("%X",ord($1))/ge;
610             return qq|"$string"|;
611 0 0 0       }
612             if ( $string =~ /(?:^[~!@#%&*|>?:,'"`{}\[\]]|^-+$|\s|:\z)/ or
613             $QUOTE{$string}
614 0           ) {
615             return "'$string'";
616 0           }
617             return $string;
618             }
619              
620 0     0     sub _dump_array {
621 0 0         my ($self, $array, $indent, $seen) = @_;
622 0           if ( $seen->{refaddr($array)}++ ) {
623             die \"YAML::As::Parsed does not support circular references";
624 0           }
625 0           my @lines = ();
626 0           foreach my $el ( @$array ) {
627 0           my $line = (' ' x $indent) . '-';
628 0 0         my $type = ref $el;
    0          
    0          
629 0           if ( ! $type ) {
630 0           $line .= ' ' . $self->_dump_scalar( $el );
631             push @lines, $line;
632              
633 0 0         } elsif ( $type eq 'ARRAY' ) {
634 0           if ( @$el ) {
635 0           push @lines, $line;
636             push @lines, $self->_dump_array( $el, $indent + 1, $seen );
637 0           } else {
638 0           $line .= ' []';
639             push @lines, $line;
640             }
641              
642 0 0         } elsif ( $type eq 'HASH' ) {
643 0           if ( keys %$el ) {
644 0           push @lines, $line;
645             push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
646 0           } else {
647 0           $line .= ' {}';
648             push @lines, $line;
649             }
650              
651 0           } else {
652             die \"YAML::As::Parsed does not support $type references";
653             }
654             }
655 0            
656             @lines;
657             }
658              
659 0     0     sub _dump_hash {
660 0 0         my ($self, $hash, $indent, $seen) = @_;
661 0           if ( $seen->{refaddr($hash)}++ ) {
662             die \"YAML::As::Parsed does not support circular references";
663 0           }
664 0           my @lines = ();
665 0           foreach my $name ( sort keys %$hash ) {
666 0           my $el = $hash->{$name};
667 0           my $line = (' ' x $indent) . $self->_dump_scalar($name, 1) . ":";
668 0 0         my $type = ref $el;
    0          
    0          
669 0           if ( ! $type ) {
670 0           $line .= ' ' . $self->_dump_scalar( $el );
671             push @lines, $line;
672              
673 0 0         } elsif ( $type eq 'ARRAY' ) {
674 0           if ( @$el ) {
675 0           push @lines, $line;
676             push @lines, $self->_dump_array( $el, $indent + 1, $seen );
677 0           } else {
678 0           $line .= ' []';
679             push @lines, $line;
680             }
681              
682 0 0         } elsif ( $type eq 'HASH' ) {
683 0           if ( keys %$el ) {
684 0           push @lines, $line;
685             push @lines, $self->_dump_hash( $el, $indent + 1, $seen );
686 0           } else {
687 0           $line .= ' {}';
688             push @lines, $line;
689             }
690              
691 0           } else {
692             die \"YAML::As::Parsed does not support $type references";
693             }
694             }
695 0            
696             @lines;
697             }
698              
699             our $errstr = '';
700              
701 0     0     sub _error {
702 0           require Carp;
703 0           $errstr = $_[1];
704 0           $errstr =~ s/ at \S+ line \d+.*//;
705             Carp::croak( $errstr );
706             }
707              
708             my $errstr_warned;
709 0     0 0   sub errstr {
710 0 0         require Carp;
711             Carp::carp( "YAML::As::Parsed->errstr and \$YAML::As::Parsed::errstr is deprecated" )
712 0           unless $errstr_warned++;
713             $errstr;
714             }
715 2     2   14  
  2         4  
  2         272  
716             use B;
717              
718             my $HAS_FLOCK;
719 0 0   0     sub _can_flock {
720 0           if ( defined $HAS_FLOCK ) {
721             return $HAS_FLOCK;
722             }
723 0           else {
724 0           require Config;
725 0           my $c = \%Config::Config;
  0            
726 0 0         $HAS_FLOCK = grep { $c->{$_} } qw/d_flock d_fcntl_can_lock d_lockf/;
727 0           require Fcntl if $HAS_FLOCK;
728             return $HAS_FLOCK;
729             }
730             }
731 2     2   13  
  2         4  
  2         109  
732             use Scalar::Util ();
733 2     2   7 BEGIN {
734 2 50       17 local $@;
  2         71  
735 2         123 if ( eval { Scalar::Util->VERSION(1.18); } ) {
736             *refaddr = *Scalar::Util::refaddr;
737             }
738 0         0 else {
739             eval <<'END_PERL';
740             sub refaddr {
741             my $pkg = ref($_[0]) or return undef;
742             if ( !! UNIVERSAL::can($_[0], 'can') ) {
743             bless $_[0], 'Scalar::Util::Fake';
744             } else {
745             $pkg = undef;
746             }
747             "$_[0]" =~ /0x(\w+)/;
748             my $i = do { no warnings 'portable'; hex $1 };
749             bless $_[0], $pkg if defined $pkg;
750             $i;
751             }
752             END_PERL
753             }
754             }
755              
756             delete $YAML::As::Parsed::{refaddr};
757              
758             1;
759              
760             __END__