line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
5
|
|
|
5
|
|
1502
|
use strict; |
|
5
|
|
|
|
|
176
|
|
|
5
|
|
|
|
|
170
|
|
2
|
5
|
|
|
5
|
|
163
|
use warnings; |
|
5
|
|
|
|
|
13
|
|
|
5
|
|
|
|
|
317
|
|
3
|
|
|
|
|
|
|
package YAML::PP::Schema::Perl; |
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
our $VERSION = '0.036'; # VERSION |
6
|
|
|
|
|
|
|
|
7
|
5
|
|
|
5
|
|
31
|
use Scalar::Util qw/ blessed reftype /; |
|
5
|
|
|
|
|
15
|
|
|
5
|
|
|
|
|
16826
|
|
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
my $qr_prefix; |
10
|
|
|
|
|
|
|
# workaround to avoid growing regexes when repeatedly loading and dumping |
11
|
|
|
|
|
|
|
# e.g. (?^:(?^:regex)) |
12
|
|
|
|
|
|
|
{ |
13
|
|
|
|
|
|
|
$qr_prefix = qr{\(\?-xism\:}; |
14
|
|
|
|
|
|
|
if ($] >= 5.014) { |
15
|
|
|
|
|
|
|
$qr_prefix = qr{\(\?\^(?:[uadl])?\:}; |
16
|
|
|
|
|
|
|
} |
17
|
|
|
|
|
|
|
} |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
sub new { |
20
|
6
|
|
|
6
|
1
|
15161
|
my ($class, %args) = @_; |
21
|
6
|
|
50
|
|
|
36
|
my $tags = $args{tags} || []; |
22
|
6
|
|
100
|
|
|
30
|
my $loadcode = $args{loadcode} || 0; |
23
|
6
|
|
|
|
|
12
|
my $dumpcode = $args{dumpcode}; |
24
|
6
|
50
|
|
|
|
19
|
$dumpcode = 1 unless defined $dumpcode; |
25
|
6
|
|
|
|
|
13
|
my $classes = $args{classes}; |
26
|
|
|
|
|
|
|
|
27
|
6
|
|
|
|
|
33
|
my $self = bless { |
28
|
|
|
|
|
|
|
tags => $tags, |
29
|
|
|
|
|
|
|
loadcode => $loadcode, |
30
|
|
|
|
|
|
|
dumpcode => $dumpcode, |
31
|
|
|
|
|
|
|
classes => $classes, |
32
|
|
|
|
|
|
|
}, $class; |
33
|
|
|
|
|
|
|
} |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
sub register { |
36
|
24
|
|
|
24
|
1
|
86
|
my ($self, %args) = @_; |
37
|
24
|
|
|
|
|
53
|
my $schema = $args{schema}; |
38
|
|
|
|
|
|
|
|
39
|
24
|
|
|
|
|
36
|
my $tags; |
40
|
24
|
|
|
|
|
43
|
my $loadcode = 0; |
41
|
24
|
|
|
|
|
35
|
my $dumpcode = 1; |
42
|
24
|
|
|
|
|
38
|
my $classes; |
43
|
24
|
100
|
|
|
|
88
|
if (blessed($self)) { |
44
|
6
|
|
|
|
|
15
|
$tags = $self->{tags}; |
45
|
6
|
50
|
|
|
|
33
|
@$tags = ('!perl') unless @$tags; |
46
|
6
|
|
|
|
|
21
|
$loadcode = $self->{loadcode}; |
47
|
6
|
|
|
|
|
17
|
$dumpcode = $self->{dumpcode}; |
48
|
6
|
|
|
|
|
22
|
$classes = $self->{classes}; |
49
|
|
|
|
|
|
|
} |
50
|
|
|
|
|
|
|
else { |
51
|
18
|
|
|
|
|
46
|
my $options = $args{options}; |
52
|
18
|
|
|
|
|
52
|
my $tagtype = '!perl'; |
53
|
18
|
|
|
|
|
46
|
for my $option (@$options) { |
54
|
12
|
100
|
|
|
|
47
|
if ($option =~ m/^tags?=(.+)$/) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
55
|
7
|
|
|
|
|
22
|
$tagtype = $1; |
56
|
|
|
|
|
|
|
} |
57
|
|
|
|
|
|
|
elsif ($option eq '+loadcode') { |
58
|
4
|
|
|
|
|
8
|
$loadcode = 1; |
59
|
|
|
|
|
|
|
} |
60
|
|
|
|
|
|
|
elsif ($option eq '-dumpcode') { |
61
|
1
|
|
|
|
|
2
|
$dumpcode = 0; |
62
|
|
|
|
|
|
|
} |
63
|
|
|
|
|
|
|
} |
64
|
18
|
|
|
|
|
61
|
$tags = [split m/\+/, $tagtype]; |
65
|
|
|
|
|
|
|
} |
66
|
|
|
|
|
|
|
|
67
|
|
|
|
|
|
|
|
68
|
24
|
|
|
|
|
76
|
my $perl_tag; |
69
|
|
|
|
|
|
|
my %tagtypes; |
70
|
24
|
|
|
|
|
0
|
my @perl_tags; |
71
|
24
|
|
|
|
|
51
|
for my $type (@$tags) { |
72
|
28
|
100
|
|
|
|
76
|
if ($type eq '!perl') { |
|
|
50
|
|
|
|
|
|
73
|
22
|
|
66
|
|
|
116
|
$perl_tag ||= $type; |
74
|
22
|
|
|
|
|
47
|
push @perl_tags, '!perl'; |
75
|
|
|
|
|
|
|
} |
76
|
|
|
|
|
|
|
elsif ($type eq '!!perl') { |
77
|
6
|
|
100
|
|
|
22
|
$perl_tag ||= 'tag:yaml.org,2002:perl'; |
78
|
6
|
|
|
|
|
10
|
push @perl_tags, 'tag:yaml.org,2002:perl'; |
79
|
|
|
|
|
|
|
} |
80
|
|
|
|
|
|
|
else { |
81
|
0
|
|
|
|
|
0
|
die "Invalid tagtype '$type'"; |
82
|
|
|
|
|
|
|
} |
83
|
28
|
|
|
|
|
67
|
$tagtypes{ $type } = 1; |
84
|
|
|
|
|
|
|
} |
85
|
|
|
|
|
|
|
|
86
|
24
|
|
|
|
|
44
|
my $perl_regex = '!perl'; |
87
|
24
|
100
|
100
|
|
|
148
|
if ($tagtypes{'!perl'} and $tagtypes{'!!perl'}) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
88
|
4
|
|
|
|
|
6
|
$perl_regex = '(?:tag:yaml\\.org,2002:|!)perl'; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
elsif ($tagtypes{'!perl'}) { |
91
|
18
|
|
|
|
|
39
|
$perl_regex = '!perl'; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
elsif ($tagtypes{'!!perl'}) { |
94
|
2
|
|
|
|
|
2
|
$perl_regex = 'tag:yaml\\.org,2002:perl'; |
95
|
|
|
|
|
|
|
} |
96
|
|
|
|
|
|
|
|
97
|
24
|
|
|
|
|
73
|
my $class_regex = qr{.+}; |
98
|
24
|
|
|
|
|
46
|
my $no_objects = 0; |
99
|
24
|
100
|
|
|
|
56
|
if ($classes) { |
100
|
5
|
100
|
|
|
|
13
|
if (@$classes) { |
101
|
1
|
|
|
|
|
7
|
$class_regex = '(' . join( '|', map "\Q$_\E", @$classes ) . ')'; |
102
|
|
|
|
|
|
|
} |
103
|
|
|
|
|
|
|
else { |
104
|
4
|
|
|
|
|
8
|
$no_objects = 1; |
105
|
4
|
|
|
|
|
8
|
$class_regex = ''; |
106
|
|
|
|
|
|
|
} |
107
|
|
|
|
|
|
|
} |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
|
|
|
# Code |
110
|
24
|
100
|
|
|
|
56
|
if ($loadcode) { |
111
|
|
|
|
|
|
|
my $load_code = sub { |
112
|
6
|
|
|
6
|
|
28
|
my ($constructor, $event) = @_; |
113
|
6
|
|
|
|
|
35
|
return $self->evaluate_code($event->{value}); |
114
|
5
|
|
|
|
|
29
|
}; |
115
|
|
|
|
|
|
|
my $load_code_blessed = sub { |
116
|
6
|
|
|
6
|
|
16
|
my ($constructor, $event) = @_; |
117
|
6
|
|
|
|
|
16
|
my $class = $event->{tag}; |
118
|
6
|
|
|
|
|
117
|
$class =~ s{^$perl_regex/code:}{}; |
119
|
6
|
|
|
|
|
37
|
my $sub = $self->evaluate_code($event->{value}); |
120
|
4
|
|
|
|
|
33
|
return $self->object($sub, $class); |
121
|
5
|
|
|
|
|
18
|
}; |
122
|
|
|
|
|
|
|
$schema->add_resolver( |
123
|
|
|
|
|
|
|
tag => "$_/code", |
124
|
|
|
|
|
|
|
match => [ all => $load_code], |
125
|
|
|
|
|
|
|
implicit => 0, |
126
|
5
|
|
|
|
|
24
|
) for @perl_tags; |
127
|
5
|
|
|
|
|
114
|
$schema->add_resolver( |
128
|
|
|
|
|
|
|
tag => qr{^$perl_regex/code:$class_regex$}, |
129
|
|
|
|
|
|
|
match => [ all => $load_code_blessed ], |
130
|
|
|
|
|
|
|
implicit => 0, |
131
|
|
|
|
|
|
|
); |
132
|
5
|
100
|
|
|
|
27
|
$schema->add_resolver( |
133
|
|
|
|
|
|
|
tag => qr{^$perl_regex/code:.+}, |
134
|
|
|
|
|
|
|
match => [ all => $load_code ], |
135
|
|
|
|
|
|
|
implicit => 0, |
136
|
|
|
|
|
|
|
) if $no_objects; |
137
|
|
|
|
|
|
|
} |
138
|
|
|
|
|
|
|
else { |
139
|
19
|
|
|
2
|
|
93
|
my $loadcode_dummy = sub { return sub {} }; |
|
2
|
|
|
|
|
20
|
|
140
|
|
|
|
|
|
|
my $loadcode_blessed_dummy = sub { |
141
|
2
|
|
|
2
|
|
17
|
my ($constructor, $event) = @_; |
142
|
2
|
|
|
|
|
5
|
my $class = $event->{tag}; |
143
|
2
|
|
|
|
|
20
|
$class =~ s{^$perl_regex/code:}{}; |
144
|
2
|
|
|
|
|
17
|
return $self->object(sub {}, $class); |
145
|
19
|
|
|
|
|
94
|
}; |
146
|
|
|
|
|
|
|
$schema->add_resolver( |
147
|
|
|
|
|
|
|
tag => "$_/code", |
148
|
|
|
|
|
|
|
match => [ all => $loadcode_dummy ], |
149
|
|
|
|
|
|
|
implicit => 0, |
150
|
19
|
|
|
|
|
123
|
) for @perl_tags; |
151
|
19
|
|
|
|
|
445
|
$schema->add_resolver( |
152
|
|
|
|
|
|
|
tag => qr{^$perl_regex/code:$class_regex$}, |
153
|
|
|
|
|
|
|
match => [ all => $loadcode_blessed_dummy ], |
154
|
|
|
|
|
|
|
implicit => 0, |
155
|
|
|
|
|
|
|
); |
156
|
19
|
100
|
|
|
|
135
|
$schema->add_resolver( |
157
|
|
|
|
|
|
|
tag => qr{^$perl_regex/code:.+}, |
158
|
|
|
|
|
|
|
match => [ all => $loadcode_dummy ], |
159
|
|
|
|
|
|
|
implicit => 0, |
160
|
|
|
|
|
|
|
) if $no_objects; |
161
|
|
|
|
|
|
|
} |
162
|
|
|
|
|
|
|
|
163
|
|
|
|
|
|
|
# Glob |
164
|
|
|
|
|
|
|
my $load_glob = sub { |
165
|
8
|
|
|
8
|
|
15
|
my $value = undef; |
166
|
8
|
|
|
|
|
19
|
return \$value; |
167
|
24
|
|
|
|
|
99
|
}; |
168
|
|
|
|
|
|
|
my $load_glob_blessed = sub { |
169
|
2
|
|
|
2
|
|
4
|
my ($constructor, $event) = @_; |
170
|
2
|
|
|
|
|
4
|
my $class = $event->{tag}; |
171
|
2
|
|
|
|
|
16
|
$class =~ s{^$perl_regex/glob:}{}; |
172
|
2
|
|
|
|
|
4
|
my $value = undef; |
173
|
2
|
|
|
|
|
6
|
return $self->object(\$value, $class); |
174
|
24
|
|
|
|
|
133
|
}; |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
$schema->add_mapping_resolver( |
177
|
|
|
|
|
|
|
tag => "$_/glob", |
178
|
|
|
|
|
|
|
on_create => $load_glob, |
179
|
|
|
|
|
|
|
on_data => sub { |
180
|
6
|
|
|
6
|
|
19
|
my ($constructor, $ref, $list) = @_; |
181
|
6
|
|
|
|
|
14
|
$$ref = $self->construct_glob($list); |
182
|
|
|
|
|
|
|
}, |
183
|
24
|
|
|
|
|
193
|
) for @perl_tags; |
184
|
24
|
100
|
|
|
|
67
|
if ($no_objects) { |
185
|
|
|
|
|
|
|
$schema->add_mapping_resolver( |
186
|
|
|
|
|
|
|
tag => qr{^$perl_regex/glob:.+$}, |
187
|
|
|
|
|
|
|
on_create => $load_glob, |
188
|
|
|
|
|
|
|
on_data => sub { |
189
|
2
|
|
|
2
|
|
6
|
my ($constructor, $ref, $list) = @_; |
190
|
2
|
|
|
|
|
7
|
$$ref = $self->construct_glob($list); |
191
|
|
|
|
|
|
|
}, |
192
|
4
|
|
|
|
|
73
|
); |
193
|
|
|
|
|
|
|
} |
194
|
|
|
|
|
|
|
else { |
195
|
|
|
|
|
|
|
$schema->add_mapping_resolver( |
196
|
|
|
|
|
|
|
tag => qr{^$perl_regex/glob:$class_regex$}, |
197
|
|
|
|
|
|
|
on_create => $load_glob_blessed, |
198
|
|
|
|
|
|
|
on_data => sub { |
199
|
2
|
|
|
2
|
|
5
|
my ($constructor, $ref, $list) = @_; |
200
|
2
|
|
|
|
|
6
|
$$$ref = $self->construct_glob($list); |
201
|
|
|
|
|
|
|
}, |
202
|
20
|
|
|
|
|
345
|
); |
203
|
|
|
|
|
|
|
} |
204
|
|
|
|
|
|
|
|
205
|
|
|
|
|
|
|
# Regex |
206
|
|
|
|
|
|
|
my $load_regex = sub { |
207
|
5
|
|
|
5
|
|
14
|
my ($constructor, $event) = @_; |
208
|
5
|
|
|
|
|
22
|
return $self->construct_regex($event->{value}); |
209
|
24
|
|
|
|
|
127
|
}; |
210
|
|
|
|
|
|
|
my $load_regex_blessed = sub { |
211
|
6
|
|
|
6
|
|
23
|
my ($constructor, $event) = @_; |
212
|
6
|
|
|
|
|
14
|
my $class = $event->{tag}; |
213
|
6
|
|
|
|
|
99
|
$class =~ s{^$perl_regex/regexp:}{}; |
214
|
6
|
|
|
|
|
34
|
my $qr = $self->construct_regex($event->{value}); |
215
|
6
|
|
|
|
|
28
|
return $self->object($qr, $class); |
216
|
24
|
|
|
|
|
100
|
}; |
217
|
|
|
|
|
|
|
$schema->add_resolver( |
218
|
|
|
|
|
|
|
tag => "$_/regexp", |
219
|
|
|
|
|
|
|
match => [ all => $load_regex ], |
220
|
|
|
|
|
|
|
implicit => 0, |
221
|
24
|
|
|
|
|
160
|
) for @perl_tags; |
222
|
24
|
|
|
|
|
386
|
$schema->add_resolver( |
223
|
|
|
|
|
|
|
tag => qr{^$perl_regex/regexp:$class_regex$}, |
224
|
|
|
|
|
|
|
match => [ all => $load_regex_blessed ], |
225
|
|
|
|
|
|
|
implicit => 0, |
226
|
|
|
|
|
|
|
); |
227
|
24
|
100
|
|
|
|
185
|
$schema->add_resolver( |
228
|
|
|
|
|
|
|
tag => qr{^$perl_regex/regexp:$class_regex$}, |
229
|
|
|
|
|
|
|
match => [ all => $load_regex ], |
230
|
|
|
|
|
|
|
implicit => 0, |
231
|
|
|
|
|
|
|
) if $no_objects; |
232
|
|
|
|
|
|
|
|
233
|
24
|
|
|
6
|
|
122
|
my $load_sequence = sub { return [] }; |
|
6
|
|
|
|
|
14
|
|
234
|
|
|
|
|
|
|
my $load_sequence_blessed = sub { |
235
|
13
|
|
|
13
|
|
31
|
my ($constructor, $event) = @_; |
236
|
13
|
|
|
|
|
29
|
my $class = $event->{tag}; |
237
|
13
|
|
|
|
|
128
|
$class =~ s{^$perl_regex/array:}{}; |
238
|
13
|
|
|
|
|
56
|
return $self->object([], $class); |
239
|
24
|
|
|
|
|
157
|
}; |
240
|
|
|
|
|
|
|
$schema->add_sequence_resolver( |
241
|
|
|
|
|
|
|
tag => "$_/array", |
242
|
|
|
|
|
|
|
on_create => $load_sequence, |
243
|
24
|
|
|
|
|
136
|
) for @perl_tags; |
244
|
24
|
|
|
|
|
411
|
$schema->add_sequence_resolver( |
245
|
|
|
|
|
|
|
tag => qr{^$perl_regex/array:$class_regex$}, |
246
|
|
|
|
|
|
|
on_create => $load_sequence_blessed, |
247
|
|
|
|
|
|
|
); |
248
|
24
|
100
|
|
|
|
140
|
$schema->add_sequence_resolver( |
249
|
|
|
|
|
|
|
tag => qr{^$perl_regex/array:.+$}, |
250
|
|
|
|
|
|
|
on_create => $load_sequence, |
251
|
|
|
|
|
|
|
) if $no_objects; |
252
|
|
|
|
|
|
|
|
253
|
24
|
|
|
5
|
|
120
|
my $load_mapping = sub { return {} }; |
|
5
|
|
|
|
|
14
|
|
254
|
|
|
|
|
|
|
my $load_mapping_blessed = sub { |
255
|
7
|
|
|
7
|
|
28
|
my ($constructor, $event) = @_; |
256
|
7
|
|
|
|
|
18
|
my $class = $event->{tag}; |
257
|
7
|
|
|
|
|
152
|
$class =~ s{^$perl_regex/hash:}{}; |
258
|
7
|
|
|
|
|
80
|
return $self->object({}, $class); |
259
|
24
|
|
|
|
|
148
|
}; |
260
|
|
|
|
|
|
|
$schema->add_mapping_resolver( |
261
|
|
|
|
|
|
|
tag => "$_/hash", |
262
|
|
|
|
|
|
|
on_create => $load_mapping, |
263
|
24
|
|
|
|
|
105
|
) for @perl_tags; |
264
|
24
|
|
|
|
|
384
|
$schema->add_mapping_resolver( |
265
|
|
|
|
|
|
|
tag => qr{^$perl_regex/hash:$class_regex$}, |
266
|
|
|
|
|
|
|
on_create => $load_mapping_blessed, |
267
|
|
|
|
|
|
|
); |
268
|
24
|
100
|
|
|
|
152
|
$schema->add_mapping_resolver( |
269
|
|
|
|
|
|
|
tag => qr{^$perl_regex/hash:.+$}, |
270
|
|
|
|
|
|
|
on_create => $load_mapping, |
271
|
|
|
|
|
|
|
) if $no_objects; |
272
|
|
|
|
|
|
|
|
273
|
|
|
|
|
|
|
# Ref |
274
|
|
|
|
|
|
|
my $load_ref = sub { |
275
|
7
|
|
|
7
|
|
15
|
my $value = undef; |
276
|
7
|
|
|
|
|
24
|
return \$value; |
277
|
24
|
|
|
|
|
109
|
}; |
278
|
|
|
|
|
|
|
my $load_ref_blessed = sub { |
279
|
7
|
|
|
7
|
|
20
|
my ($constructor, $event) = @_; |
280
|
7
|
|
|
|
|
17
|
my $class = $event->{tag}; |
281
|
7
|
|
|
|
|
98
|
$class =~ s{^$perl_regex/ref:}{}; |
282
|
7
|
|
|
|
|
20
|
my $value = undef; |
283
|
7
|
|
|
|
|
28
|
return $self->object(\$value, $class); |
284
|
24
|
|
|
|
|
134
|
}; |
285
|
|
|
|
|
|
|
$schema->add_mapping_resolver( |
286
|
|
|
|
|
|
|
tag => "$_/ref", |
287
|
|
|
|
|
|
|
on_create => $load_ref, |
288
|
|
|
|
|
|
|
on_data => sub { |
289
|
6
|
|
|
6
|
|
13
|
my ($constructor, $ref, $list) = @_; |
290
|
6
|
|
|
|
|
24
|
$$$ref = $self->construct_ref($list); |
291
|
|
|
|
|
|
|
}, |
292
|
24
|
|
|
|
|
160
|
) for @perl_tags; |
293
|
|
|
|
|
|
|
$schema->add_mapping_resolver( |
294
|
|
|
|
|
|
|
tag => qr{^$perl_regex/ref:$class_regex$}, |
295
|
|
|
|
|
|
|
on_create => $load_ref_blessed, |
296
|
|
|
|
|
|
|
on_data => sub { |
297
|
7
|
|
|
7
|
|
26
|
my ($constructor, $ref, $list) = @_; |
298
|
7
|
|
|
|
|
26
|
$$$ref = $self->construct_ref($list); |
299
|
|
|
|
|
|
|
}, |
300
|
24
|
|
|
|
|
399
|
); |
301
|
|
|
|
|
|
|
$schema->add_mapping_resolver( |
302
|
|
|
|
|
|
|
tag => qr{^$perl_regex/ref:.+$}, |
303
|
|
|
|
|
|
|
on_create => $load_ref, |
304
|
|
|
|
|
|
|
on_data => sub { |
305
|
1
|
|
|
1
|
|
3
|
my ($constructor, $ref, $list) = @_; |
306
|
1
|
|
|
|
|
4
|
$$$ref = $self->construct_ref($list); |
307
|
|
|
|
|
|
|
}, |
308
|
24
|
100
|
|
|
|
155
|
) if $no_objects; |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
# Scalar ref |
311
|
|
|
|
|
|
|
my $load_scalar_ref = sub { |
312
|
7
|
|
|
7
|
|
22
|
my $value = undef; |
313
|
7
|
|
|
|
|
23
|
return \$value; |
314
|
24
|
|
|
|
|
154
|
}; |
315
|
|
|
|
|
|
|
my $load_scalar_ref_blessed = sub { |
316
|
7
|
|
|
7
|
|
20
|
my ($constructor, $event) = @_; |
317
|
7
|
|
|
|
|
18
|
my $class = $event->{tag}; |
318
|
7
|
|
|
|
|
99
|
$class =~ s{^$perl_regex/scalar:}{}; |
319
|
7
|
|
|
|
|
20
|
my $value = undef; |
320
|
7
|
|
|
|
|
25
|
return $self->object(\$value, $class); |
321
|
24
|
|
|
|
|
131
|
}; |
322
|
|
|
|
|
|
|
$schema->add_mapping_resolver( |
323
|
|
|
|
|
|
|
tag => "$_/scalar", |
324
|
|
|
|
|
|
|
on_create => $load_scalar_ref, |
325
|
|
|
|
|
|
|
on_data => sub { |
326
|
6
|
|
|
6
|
|
23
|
my ($constructor, $ref, $list) = @_; |
327
|
6
|
|
|
|
|
24
|
$$$ref = $self->construct_scalar($list); |
328
|
|
|
|
|
|
|
}, |
329
|
24
|
|
|
|
|
219
|
) for @perl_tags; |
330
|
|
|
|
|
|
|
$schema->add_mapping_resolver( |
331
|
|
|
|
|
|
|
tag => qr{^$perl_regex/scalar:$class_regex$}, |
332
|
|
|
|
|
|
|
on_create => $load_scalar_ref_blessed, |
333
|
|
|
|
|
|
|
on_data => sub { |
334
|
7
|
|
|
7
|
|
43
|
my ($constructor, $ref, $list) = @_; |
335
|
7
|
|
|
|
|
29
|
$$$ref = $self->construct_scalar($list); |
336
|
|
|
|
|
|
|
}, |
337
|
24
|
|
|
|
|
449
|
); |
338
|
|
|
|
|
|
|
$schema->add_mapping_resolver( |
339
|
|
|
|
|
|
|
tag => qr{^$perl_regex/scalar:.+$}, |
340
|
|
|
|
|
|
|
on_create => $load_scalar_ref, |
341
|
|
|
|
|
|
|
on_data => sub { |
342
|
1
|
|
|
1
|
|
6
|
my ($constructor, $ref, $list) = @_; |
343
|
1
|
|
|
|
|
5
|
$$$ref = $self->construct_scalar($list); |
344
|
|
|
|
|
|
|
}, |
345
|
24
|
100
|
|
|
|
162
|
) if $no_objects; |
346
|
|
|
|
|
|
|
|
347
|
|
|
|
|
|
|
$schema->add_representer( |
348
|
|
|
|
|
|
|
scalarref => 1, |
349
|
|
|
|
|
|
|
code => sub { |
350
|
4
|
|
|
4
|
|
15
|
my ($rep, $node) = @_; |
351
|
4
|
|
|
|
|
13
|
$node->{tag} = $perl_tag . "/scalar"; |
352
|
4
|
|
|
|
|
20
|
$node->{data} = $self->represent_scalar($node->{value}); |
353
|
|
|
|
|
|
|
}, |
354
|
24
|
|
|
|
|
207
|
); |
355
|
|
|
|
|
|
|
$schema->add_representer( |
356
|
|
|
|
|
|
|
refref => 1, |
357
|
|
|
|
|
|
|
code => sub { |
358
|
4
|
|
|
4
|
|
12
|
my ($rep, $node) = @_; |
359
|
4
|
|
|
|
|
15
|
$node->{tag} = $perl_tag . "/ref"; |
360
|
4
|
|
|
|
|
16
|
$node->{data} = $self->represent_ref($node->{value}); |
361
|
|
|
|
|
|
|
}, |
362
|
24
|
|
|
|
|
175
|
); |
363
|
|
|
|
|
|
|
$schema->add_representer( |
364
|
|
|
|
|
|
|
coderef => 1, |
365
|
|
|
|
|
|
|
code => sub { |
366
|
5
|
|
|
5
|
|
16
|
my ($rep, $node) = @_; |
367
|
5
|
|
|
|
|
23
|
$node->{tag} = $perl_tag . "/code"; |
368
|
5
|
100
|
|
|
|
26
|
$node->{data} = $dumpcode ? $self->represent_code($node->{value}) : '{ "DUMMY" }'; |
369
|
|
|
|
|
|
|
}, |
370
|
24
|
|
|
|
|
159
|
); |
371
|
|
|
|
|
|
|
$schema->add_representer( |
372
|
|
|
|
|
|
|
glob => 1, |
373
|
|
|
|
|
|
|
code => sub { |
374
|
6
|
|
|
6
|
|
14
|
my ($rep, $node) = @_; |
375
|
6
|
|
|
|
|
18
|
$node->{tag} = $perl_tag . "/glob"; |
376
|
6
|
|
|
|
|
14
|
$node->{data} = $self->represent_glob($node->{value}); |
377
|
|
|
|
|
|
|
}, |
378
|
24
|
|
|
|
|
140
|
); |
379
|
|
|
|
|
|
|
|
380
|
|
|
|
|
|
|
$schema->add_representer( |
381
|
|
|
|
|
|
|
class_matches => 1, |
382
|
|
|
|
|
|
|
code => sub { |
383
|
40
|
|
|
40
|
|
67
|
my ($rep, $node) = @_; |
384
|
40
|
|
|
|
|
132
|
my $blessed = blessed $node->{value}; |
385
|
40
|
|
|
|
|
131
|
my $tag_blessed = ":$blessed"; |
386
|
40
|
50
|
|
|
|
340
|
if ($blessed !~ m/^$class_regex$/) { |
387
|
0
|
|
|
|
|
0
|
$tag_blessed = ''; |
388
|
|
|
|
|
|
|
} |
389
|
|
|
|
|
|
|
$node->{tag} = sprintf "$perl_tag/%s%s", |
390
|
40
|
|
|
|
|
305
|
lc($node->{reftype}), $tag_blessed; |
391
|
40
|
100
|
|
|
|
276
|
if ($node->{reftype} eq 'HASH') { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
392
|
6
|
|
|
|
|
16
|
$node->{data} = $node->{value}; |
393
|
|
|
|
|
|
|
} |
394
|
|
|
|
|
|
|
elsif ($node->{reftype} eq 'ARRAY') { |
395
|
10
|
|
|
|
|
21
|
$node->{data} = $node->{value}; |
396
|
|
|
|
|
|
|
} |
397
|
|
|
|
|
|
|
|
398
|
|
|
|
|
|
|
# Fun with regexes in perl versions! |
399
|
|
|
|
|
|
|
elsif ($node->{reftype} eq 'REGEXP') { |
400
|
8
|
100
|
|
|
|
26
|
if ($blessed eq 'Regexp') { |
401
|
4
|
|
|
|
|
14
|
$node->{tag} = $perl_tag . "/regexp"; |
402
|
|
|
|
|
|
|
} |
403
|
8
|
|
|
|
|
42
|
$node->{data} = $self->represent_regex($node->{value}); |
404
|
|
|
|
|
|
|
} |
405
|
|
|
|
|
|
|
elsif ($node->{reftype} eq 'SCALAR') { |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
# in perl <= 5.10 regex reftype(regex) was SCALAR |
408
|
4
|
50
|
33
|
|
|
81
|
if ($blessed eq 'Regexp') { |
|
|
50
|
33
|
|
|
|
|
409
|
0
|
|
|
|
|
0
|
$node->{tag} = $perl_tag . '/regexp'; |
410
|
0
|
|
|
|
|
0
|
$node->{data} = $self->represent_regex($node->{value}); |
411
|
|
|
|
|
|
|
} |
412
|
|
|
|
|
|
|
|
413
|
|
|
|
|
|
|
# In perl <= 5.10 there seemed to be no better pure perl |
414
|
|
|
|
|
|
|
# way to detect a blessed regex? |
415
|
|
|
|
|
|
|
elsif ( |
416
|
|
|
|
|
|
|
$] <= 5.010001 |
417
|
0
|
|
|
|
|
0
|
and not defined ${ $node->{value} } |
418
|
|
|
|
|
|
|
and $node->{value} =~ m/^\(\?/ |
419
|
|
|
|
|
|
|
) { |
420
|
0
|
|
|
|
|
0
|
$node->{tag} = $perl_tag . '/regexp' . $tag_blessed; |
421
|
0
|
|
|
|
|
0
|
$node->{data} = $self->represent_regex($node->{value}); |
422
|
|
|
|
|
|
|
} |
423
|
|
|
|
|
|
|
else { |
424
|
|
|
|
|
|
|
# phew, just a simple scalarref |
425
|
4
|
|
|
|
|
25
|
$node->{data} = $self->represent_scalar($node->{value}); |
426
|
|
|
|
|
|
|
} |
427
|
|
|
|
|
|
|
} |
428
|
|
|
|
|
|
|
elsif ($node->{reftype} eq 'REF') { |
429
|
4
|
|
|
|
|
20
|
$node->{data} = $self->represent_ref($node->{value}); |
430
|
|
|
|
|
|
|
} |
431
|
|
|
|
|
|
|
|
432
|
|
|
|
|
|
|
elsif ($node->{reftype} eq 'CODE') { |
433
|
5
|
100
|
|
|
|
23
|
$node->{data} = $dumpcode ? $self->represent_code($node->{value}) : '{ "DUMMY" }'; |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
elsif ($node->{reftype} eq 'GLOB') { |
436
|
3
|
|
|
|
|
8
|
$node->{data} = $self->represent_glob($node->{value}); |
437
|
|
|
|
|
|
|
} |
438
|
|
|
|
|
|
|
else { |
439
|
0
|
|
|
|
|
0
|
die "Reftype '$node->{reftype}' not implemented"; |
440
|
|
|
|
|
|
|
} |
441
|
|
|
|
|
|
|
|
442
|
40
|
|
|
|
|
201
|
return 1; |
443
|
|
|
|
|
|
|
}, |
444
|
24
|
|
|
|
|
200
|
); |
445
|
24
|
|
|
|
|
236
|
return; |
446
|
|
|
|
|
|
|
} |
447
|
|
|
|
|
|
|
|
448
|
|
|
|
|
|
|
sub evaluate_code { |
449
|
12
|
|
|
12
|
1
|
33
|
my ($self, $code) = @_; |
450
|
12
|
100
|
|
|
|
73
|
unless ($code =~ m/^ \s* \{ .* \} \s* \z/xs) { |
451
|
2
|
|
|
|
|
31
|
die "Malformed code"; |
452
|
|
|
|
|
|
|
} |
453
|
10
|
|
|
|
|
36
|
$code = "sub $code"; |
454
|
10
|
|
|
1
|
|
725
|
my $sub = eval $code; |
|
1
|
|
|
1
|
|
9
|
|
|
1
|
|
|
1
|
|
2
|
|
|
1
|
|
|
1
|
|
48
|
|
|
1
|
|
|
1
|
|
5
|
|
|
1
|
|
|
1
|
|
3
|
|
|
1
|
|
|
1
|
|
73
|
|
|
1
|
|
|
1
|
|
7
|
|
|
1
|
|
|
1
|
|
2
|
|
|
1
|
|
|
1
|
|
51
|
|
|
1
|
|
|
1
|
|
7
|
|
|
1
|
|
|
1
|
|
2
|
|
|
1
|
|
|
1
|
|
62
|
|
|
1
|
|
|
1
|
|
15
|
|
|
1
|
|
|
1
|
|
2
|
|
|
1
|
|
|
1
|
|
51
|
|
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
64
|
|
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
40
|
|
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
69
|
|
|
1
|
|
|
|
|
12
|
|
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
75
|
|
|
1
|
|
|
|
|
9
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
55
|
|
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
4
|
|
|
1
|
|
|
|
|
42
|
|
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
58
|
|
|
1
|
|
|
|
|
12
|
|
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
38
|
|
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
99
|
|
|
1
|
|
|
|
|
7
|
|
|
1
|
|
|
|
|
13
|
|
|
1
|
|
|
|
|
29
|
|
|
1
|
|
|
|
|
5
|
|
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
92
|
|
455
|
10
|
100
|
|
|
|
50
|
if ($@) { |
456
|
2
|
|
|
|
|
30
|
die "Couldn't eval code: $@>>$code<<"; |
457
|
|
|
|
|
|
|
} |
458
|
8
|
|
|
|
|
34
|
return $sub; |
459
|
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
sub construct_regex { |
462
|
11
|
|
|
11
|
1
|
29
|
my ($self, $regex) = @_; |
463
|
11
|
100
|
|
|
|
78
|
if ($regex =~ m/^$qr_prefix(.*)\)\z/s) { |
464
|
2
|
|
|
|
|
6
|
$regex = $1; |
465
|
|
|
|
|
|
|
} |
466
|
11
|
|
|
|
|
113
|
my $qr = qr{$regex}; |
467
|
11
|
|
|
|
|
42
|
return $qr; |
468
|
|
|
|
|
|
|
} |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
sub construct_glob { |
471
|
10
|
|
|
10
|
1
|
18
|
my ($self, $list) = @_; |
472
|
10
|
50
|
|
|
|
26
|
if (@$list % 2) { |
473
|
0
|
|
|
|
|
0
|
die "Unexpected data in perl/glob construction"; |
474
|
|
|
|
|
|
|
} |
475
|
10
|
|
|
|
|
38
|
my %globdata = @$list; |
476
|
10
|
100
|
|
|
|
51
|
my $name = delete $globdata{NAME} or die "Missing NAME in perl/glob"; |
477
|
9
|
|
|
|
|
16
|
my $pkg = delete $globdata{PACKAGE}; |
478
|
9
|
100
|
|
|
|
19
|
$pkg = 'main' unless defined $pkg; |
479
|
9
|
|
|
|
|
22
|
my @allowed = qw(SCALAR ARRAY HASH CODE IO); |
480
|
9
|
|
|
|
|
25
|
delete @globdata{ @allowed }; |
481
|
9
|
100
|
|
|
|
24
|
if (my @keys = keys %globdata) { |
482
|
1
|
|
|
|
|
18
|
die "Unexpected keys in perl/glob: @keys"; |
483
|
|
|
|
|
|
|
} |
484
|
5
|
|
|
5
|
|
47
|
no strict 'refs'; |
|
5
|
|
|
|
|
12
|
|
|
5
|
|
|
|
|
3084
|
|
485
|
8
|
|
|
|
|
11
|
return *{"${pkg}::$name"}; |
|
8
|
|
|
|
|
54
|
|
486
|
|
|
|
|
|
|
} |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
sub construct_scalar { |
489
|
28
|
|
|
28
|
1
|
56
|
my ($self, $list) = @_; |
490
|
28
|
100
|
|
|
|
66
|
if (@$list != 2) { |
491
|
4
|
|
|
|
|
49
|
die "Unexpected data in perl/scalar construction"; |
492
|
|
|
|
|
|
|
} |
493
|
24
|
|
|
|
|
46
|
my ($key, $value) = @$list; |
494
|
24
|
100
|
|
|
|
54
|
unless ($key eq '=') { |
495
|
4
|
|
|
|
|
50
|
die "Unexpected data in perl/scalar construction"; |
496
|
|
|
|
|
|
|
} |
497
|
20
|
|
|
|
|
66
|
return $value; |
498
|
|
|
|
|
|
|
} |
499
|
|
|
|
|
|
|
|
500
|
|
|
|
|
|
|
sub construct_ref { |
501
|
14
|
|
|
14
|
1
|
29
|
&construct_scalar; |
502
|
|
|
|
|
|
|
} |
503
|
|
|
|
|
|
|
|
504
|
|
|
|
|
|
|
sub represent_scalar { |
505
|
16
|
|
|
16
|
1
|
40
|
my ($self, $value) = @_; |
506
|
16
|
|
|
|
|
99
|
return { '=' => $$value }; |
507
|
|
|
|
|
|
|
} |
508
|
|
|
|
|
|
|
|
509
|
|
|
|
|
|
|
sub represent_ref { |
510
|
8
|
|
|
8
|
1
|
18
|
&represent_scalar; |
511
|
|
|
|
|
|
|
} |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
sub represent_code { |
514
|
8
|
|
|
8
|
1
|
17
|
my ($self, $code) = @_; |
515
|
8
|
|
|
|
|
53
|
require B::Deparse; |
516
|
8
|
|
|
|
|
315
|
my $deparse = B::Deparse->new("-p", "-sC"); |
517
|
8
|
|
|
|
|
16477
|
return $deparse->coderef2text($code); |
518
|
|
|
|
|
|
|
} |
519
|
|
|
|
|
|
|
|
520
|
|
|
|
|
|
|
|
521
|
|
|
|
|
|
|
my @stats = qw/ device inode mode links uid gid rdev size |
522
|
|
|
|
|
|
|
atime mtime ctime blksize blocks /; |
523
|
|
|
|
|
|
|
sub represent_glob { |
524
|
9
|
|
|
9
|
1
|
19
|
my ($self, $glob) = @_; |
525
|
9
|
|
|
|
|
15
|
my %glob; |
526
|
9
|
|
|
|
|
18
|
for my $type (qw/ PACKAGE NAME SCALAR ARRAY HASH CODE IO /) { |
527
|
63
|
|
|
|
|
75
|
my $value = *{ $glob }{ $type }; |
|
63
|
|
|
|
|
129
|
|
528
|
63
|
100
|
|
|
|
137
|
if ($type eq 'SCALAR') { |
|
|
100
|
|
|
|
|
|
529
|
9
|
|
|
|
|
17
|
$value = $$value; |
530
|
|
|
|
|
|
|
} |
531
|
|
|
|
|
|
|
elsif ($type eq 'IO') { |
532
|
9
|
100
|
|
|
|
22
|
if (defined $value) { |
533
|
5
|
|
|
|
|
10
|
undef $value; |
534
|
5
|
|
|
|
|
13
|
$value->{stat} = {}; |
535
|
5
|
50
|
|
|
|
8
|
if ($value->{fileno} = fileno(*{ $glob })) { |
|
5
|
|
|
|
|
18
|
|
536
|
5
|
|
|
|
|
7
|
@{ $value->{stat} }{ @stats } = stat(*{ $glob }); |
|
5
|
|
|
|
|
48
|
|
|
5
|
|
|
|
|
73
|
|
537
|
5
|
|
|
|
|
13
|
$value->{tell} = tell *{ $glob }; |
|
5
|
|
|
|
|
15
|
|
538
|
|
|
|
|
|
|
} |
539
|
|
|
|
|
|
|
} |
540
|
|
|
|
|
|
|
} |
541
|
63
|
100
|
|
|
|
144
|
$glob{ $type } = $value if defined $value; |
542
|
|
|
|
|
|
|
} |
543
|
9
|
|
|
|
|
41
|
return \%glob; |
544
|
|
|
|
|
|
|
} |
545
|
|
|
|
|
|
|
|
546
|
|
|
|
|
|
|
sub represent_regex { |
547
|
8
|
|
|
8
|
1
|
18
|
my ($self, $regex) = @_; |
548
|
8
|
|
|
|
|
17
|
$regex = "$regex"; |
549
|
8
|
50
|
|
|
|
77
|
if ($regex =~ m/^$qr_prefix(.*)\)\z/s) { |
550
|
8
|
|
|
|
|
23
|
$regex = $1; |
551
|
|
|
|
|
|
|
} |
552
|
8
|
|
|
|
|
26
|
return $regex; |
553
|
|
|
|
|
|
|
} |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
sub object { |
556
|
48
|
|
|
48
|
1
|
114
|
my ($self, $data, $class) = @_; |
557
|
48
|
|
|
|
|
206
|
return bless $data, $class; |
558
|
|
|
|
|
|
|
} |
559
|
|
|
|
|
|
|
|
560
|
|
|
|
|
|
|
1; |
561
|
|
|
|
|
|
|
|
562
|
|
|
|
|
|
|
__END__ |