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