Commit | Line | Data |
3fea05b9 |
1 | package YAML::Types; |
2 | |
3 | use strict; |
4 | use warnings; |
5 | use YAML::Base; |
6 | use YAML::Node; |
7 | |
8 | our $VERSION = '0.70'; |
9 | our @ISA = 'YAML::Base'; |
10 | |
11 | # XXX These classes and their APIs could still use some refactoring, |
12 | # but at least they work for now. |
13 | #------------------------------------------------------------------------------- |
14 | package YAML::Type::blessed; |
15 | |
16 | use YAML::Base; # XXX |
17 | |
18 | sub yaml_dump { |
19 | my $self = shift; |
20 | my ($value) = @_; |
21 | my ($class, $type) = YAML::Base->node_info($value); |
22 | no strict 'refs'; |
23 | my $kind = lc($type) . ':'; |
24 | my $tag = ${$class . '::ClassTag'} || |
25 | "!perl/$kind$class"; |
26 | if ($type eq 'REF') { |
27 | YAML::Node->new( |
28 | {(&YAML::VALUE, ${$_[0]})}, $tag |
29 | ); |
30 | } |
31 | elsif ($type eq 'SCALAR') { |
32 | $_[1] = $$value; |
33 | YAML::Node->new($_[1], $tag); |
34 | } else { |
35 | YAML::Node->new($value, $tag); |
36 | } |
37 | } |
38 | |
39 | #------------------------------------------------------------------------------- |
40 | package YAML::Type::undef; |
41 | |
42 | sub yaml_dump { |
43 | my $self = shift; |
44 | } |
45 | |
46 | sub yaml_load { |
47 | my $self = shift; |
48 | } |
49 | |
50 | #------------------------------------------------------------------------------- |
51 | package YAML::Type::glob; |
52 | |
53 | sub yaml_dump { |
54 | my $self = shift; |
55 | my $ynode = YAML::Node->new({}, '!perl/glob:'); |
56 | for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) { |
57 | my $value = *{$_[0]}{$type}; |
58 | $value = $$value if $type eq 'SCALAR'; |
59 | if (defined $value) { |
60 | if ($type eq 'IO') { |
61 | my @stats = qw(device inode mode links uid gid rdev size |
62 | atime mtime ctime blksize blocks); |
63 | undef $value; |
64 | $value->{stat} = YAML::Node->new({}); |
65 | map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]}); |
66 | $value->{fileno} = fileno(*{$_[0]}); |
67 | { |
68 | local $^W; |
69 | $value->{tell} = tell(*{$_[0]}); |
70 | } |
71 | } |
72 | $ynode->{$type} = $value; |
73 | } |
74 | } |
75 | return $ynode; |
76 | } |
77 | |
78 | sub yaml_load { |
79 | my $self = shift; |
80 | my ($node, $class, $loader) = @_; |
81 | my ($name, $package); |
82 | if (defined $node->{NAME}) { |
83 | $name = $node->{NAME}; |
84 | delete $node->{NAME}; |
85 | } |
86 | else { |
87 | $loader->warn('YAML_LOAD_WARN_GLOB_NAME'); |
88 | return undef; |
89 | } |
90 | if (defined $node->{PACKAGE}) { |
91 | $package = $node->{PACKAGE}; |
92 | delete $node->{PACKAGE}; |
93 | } |
94 | else { |
95 | $package = 'main'; |
96 | } |
97 | no strict 'refs'; |
98 | if (exists $node->{SCALAR}) { |
99 | *{"${package}::$name"} = \$node->{SCALAR}; |
100 | delete $node->{SCALAR}; |
101 | } |
102 | for my $elem (qw(ARRAY HASH CODE IO)) { |
103 | if (exists $node->{$elem}) { |
104 | if ($elem eq 'IO') { |
105 | $loader->warn('YAML_LOAD_WARN_GLOB_IO'); |
106 | delete $node->{IO}; |
107 | next; |
108 | } |
109 | *{"${package}::$name"} = $node->{$elem}; |
110 | delete $node->{$elem}; |
111 | } |
112 | } |
113 | for my $elem (sort keys %$node) { |
114 | $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem); |
115 | } |
116 | return *{"${package}::$name"}; |
117 | } |
118 | |
119 | #------------------------------------------------------------------------------- |
120 | package YAML::Type::code; |
121 | |
122 | my $dummy_warned = 0; |
123 | my $default = '{ "DUMMY" }'; |
124 | |
125 | sub yaml_dump { |
126 | my $self = shift; |
127 | my $code; |
128 | my ($dumpflag, $value) = @_; |
129 | my ($class, $type) = YAML::Base->node_info($value); |
130 | my $tag = "!perl/code"; |
131 | $tag .= ":$class" if defined $class; |
132 | if (not $dumpflag) { |
133 | $code = $default; |
134 | } |
135 | else { |
136 | bless $value, "CODE" if $class; |
137 | eval { use B::Deparse }; |
138 | return if $@; |
139 | my $deparse = B::Deparse->new(); |
140 | eval { |
141 | local $^W = 0; |
142 | $code = $deparse->coderef2text($value); |
143 | }; |
144 | if ($@) { |
145 | warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W; |
146 | $code = $default; |
147 | } |
148 | bless $value, $class if $class; |
149 | chomp $code; |
150 | $code .= "\n"; |
151 | } |
152 | $_[2] = $code; |
153 | YAML::Node->new($_[2], $tag); |
154 | } |
155 | |
156 | sub yaml_load { |
157 | my $self = shift; |
158 | my ($node, $class, $loader) = @_; |
159 | if ($loader->load_code) { |
160 | my $code = eval "package main; sub $node"; |
161 | if ($@) { |
162 | $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@); |
163 | return sub {}; |
164 | } |
165 | else { |
166 | CORE::bless $code, $class if $class; |
167 | return $code; |
168 | } |
169 | } |
170 | else { |
171 | return CORE::bless sub {}, $class if $class; |
172 | return sub {}; |
173 | } |
174 | } |
175 | |
176 | #------------------------------------------------------------------------------- |
177 | package YAML::Type::ref; |
178 | |
179 | sub yaml_dump { |
180 | my $self = shift; |
181 | YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref') |
182 | } |
183 | |
184 | sub yaml_load { |
185 | my $self = shift; |
186 | my ($node, $class, $loader) = @_; |
187 | $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr') |
188 | unless exists $node->{&YAML::VALUE}; |
189 | return \$node->{&YAML::VALUE}; |
190 | } |
191 | |
192 | #------------------------------------------------------------------------------- |
193 | package YAML::Type::regexp; |
194 | |
195 | # XXX Be sure to handle blessed regexps (if possible) |
196 | sub yaml_dump { |
197 | die "YAML::Type::regexp::yaml_dump not currently implemented"; |
198 | } |
199 | |
200 | use constant _QR_TYPES => { |
201 | '' => sub { qr{$_[0]} }, |
202 | x => sub { qr{$_[0]}x }, |
203 | i => sub { qr{$_[0]}i }, |
204 | s => sub { qr{$_[0]}s }, |
205 | m => sub { qr{$_[0]}m }, |
206 | ix => sub { qr{$_[0]}ix }, |
207 | sx => sub { qr{$_[0]}sx }, |
208 | mx => sub { qr{$_[0]}mx }, |
209 | si => sub { qr{$_[0]}si }, |
210 | mi => sub { qr{$_[0]}mi }, |
211 | ms => sub { qr{$_[0]}sm }, |
212 | six => sub { qr{$_[0]}six }, |
213 | mix => sub { qr{$_[0]}mix }, |
214 | msx => sub { qr{$_[0]}msx }, |
215 | msi => sub { qr{$_[0]}msi }, |
216 | msix => sub { qr{$_[0]}msix }, |
217 | }; |
218 | |
219 | sub yaml_load { |
220 | my $self = shift; |
221 | my ($node, $class) = @_; |
222 | return qr{$node} unless $node =~ /^\(\?([\-xism]*):(.*)\)\z/s; |
223 | my ($flags, $re) = ($1, $2); |
224 | $flags =~ s/-.*//; |
225 | my $sub = _QR_TYPES->{$flags} || sub { qr{$_[0]} }; |
226 | my $qr = &$sub($re); |
227 | bless $qr, $class if length $class; |
228 | return $qr; |
229 | } |
230 | |
231 | 1; |
232 | |
233 | __END__ |
234 | |
235 | =head1 NAME |
236 | |
237 | YAML::Types - Marshall Perl internal data types to/from YAML |
238 | |
239 | =head1 SYNOPSIS |
240 | |
241 | $::foo = 42; |
242 | print YAML::Dump(*::foo); |
243 | |
244 | print YAML::Dump(qr{match me}); |
245 | |
246 | =head1 DESCRIPTION |
247 | |
248 | This module has the helper classes for transferring objects, |
249 | subroutines, references, globs, regexps and file handles to and |
250 | from YAML. |
251 | |
252 | =head1 AUTHOR |
253 | |
254 | Ingy döt Net <ingy@cpan.org> |
255 | |
256 | =head1 COPYRIGHT |
257 | |
258 | Copyright (c) 2006. Ingy döt Net. All rights reserved. |
259 | |
260 | This program is free software; you can redistribute it and/or modify it |
261 | under the same terms as Perl itself. |
262 | |
263 | See L<http://www.perl.com/perl/misc/Artistic.html> |
264 | |
265 | =cut |