Revision c6bc1816
Von Sven Schöling vor etwa 9 Jahren hinzugefügt
| modules/override/YAML/Types.pm | ||
|---|---|---|
| 1 | 1 |
package YAML::Types; |
| 2 |
use strict; use warnings; |
|
| 3 |
use YAML::Base; use base 'YAML::Base';
|
|
| 2 |
|
|
| 3 |
use YAML::Mo;
|
|
| 4 | 4 |
use YAML::Node; |
| 5 | 5 |
|
| 6 | 6 |
# XXX These classes and their APIs could still use some refactoring, |
| 7 | 7 |
# but at least they work for now. |
| 8 | 8 |
#------------------------------------------------------------------------------- |
| 9 | 9 |
package YAML::Type::blessed; |
| 10 |
use YAML::Base; # XXX |
|
| 10 |
|
|
| 11 |
use YAML::Mo; # XXX |
|
| 12 |
|
|
| 11 | 13 |
sub yaml_dump {
|
| 12 | 14 |
my $self = shift; |
| 13 | 15 |
my ($value) = @_; |
| 14 |
my ($class, $type) = YAML::Base->node_info($value);
|
|
| 16 |
my ($class, $type) = YAML::Mo::Object->node_info($value);
|
|
| 15 | 17 |
no strict 'refs'; |
| 16 | 18 |
my $kind = lc($type) . ':'; |
| 17 | 19 |
my $tag = ${$class . '::ClassTag'} ||
|
| ... | ... | |
| 24 | 26 |
elsif ($type eq 'SCALAR') {
|
| 25 | 27 |
$_[1] = $$value; |
| 26 | 28 |
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 |
return YAML::Type::glob->yaml_dump($value, $tag); |
|
| 27 | 34 |
} else {
|
| 28 | 35 |
YAML::Node->new($value, $tag); |
| 29 | 36 |
} |
| ... | ... | |
| 31 | 38 |
|
| 32 | 39 |
#------------------------------------------------------------------------------- |
| 33 | 40 |
package YAML::Type::undef; |
| 41 |
|
|
| 34 | 42 |
sub yaml_dump {
|
| 35 | 43 |
my $self = shift; |
| 36 | 44 |
} |
| ... | ... | |
| 41 | 49 |
|
| 42 | 50 |
#------------------------------------------------------------------------------- |
| 43 | 51 |
package YAML::Type::glob; |
| 52 |
|
|
| 44 | 53 |
sub yaml_dump {
|
| 45 | 54 |
my $self = shift; |
| 46 |
my $ynode = YAML::Node->new({}, '!perl/glob:');
|
|
| 55 |
# $_[0] remains as the glob |
|
| 56 |
my $tag = pop @_ if 2==@_; |
|
| 57 |
|
|
| 58 |
$tag = '!perl/glob:' unless defined $tag; |
|
| 59 |
my $ynode = YAML::Node->new({}, $tag);
|
|
| 47 | 60 |
for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
|
| 48 | 61 |
my $value = *{$_[0]}{$type};
|
| 49 | 62 |
$value = $$value if $type eq 'SCALAR'; |
| ... | ... | |
| 53 | 66 |
atime mtime ctime blksize blocks); |
| 54 | 67 |
undef $value; |
| 55 | 68 |
$value->{stat} = YAML::Node->new({});
|
| 56 |
map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
|
|
| 57 |
$value->{fileno} = fileno(*{$_[0]});
|
|
| 58 |
{
|
|
| 69 |
if ($value->{fileno} = fileno(*{$_[0]})) {
|
|
| 59 | 70 |
local $^W; |
| 71 |
map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
|
|
| 60 | 72 |
$value->{tell} = tell(*{$_[0]});
|
| 61 | 73 |
} |
| 62 | 74 |
} |
| 63 |
$ynode->{$type} = $value;
|
|
| 75 |
$ynode->{$type} = $value;
|
|
| 64 | 76 |
} |
| 65 | 77 |
} |
| 66 | 78 |
return $ynode; |
| ... | ... | |
| 109 | 121 |
|
| 110 | 122 |
#------------------------------------------------------------------------------- |
| 111 | 123 |
package YAML::Type::code; |
| 112 |
my $dummy_warned = 0; |
|
| 124 |
|
|
| 125 |
my $dummy_warned = 0; |
|
| 113 | 126 |
my $default = '{ "DUMMY" }';
|
| 127 |
|
|
| 114 | 128 |
sub yaml_dump {
|
| 115 | 129 |
my $self = shift; |
| 116 | 130 |
my $code; |
| 117 | 131 |
my ($dumpflag, $value) = @_; |
| 118 |
my ($class, $type) = YAML::Base->node_info($value);
|
|
| 119 |
$class ||= '';
|
|
| 120 |
my $tag = "!perl/code:$class";
|
|
| 132 |
my ($class, $type) = YAML::Mo::Object->node_info($value);
|
|
| 133 |
my $tag = "!perl/code";
|
|
| 134 |
$tag .= ":$class" if defined $class;
|
|
| 121 | 135 |
if (not $dumpflag) {
|
| 122 | 136 |
$code = $default; |
| 123 | 137 |
} |
| ... | ... | |
| 140 | 154 |
} |
| 141 | 155 |
$_[2] = $code; |
| 142 | 156 |
YAML::Node->new($_[2], $tag); |
| 143 |
}
|
|
| 157 |
} |
|
| 144 | 158 |
|
| 145 | 159 |
sub yaml_load {
|
| 146 | 160 |
my $self = shift; |
| ... | ... | |
| 157 | 171 |
} |
| 158 | 172 |
} |
| 159 | 173 |
else {
|
| 174 |
return CORE::bless sub {}, $class if $class;
|
|
| 160 | 175 |
return sub {};
|
| 161 | 176 |
} |
| 162 | 177 |
} |
| 163 | 178 |
|
| 164 | 179 |
#------------------------------------------------------------------------------- |
| 165 | 180 |
package YAML::Type::ref; |
| 181 |
|
|
| 166 | 182 |
sub yaml_dump {
|
| 167 | 183 |
my $self = shift; |
| 168 |
YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref:')
|
|
| 184 |
YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref')
|
|
| 169 | 185 |
} |
| 170 | 186 |
|
| 171 | 187 |
sub yaml_load {
|
| ... | ... | |
| 178 | 194 |
|
| 179 | 195 |
#------------------------------------------------------------------------------- |
| 180 | 196 |
package YAML::Type::regexp; |
| 197 |
|
|
| 181 | 198 |
# XXX Be sure to handle blessed regexps (if possible) |
| 182 | 199 |
sub yaml_dump {
|
| 183 |
my $self = shift; |
|
| 184 |
my ($node, $class, $dumper) = @_; |
|
| 185 |
my ($regexp, $modifiers); |
|
| 186 |
if ("$node" =~ /^\(\?(\w*)(?:\-\w+)?\:(.*)\)$/) {
|
|
| 187 |
$regexp = $2; |
|
| 188 |
$modifiers = $1 || ''; |
|
| 189 |
} |
|
| 190 |
else {
|
|
| 191 |
$dumper->die('YAML_DUMP_ERR_BAD_REGEXP', $node);
|
|
| 192 |
} |
|
| 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;
|
|
| 198 |
return $ynode; |
|
| 200 |
die "YAML::Type::regexp::yaml_dump not currently implemented"; |
|
| 199 | 201 |
} |
| 200 | 202 |
|
| 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 },
|
|
| 220 |
}; |
|
| 221 |
|
|
| 201 | 222 |
sub yaml_load {
|
| 202 | 223 |
my $self = shift; |
| 203 |
my ($node, $class, $loader) = @_; |
|
| 204 |
my ($regexp, $modifiers); |
|
| 205 |
if (defined $node->{REGEXP}) {
|
|
| 206 |
$regexp = $node->{REGEXP};
|
|
| 207 |
delete $node->{REGEXP};
|
|
| 208 |
} |
|
| 209 |
else {
|
|
| 210 |
$loader->warn('YAML_LOAD_WARN_NO_REGEXP_IN_REGEXP');
|
|
| 211 |
return undef; |
|
| 212 |
} |
|
| 213 |
if (defined $node->{MODIFIERS}) {
|
|
| 214 |
$modifiers = $node->{MODIFIERS};
|
|
| 215 |
delete $node->{MODIFIERS};
|
|
| 216 |
} |
|
| 217 |
else {
|
|
| 218 |
$modifiers = ''; |
|
| 219 |
} |
|
| 220 |
for my $elem (sort keys %$node) {
|
|
| 221 |
$loader->warn('YAML_LOAD_WARN_BAD_REGEXP_ELEM', $elem);
|
|
| 222 |
} |
|
| 223 |
my $qr = $regexp; |
|
| 224 |
$qr = "(?$modifiers:$qr)"; |
|
| 225 |
return qr{$qr};
|
|
| 224 |
my ($node, $class) = @_; |
|
| 225 |
return qr{$node} unless $node =~ /^\(\?([\^\-xism]*):(.*)\)\z/s;
|
|
| 226 |
my ($flags, $re) = ($1, $2); |
|
| 227 |
$flags =~ s/-.*//; |
|
| 228 |
$flags =~ s/^\^//; |
|
| 229 |
my $sub = _QR_TYPES->{$flags} || sub { qr{$_[0]} };
|
|
| 230 |
my $qr = &$sub($re); |
|
| 231 |
bless $qr, $class if length $class; |
|
| 232 |
return $qr; |
|
| 226 | 233 |
} |
| 227 | 234 |
|
| 228 | 235 |
1; |
| 229 |
|
|
| 230 |
__END__ |
|
| 231 |
|
|
| 232 |
=head1 NAME |
|
| 233 |
|
|
| 234 |
YAML::Transfer - Marshall Perl internal data types to/from YAML |
|
| 235 |
|
|
| 236 |
=head1 SYNOPSIS |
|
| 237 |
|
|
| 238 |
$::foo = 42; |
|
| 239 |
print YAML::Dump(*::foo); |
|
| 240 |
|
|
| 241 |
print YAML::Dump(qr{match me});
|
|
| 242 |
|
|
| 243 |
=head1 DESCRIPTION |
|
| 244 |
|
|
| 245 |
This module has the helper classes for transferring objects, |
|
| 246 |
subroutines, references, globs, regexps and file handles to and |
|
| 247 |
from YAML. |
|
| 248 |
|
|
| 249 |
=head1 AUTHOR |
|
| 250 |
|
|
| 251 |
Ingy döt Net <ingy@cpan.org> |
|
| 252 |
|
|
| 253 |
=head1 COPYRIGHT |
|
| 254 |
|
|
| 255 |
Copyright (c) 2006. Ingy döt Net. All rights reserved. |
|
| 256 |
|
|
| 257 |
This program is free software; you can redistribute it and/or modify it |
|
| 258 |
under the same terms as Perl itself. |
|
| 259 |
|
|
| 260 |
See L<http://www.perl.com/perl/misc/Artistic.html> |
|
| 261 |
|
|
| 262 |
=cut |
|
Auch abrufbar als: Unified diff
YAML: Versionsupdate