File Coverage

blib/lib/YAML/Types.pm
Criterion Covered Total %
statement 130 163 79.7
branch 46 60 76.6
condition 12 20 60.0
subroutine 15 23 65.2
pod n/a
total 203 266 76.3


line stmt bran cond sub pod time code
1             package YAML::Types;
2              
3 48     48   288 use YAML::Mo;
  48         84  
  48         258  
4 48     48   303 use YAML::Node;
  48         96  
  48         2818  
5              
6             # XXX These classes and their APIs could still use some refactoring,
7             # but at least they work for now.
8             #-------------------------------------------------------------------------------
9             package YAML::Type::blessed;
10              
11 48     48   324 use YAML::Mo; # XXX
  48         95  
  48         181  
12              
13             sub yaml_dump {
14 29     29   63 my $self = shift;
15 29         58 my ($value) = @_;
16 29         86 my ($class, $type) = YAML::Mo::Object->node_info($value);
17 48     48   317 no strict 'refs';
  48         114  
  48         25375  
18 29         103 my $kind = lc($type) . ':';
19 29   66     44 my $tag = ${$class . '::ClassTag'} ||
20             "!perl/$kind$class";
21 29 100       132 if ($type eq 'REF') {
    100          
    100          
22             YAML::Node->new(
23 1         4 {(&YAML::VALUE, ${$_[0]})}, $tag
  1         5  
24             );
25             }
26             elsif ($type eq 'SCALAR') {
27 7         81 $_[1] = $$value;
28 7         35 YAML::Node->new($_[1], $tag);
29             }
30             elsif ($type eq 'GLOB') {
31             # blessed glob support is minimal, and will not round-trip
32             # initial aim: to not cause an error
33 2         7 return YAML::Type::glob->yaml_dump($value, $tag);
34             } else {
35 19         81 YAML::Node->new($value, $tag);
36             }
37             }
38              
39             #-------------------------------------------------------------------------------
40             package YAML::Type::undef;
41              
42             sub yaml_dump {
43 0     0   0 my $self = shift;
44             }
45              
46             sub yaml_load {
47 0     0   0 my $self = shift;
48             }
49              
50             #-------------------------------------------------------------------------------
51             package YAML::Type::glob;
52              
53             sub yaml_dump {
54 8     8   16 my $self = shift;
55             # $_[0] remains as the glob
56 8 100       26 my $tag = pop @_ if 2==@_;
57              
58 8 100       35 $tag = '!perl/glob:' unless defined $tag;
59 8         37 my $ynode = YAML::Node->new({}, $tag);
60 8         22 for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
61 56         71 my $value = *{$_[0]}{$type};
  56         127  
62 56 100       323 $value = $$value if $type eq 'SCALAR';
63 56 100       115 if (defined $value) {
64 28 100       51 if ($type eq 'IO') {
65 1         3 my @stats = qw(device inode mode links uid gid rdev size
66             atime mtime ctime blksize blocks);
67 1         2 undef $value;
68 1         4 $value->{stat} = YAML::Node->new({});
69 1 50       4 if ($value->{fileno} = fileno(*{$_[0]})) {
  1         5  
70 1         5 local $^W;
71 1         2 map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
  13         39  
  1         10  
72 1         3 $value->{tell} = tell(*{$_[0]});
  1         4  
73             }
74             }
75 28         141 $ynode->{$type} = $value;
76             }
77             }
78 8         33 return $ynode;
79             }
80              
81             sub yaml_load {
82 6     6   13 my $self = shift;
83 6         16 my ($node, $class, $loader) = @_;
84 6         12 my ($name, $package);
85 6 100       17 if (defined $node->{NAME}) {
86 5         12 $name = $node->{NAME};
87 5         12 delete $node->{NAME};
88             }
89             else {
90 1         5 $loader->warn('YAML_LOAD_WARN_GLOB_NAME');
91 1         755 return undef;
92             }
93 5 100       14 if (defined $node->{PACKAGE}) {
94 4         11 $package = $node->{PACKAGE};
95 4         10 delete $node->{PACKAGE};
96             }
97             else {
98 1         2 $package = 'main';
99             }
100 48     48   377 no strict 'refs';
  48         91  
  48         50405  
101 5 100       16 if (exists $node->{SCALAR}) {
102 4 50 66     21 if ($YAML::LoadBlessed and $loader->load_code) {
103 0         0 *{"${package}::$name"} = \$node->{SCALAR};
  0         0  
104             }
105 4         8 delete $node->{SCALAR};
106             }
107 5         15 for my $elem (qw(ARRAY HASH CODE IO)) {
108 20 100       82 if (exists $node->{$elem}) {
109 2 50       19 if ($elem eq 'IO') {
110 0         0 $loader->warn('YAML_LOAD_WARN_GLOB_IO');
111 0         0 delete $node->{IO};
112 0         0 next;
113             }
114 2 50 33     12 if ($YAML::LoadBlessed and $loader->load_code) {
115 0         0 *{"${package}::$name"} = $node->{$elem};
  0         0  
116             }
117 2         4 delete $node->{$elem};
118             }
119             }
120 5         19 for my $elem (sort keys %$node) {
121 1         6 $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem);
122             }
123 5         704 return *{"${package}::$name"};
  5         41  
