modules/override/YAML/Types.pm

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