diff options
Diffstat (limited to 'lib/YAML/Types.pm')
| -rw-r--r-- | lib/YAML/Types.pm | 235 |
1 files changed, 235 insertions, 0 deletions
diff --git a/lib/YAML/Types.pm b/lib/YAML/Types.pm new file mode 100644 index 0000000..8cbbde2 --- /dev/null +++ b/lib/YAML/Types.pm @@ -0,0 +1,235 @@ +package YAML::Types; + +use YAML::Mo; +use YAML::Node; + +# XXX These classes and their APIs could still use some refactoring, +# but at least they work for now. +#------------------------------------------------------------------------------- +package YAML::Type::blessed; + +use YAML::Mo; # XXX + +sub yaml_dump { + my $self = shift; + my ($value) = @_; + my ($class, $type) = YAML::Mo::Object->node_info($value); + no strict 'refs'; + my $kind = lc($type) . ':'; + my $tag = ${$class . '::ClassTag'} || + "!perl/$kind$class"; + if ($type eq 'REF') { + YAML::Node->new( + {(&YAML::VALUE, ${$_[0]})}, $tag + ); + } + elsif ($type eq 'SCALAR') { + $_[1] = $$value; + YAML::Node->new($_[1], $tag); + } + elsif ($type eq 'GLOB') { + # blessed glob support is minimal, and will not round-trip + # initial aim: to not cause an error + return YAML::Type::glob->yaml_dump($value, $tag); + } else { + YAML::Node->new($value, $tag); + } +} + +#------------------------------------------------------------------------------- +package YAML::Type::undef; + +sub yaml_dump { + my $self = shift; +} + +sub yaml_load { + my $self = shift; +} + +#------------------------------------------------------------------------------- +package YAML::Type::glob; + +sub yaml_dump { + my $self = shift; + # $_[0] remains as the glob + my $tag = pop @_ if 2==@_; + + $tag = '!perl/glob:' unless defined $tag; + my $ynode = YAML::Node->new({}, $tag); + for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) { + my $value = *{$_[0]}{$type}; + $value = $$value if $type eq 'SCALAR'; + if (defined $value) { + if ($type eq 'IO') { + my @stats = qw(device inode mode links uid gid rdev size + atime mtime ctime blksize blocks); + undef $value; + $value->{stat} = YAML::Node->new({}); + if ($value->{fileno} = fileno(*{$_[0]})) { + local $^W; + map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]}); + $value->{tell} = tell(*{$_[0]}); + } + } + $ynode->{$type} = $value; + } + } + return $ynode; +} + +sub yaml_load { + my $self = shift; + my ($node, $class, $loader) = @_; + my ($name, $package); + if (defined $node->{NAME}) { + $name = $node->{NAME}; + delete $node->{NAME}; + } + else { + $loader->warn('YAML_LOAD_WARN_GLOB_NAME'); + return undef; + } + if (defined $node->{PACKAGE}) { + $package = $node->{PACKAGE}; + delete $node->{PACKAGE}; + } + else { + $package = 'main'; + } + no strict 'refs'; + if (exists $node->{SCALAR}) { + *{"${package}::$name"} = \$node->{SCALAR}; + delete $node->{SCALAR}; + } + for my $elem (qw(ARRAY HASH CODE IO)) { + if (exists $node->{$elem}) { + if ($elem eq 'IO') { + $loader->warn('YAML_LOAD_WARN_GLOB_IO'); + delete $node->{IO}; + next; + } + *{"${package}::$name"} = $node->{$elem}; + delete $node->{$elem}; + } + } + for my $elem (sort keys %$node) { + $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem); + } + return *{"${package}::$name"}; +} + +#------------------------------------------------------------------------------- +package YAML::Type::code; + +my $dummy_warned = 0; +my $default = '{ "DUMMY" }'; + +sub yaml_dump { + my $self = shift; + my $code; + my ($dumpflag, $value) = @_; + my ($class, $type) = YAML::Mo::Object->node_info($value); + my $tag = "!perl/code"; + $tag .= ":$class" if defined $class; + if (not $dumpflag) { + $code = $default; + } + else { + bless $value, "CODE" if $class; + eval { use B::Deparse }; + return if $@; + my $deparse = B::Deparse->new(); + eval { + local $^W = 0; + $code = $deparse->coderef2text($value); + }; + if ($@) { + warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W; + $code = $default; + } + bless $value, $class if $class; + chomp $code; + $code .= "\n"; + } + $_[2] = $code; + YAML::Node->new($_[2], $tag); +} + +sub yaml_load { + my $self = shift; + my ($node, $class, $loader) = @_; + if ($loader->load_code) { + my $code = eval "package main; sub $node"; + if ($@) { + $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@); + return sub {}; + } + else { + CORE::bless $code, $class if $class; + return $code; + } + } + else { + return CORE::bless sub {}, $class if $class; + return sub {}; + } +} + +#------------------------------------------------------------------------------- +package YAML::Type::ref; + +sub yaml_dump { + my $self = shift; + YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref') +} + +sub yaml_load { + my $self = shift; + my ($node, $class, $loader) = @_; + $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr') + unless exists $node->{&YAML::VALUE}; + return \$node->{&YAML::VALUE}; +} + +#------------------------------------------------------------------------------- +package YAML::Type::regexp; + +# XXX Be sure to handle blessed regexps (if possible) +sub yaml_dump { + die "YAML::Type::regexp::yaml_dump not currently implemented"; +} + +use constant _QR_TYPES => { + '' => sub { qr{$_[0]} }, + x => sub { qr{$_[0]}x }, + i => sub { qr{$_[0]}i }, + s => sub { qr{$_[0]}s }, + m => sub { qr{$_[0]}m }, + ix => sub { qr{$_[0]}ix }, + sx => sub { qr{$_[0]}sx }, + mx => sub { qr{$_[0]}mx }, + si => sub { qr{$_[0]}si }, + mi => sub { qr{$_[0]}mi }, + ms => sub { qr{$_[0]}sm }, + six => sub { qr{$_[0]}six }, + mix => sub { qr{$_[0]}mix }, + msx => sub { qr{$_[0]}msx }, + msi => sub { qr{$_[0]}msi }, + msix => sub { qr{$_[0]}msix }, +}; + +sub yaml_load { + my $self = shift; + my ($node, $class) = @_; + return qr{$node} unless $node =~ /^\(\?([\^\-xism]*):(.*)\)\z/s; + my ($flags, $re) = ($1, $2); + $flags =~ s/-.*//; + $flags =~ s/^\^//; + my $sub = _QR_TYPES->{$flags} || sub { qr{$_[0]} }; + my $qr = &$sub($re); + bless $qr, $class if length $class; + return $qr; +} + +1; |