124             }
125              
126             #-------------------------------------------------------------------------------
127             package YAML::Type::code;
128              
129             my $dummy_warned = 0;
130             my $default = '{ "DUMMY" }';
131              
132             sub yaml_dump {
133 9     9   20 my $self = shift;
134 9         16 my $code;
135 9         22 my ($dumpflag, $value) = @_;
136 9         26 my ($class, $type) = YAML::Mo::Object->node_info($value);
137 9         19 my $tag = "!perl/code";
138 9 100       28 $tag .= ":$class" if defined $class;
139 9 100       38 if (not $dumpflag) {
140 2         11 $code = $default;
141             }
142             else {
143 7 100       38 bless $value, "CODE" if $class;
144 7         12 eval { require B::Deparse };
  7         30  
145 7 50       20 return if $@;
146 7         275 my $deparse = B::Deparse->new();
147 7         26 eval {
148 7         30 local $^W = 0;
149 7         5879 $code = $deparse->coderef2text($value);
150             };
151 7 50       42 if ($@) {
152 0 0       0 warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W;
153 0         0 $code = $default;
154             }
155 7 100       20 bless $value, $class if $class;
156 7         18 chomp $code;
157 7         50 $code .= "\n";
158             }
159 9         21 $_[2] = $code;
160 9         50 YAML::Node->new($_[2], $tag);
161             }
162              
163             sub yaml_load {
164 6     6   13 my $self = shift;
165 6         13 my ($node, $class, $loader) = @_;
166 6 100       30 if ($loader->load_code) {
167 3     1   234 my $code = eval "package main; sub $node";
  1     1   6  
  1         2  
  1         28  
  1         5  
  1         2  
  1         23  
168 3 50       9 if ($@) {
169 0         0 $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@);
170 0     0   0 return sub {};
171             }
172             else {
173 3 50 66     20 CORE::bless $code, $class if ($class and $YAML::LoadBlessed);
174 3         11 return $code;
175             }
176             }
177             else {
178 3 0 33 0   9 return CORE::bless sub {}, $class if ($class and $YAML::LoadBlessed);
179 3     0   23 return sub {};
180             }
181             }
182              
183             #-------------------------------------------------------------------------------
184             package YAML::Type::ref;
185              
186             sub yaml_dump {
187 33     33   52 my $self = shift;
188 33         78 YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref')
  33         154  
189             }
190              
191             sub yaml_load {
192 0     0   0 my $self = shift;
193 0         0 my ($node, $class, $loader) = @_;
194             $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr')
195 0 0       0 unless exists $node->{&YAML::VALUE};
196 0         0 return \$node->{&YAML::VALUE};
197             }
198              
199             #-------------------------------------------------------------------------------
200             package YAML::Type::regexp;
201              
202             # XXX Be sure to handle blessed regexps (if possible)
203             sub yaml_dump {
204 0     0   0 die "YAML::Type::regexp::yaml_dump not currently implemented";
205             }
206              
207             use constant _QR_TYPES => {
208 7         68 '' => sub { qr{$_[0]} },
209 0         0 x => sub { qr{$_[0]}x },
210 0         0 i => sub { qr{$_[0]}i },
211 0         0 s => sub { qr{$_[0]}s },
212 2         14 m => sub { qr{$_[0]}m },
213 0         0 ix => sub { qr{$_[0]}ix },
214 0         0 sx => sub { qr{$_[0]}sx },
215 0         0 mx => sub { qr{$_[0]}mx },
216 0         0 si => sub { qr{$_[0]}si },
217 0         0 mi => sub { qr{$_[0]}mi },
218 0         0 ms => sub { qr{$_[0]}sm },
219 0         0 six => sub { qr{$_[0]}six },
220 0         0 mix => sub { qr{$_[0]}mix },
221 0         0 msx => sub { qr{$_[0]}msx },
222 0         0 msi => sub { qr{$_[0]}msi },
223 0         0 msix => sub { qr{$_[0]}msix },
224 48     48   366 };
  48         108  
  48         15158  
225              
226             sub yaml_load {
227 10     10   14 my $self = shift;
228 10         16 my ($node, $class) = @_;
229 10 100       53 return qr{$node} unless $node =~ /^\(\?([\^\-uxism]*):(.*)\)\z/s;
230 9         22 my ($flags, $re) = ($1, $2);
231 9         22 $flags =~ s/-.*//;
232 9         20 $flags =~ s/^\^//;
233 9         22 $flags =~ tr/u//d;
234 9   50 0   34 my $sub = _QR_TYPES->{$flags} || sub { qr{$_[0]} };
  0         0  
235 9         21 my $qr = &$sub($re);
236 9 100 100     33 bless $qr, $class if (length $class and $YAML::LoadBlessed);
237 9         28 return $qr;
238             }
239              
240             1;