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;
16 my ($class, $type) = YAML::Mo::Object->node_info($value);
18 my $kind = lc($type) . ':';
19 my $tag = ${$class . '::ClassTag'} ||
23 {(&YAML::VALUE, ${$_[0]})}, $tag
26 elsif ($type eq 'SCALAR') {
28 YAML::Node->new($_[1], $tag);
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 return YAML::Type::glob->yaml_dump($value, $tag);
35 YAML::Node->new($value, $tag);
39 #-------------------------------------------------------------------------------
40 package YAML::Type::undef;
50 #-------------------------------------------------------------------------------
51 package YAML::Type::glob;
55 # $_[0] remains as the glob
56 my $tag = pop @_ if 2==@_;
58 $tag = '!perl/glob:' unless defined $tag;
59 my $ynode = YAML::Node->new({}, $tag);
60 for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
61 my $value = *{$_[0]}{$type};
62 $value = $$value if $type eq 'SCALAR';
65 my @stats = qw(device inode mode links uid gid rdev size
66 atime mtime ctime blksize blocks);
68 $value->{stat} = YAML::Node->new({});
69 if ($value->{fileno} = fileno(*{$_[0]})) {
71 map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
72 $value->{tell} = tell(*{$_[0]});
75 $ynode->{$type} = $value;
83 my ($node, $class, $loader) = @_;
85 if (defined $node->{NAME}) {
86 $name = $node->{NAME};
90 $loader->warn('YAML_LOAD_WARN_GLOB_NAME');
93 if (defined $node->{PACKAGE}) {
94 $package = $node->{PACKAGE};
95 delete $node->{PACKAGE};
101 if (exists $node->{SCALAR}) {
102 *{"${package}::$name"} = \$node->{SCALAR};
103 delete $node->{SCALAR};
105 for my $elem (qw(ARRAY HASH CODE IO)) {
106 if (exists $node->{$elem}) {
108 $loader->warn('YAML_LOAD_WARN_GLOB_IO');
112 *{"${package}::$name"} = $node->{$elem};
113 delete $node->{$elem};
116 for my $elem (sort keys %$node) {
117 $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem);
119 return *{"${package}::$name"};
122 #-------------------------------------------------------------------------------
123 package YAML::Type::code;
125 my $dummy_warned = 0;
126 my $default = '{ "DUMMY" }';
131 my ($dumpflag, $value) = @_;
132 my ($class, $type) = YAML::Mo::Object->node_info($value);
133 my $tag = "!perl/code";
134 $tag .= ":$class" if defined $class;
139 bless $value, "CODE" if $class;
140 eval { use B::Deparse };
142 my $deparse = B::Deparse->new();
145 $code = $deparse->coderef2text($value);
148 warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W;
151 bless $value, $class if $class;
156 YAML::Node->new($_[2], $tag);
161 my ($node, $class, $loader) = @_;
162 if ($loader->load_code) {
163 my $code = eval "package main; sub $node";
165 $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@);
169 CORE::bless $code, $class if $class;
174 return CORE::bless sub {}, $class if $class;
179 #-------------------------------------------------------------------------------
180 package YAML::Type::ref;
184 YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref')
189 my ($node, $class, $loader) = @_;
190 $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr')
191 unless exists $node->{&YAML::VALUE};
192 return \$node->{&YAML::VALUE};
195 #-------------------------------------------------------------------------------
196 package YAML::Type::regexp;
198 # XXX Be sure to handle blessed regexps (if possible)
200 die "YAML::Type::regexp::yaml_dump not currently implemented";
203 use constant _QR_TYPES => {
204 '' => sub { qr{$_[0]} },
205 x => sub { qr{$_[0]}x },
206 i => sub { qr{$_[0]}i },
207 s => sub { qr{$_[0]}s },
208 m => sub { qr{$_[0]}m },
209 ix => sub { qr{$_[0]}ix },
210 sx => sub { qr{$_[0]}sx },
211 mx => sub { qr{$_[0]}mx },
212 si => sub { qr{$_[0]}si },
213 mi => sub { qr{$_[0]}mi },
214 ms => sub { qr{$_[0]}sm },
215 six => sub { qr{$_[0]}six },
216 mix => sub { qr{$_[0]}mix },
217 msx => sub { qr{$_[0]}msx },
218 msi => sub { qr{$_[0]}msi },
219 msix => sub { qr{$_[0]}msix },
224 my ($node, $class) = @_;
225 return qr{$node} unless $node =~ /^\(\?([\^\-xism]*):(.*)\)\z/s;
226 my ($flags, $re) = ($1, $2);
229 my $sub = _QR_TYPES->{$flags} || sub { qr{$_[0]} };
231 bless $qr, $class if length $class;