File Coverage

blib/lib/YAML/PP/Schema/Perl.pm
Criterion Covered Total %
statement 319 328 97.2
branch 88 100 88.0
condition 12 18 66.6
subroutine 63 63 100.0
pod 13 13 100.0
total 495 522 94.8


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__