2 use strict; use warnings;
3 use YAML::Base; use base 'YAML::Base';
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;
14 my ($class, $type) = YAML::Base->node_info($value);
16 my $kind = lc($type) . ':';
17 my $tag = ${$class . '::ClassTag'} ||
21 {(&YAML::VALUE, ${$_[0]})}, $tag
24 elsif ($type eq 'SCALAR') {
26 YAML::Node->new($_[1], $tag);
28 YAML::Node->new($value, $tag);
32 #-------------------------------------------------------------------------------
33 package YAML::Type::undef;
42 #-------------------------------------------------------------------------------
43 package YAML::Type::glob;
46 my $ynode = YAML::Node->new({}, '!perl/glob:');
47 for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
48 my $value = *{$_[0]}{$type};
49 $value = $$value if $type eq 'SCALAR';
52 my @stats = qw(device inode mode links uid gid rdev size
53 atime mtime ctime blksize blocks);
55 $value->{stat} = YAML::Node->new({});
56 map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
57 $value->{fileno} = fileno(*{$_[0]});
60 $value->{tell} = tell(*{$_[0]});
63 $ynode->{$type} = $value;
71 my ($node, $class, $loader) = @_;
73 if (defined $node->{NAME}) {
74 $name = $node->{NAME};
78 $loader->warn('YAML_LOAD_WARN_GLOB_NAME');
81 if (defined $node->{PACKAGE}) {
82 $package = $node->{PACKAGE};
83 delete $node->{PACKAGE};
89 if (exists $node->{SCALAR}) {
90 *{"${package}::$name"} = \$node->{SCALAR};
91 delete $node->{SCALAR};
93 for my $elem (qw(ARRAY HASH CODE IO)) {
94 if (exists $node->{$elem}) {
96 $loader->warn('YAML_LOAD_WARN_GLOB_IO');
100 *{"${package}::$name"} = $node->{$elem};
101 delete $node->{$elem};
104 for my $elem (sort keys %$node) {
105 $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem);
107 return *{"${package}::$name"};
110 #-------------------------------------------------------------------------------
111 package YAML::Type::code;
112 my $dummy_warned = 0;
113 my $default = '{ "DUMMY" }';
117 my ($dumpflag, $value) = @_;
118 my ($class, $type) = YAML::Base->node_info($value);
120 my $tag = "!perl/code:$class";
125 bless $value, "CODE" if $class;
126 eval { use B::Deparse };
128 my $deparse = B::Deparse->new();
131 $code = $deparse->coderef2text($value);
134 warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W;
137 bless $value, $class if $class;
142 YAML::Node->new($_[2], $tag);
147 my ($node, $class, $loader) = @_;
148 if ($loader->load_code) {
149 my $code = eval "package main; sub $node";
151 $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@);
155 CORE::bless $code, $class if $class;
164 #-------------------------------------------------------------------------------
165 package YAML::Type::ref;
168 YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref:')
173 my ($node, $class, $loader) = @_;
174 $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr')
175 unless exists $node->{&YAML::VALUE};
176 return \$node->{&YAML::VALUE};
179 #-------------------------------------------------------------------------------
180 package YAML::Type::regexp;
181 # XXX Be sure to handle blessed regexps (if possible)
184 my ($node, $class, $dumper) = @_;
185 my ($regexp, $modifiers);
186 if ("$node" =~ /^\(\?(\w*)(?:\-\w+)?\:(.*)\)$/) {
188 $modifiers = $1 || '';
191 $dumper->die('YAML_DUMP_ERR_BAD_REGEXP', $node);
193 my $tag = '!perl/regexp:';
194 $tag .= $class if $class;
195 my $ynode = YAML::Node->new({}, $tag);
196 $ynode->{REGEXP} = $regexp;
197 $ynode->{MODIFIERS} = $modifiers if $modifiers;
203 my ($node, $class, $loader) = @_;
204 my ($regexp, $modifiers);
205 if (defined $node->{REGEXP}) {
206 $regexp = $node->{REGEXP};
207 delete $node->{REGEXP};
210 $loader->warn('YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP');
213 if (defined $node->{MODIFIERS}) {
214 $modifiers = $node->{MODIFIERS};
215 delete $node->{MODIFIERS};
220 for my $elem (sort keys %$node) {
221 $loader->warn('YAML_LOAD_WARN_BAD_REGEXP_ELEM', $elem);
224 $qr = "(?$modifiers:$qr)";
234 YAML::Transfer - Marshall Perl internal data types to/from YAML
239 print YAML::Dump(*::foo);
241 print YAML::Dump(qr{match me});
245 This module has the helper classes for transferring objects,
246 subroutines, references, globs, regexps and file handles to and
251 Ingy döt Net <ingy@cpan.org>
255 Copyright (c) 2006. Ingy döt Net. All rights reserved.
257 This program is free software; you can redistribute it and/or modify it
258 under the same terms as Perl itself.
260 See L<http://www.perl.com/perl/misc/Artistic.html>