modules/override/YAML/Types.pm

   1 package YAML::Types;
   2 use strict; use warnings;
   3 use YAML::Base; use base 'YAML::Base';
   4 use YAML::Node;
   5
   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;
  10 use YAML::Base; # XXX
  11 sub yaml_dump {
  12     my $self = shift;
  13     my ($value) = @_;
  14     my ($class, $type) = YAML::Base->node_info($value);
  15     no strict 'refs';
  16     my $kind = lc($type) . ':';
  17     my $tag = ${$class . '::ClassTag'} ||
  18               "!perl/$kind$class";
  19     if ($type eq 'REF') {
  20         YAML::Node->new(
  21             {(&YAML::VALUE, ${$_[0]})}, $tag
  22         );
  23     }
  24     elsif ($type eq 'SCALAR') {
  25         $_[1] = $$value;
  26         YAML::Node->new($_[1], $tag);
  27     } else {
  28         YAML::Node->new($value, $tag);
  29     }
  30 }
  31
  32 #-------------------------------------------------------------------------------
  33 package YAML::Type::undef;
  34 sub yaml_dump {
  35     my $self = shift;
  36 }
  37
  38 sub yaml_load {
  39     my $self = shift;
  40 }
  41
  42 #-------------------------------------------------------------------------------
  43 package YAML::Type::glob;
  44 sub yaml_dump {
  45     my $self = shift;
  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';
  50         if (defined $value) {
  51             if ($type eq 'IO') {
  52                 my @stats = qw(device inode mode links uid gid rdev size
  53                                atime mtime ctime blksize blocks);
  54                 undef $value;
  55                 $value->{stat} = YAML::Node->new({});
  56                 map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
  57                 $value->{fileno} = fileno(*{$_[0]});
  58                 {
  59                     local $^W;
  60                     $value->{tell} = tell(*{$_[0]});
  61                 }
  62             }
  63             $ynode->{$type} = $value;
  64         }
  65     }
  66     return $ynode;
  67 }
  68
  69 sub yaml_load {
  70     my $self = shift;
  71     my ($node, $class, $loader) = @_;
  72     my ($name, $package);
  73     if (defined $node->{NAME}) {
  74         $name = $node->{NAME};
  75         delete $node->{NAME};
  76     }
  77     else {
  78         $loader->warn('YAML_LOAD_WARN_GLOB_NAME');
  79         return undef;
  80     }
  81     if (defined $node->{PACKAGE}) {
  82         $package = $node->{PACKAGE};
  83         delete $node->{PACKAGE};
  84     }
  85     else {
  86         $package = 'main';
  87     }
  88     no strict 'refs';
  89     if (exists $node->{SCALAR}) {
  90         *{"${package}::$name"} = \$node->{SCALAR};
  91         delete $node->{SCALAR};
  92     }
  93     for my $elem (qw(ARRAY HASH CODE IO)) {
  94         if (exists $node->{$elem}) {
  95             if ($elem eq 'IO') {
  96                 $loader->warn('YAML_LOAD_WARN_GLOB_IO');
  97                 delete $node->{IO};
  98                 next;
  99             }
 100             *{"${package}::$name"} = $node->{$elem};
 101             delete $node->{$elem};
 102         }
 103     }
 104     for my $elem (sort keys %$node) {
 105         $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem);
 106     }
 107     return *{"${package}::$name"};
 108 }
 109
 110 #-------------------------------------------------------------------------------
 111 package YAML::Type::code;
 112 my $dummy_warned = 0;
 113 my $default = '{ "DUMMY" }';
 114 sub yaml_dump {
 115     my $self = shift;
 116     my $code;
 117     my ($dumpflag, $value) = @_;
 118     my ($class, $type) = YAML::Base->node_info($value);
 119     $class ||= '';
 120     my $tag = "!perl/code:$class";
 121     if (not $dumpflag) {
 122         $code = $default;
 123     }
 124     else {
 125         bless $value, "CODE" if $class;
 126         eval { use B::Deparse };
 127         return if $@;
 128         my $deparse = B::Deparse->new();
 129         eval {
 130             local $^W = 0;
 131             $code = $deparse->coderef2text($value);
 132         };
 133         if ($@) {
 134             warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W;
 135             $code = $default;
 136         }
 137         bless $value, $class if $class;
 138         chomp $code;
 139         $code .= "\n";
 140     }
 141     $_[2] = $code;
 142     YAML::Node->new($_[2], $tag);
 143 }
 144
 145 sub yaml_load {
 146     my $self = shift;
 147     my ($node, $class, $loader) = @_;
 148     if ($loader->load_code) {
 149         my $code = eval "package main; sub $node";
 150         if ($@) {
 151             $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@);
 152             return sub {};
 153         }
 154         else {
 155             CORE::bless $code, $class if $class;
 156             return $code;
 157         }
 158     }
 159     else {
 160         return sub {};
 161     }
 162 }
 163
 164 #-------------------------------------------------------------------------------
 165 package YAML::Type::ref;
 166 sub yaml_dump {
 167     my $self = shift;
 168     YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref:')
 169 }
 170
 171 sub yaml_load {
 172     my $self = shift;
 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};
 177 }
 178
 179 #-------------------------------------------------------------------------------
 180 package YAML::Type::regexp;
 181 # XXX Be sure to handle blessed regexps (if possible)
 182 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;
 199 }
 200
 201 sub yaml_load {
 202     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};
 226 }
 227
 228 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