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__ |