local-lib5/lib/perl5/YAML/Types.pm

   1 package YAML::Types;
   2
   3 use strict;
   4 use warnings;
   5 use YAML::Base;
   6 use YAML::Node;
   7
   8 our $VERSION = '0.70';
   9 our @ISA     = 'YAML::Base';
  10
  11 # XXX These classes and their APIs could still use some refactoring,
  12 # but at least they work for now.
  13 #-------------------------------------------------------------------------------
  14 package YAML::Type::blessed;
  15
  16 use YAML::Base; # XXX
  17
  18 sub yaml_dump {
  19     my $self = shift;
  20     my ($value) = @_;
  21     my ($class, $type) = YAML::Base->node_info($value);
  22     no strict 'refs';
  23     my $kind = lc($type) . ':';
  24     my $tag = ${$class . '::ClassTag'} ||
  25               "!perl/$kind$class";
  26     if ($type eq 'REF') {
  27         YAML::Node->new(
  28             {(&YAML::VALUE, ${$_[0]})}, $tag
  29         );
  30     }
  31     elsif ($type eq 'SCALAR') {
  32         $_[1] = $$value;
  33         YAML::Node->new($_[1], $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     my $ynode = YAML::Node->new({}, '!perl/glob:');
  56     for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
  57         my $value = *{$_[0]}{$type};
  58         $value = $$value if $type eq 'SCALAR';
  59         if (defined $value) {
  60             if ($type eq 'IO') {
  61                 my @stats = qw(device inode mode links uid gid rdev size
  62                                atime mtime ctime blksize blocks);
  63                 undef $value;
  64                 $value->{stat} = YAML::Node->new({});
  65                 map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
  66                 $value->{fileno} = fileno(*{$_[0]});
  67                 {
  68                     local $^W;
  69                     $value->{tell} = tell(*{$_[0]});
  70                 }
  71             }
  72             $ynode->{$type} = $value;
  73         }
  74     }
  75     return $ynode;
  76 }
  77
  78 sub yaml_load {
  79     my $self = shift;
  80     my ($node, $class, $loader) = @_;
  81     my ($name, $package);
  82     if (defined $node->{NAME}) {
  83         $name = $node->{NAME};
  84         delete $node->{NAME};
  85     }
  86     else {
  87         $loader->warn('YAML_LOAD_WARN_GLOB_NAME');
  88         return undef;
  89     }
  90     if (defined $node->{PACKAGE}) {
  91         $package = $node->{PACKAGE};
  92         delete $node->{PACKAGE};
  93     }
  94     else {
  95         $package = 'main';
  96     }
  97     no strict 'refs';
  98     if (exists $node->{SCALAR}) {
  99         *{"${package}::$name"} = \$node->{SCALAR};
 100         delete $node->{SCALAR};
 101     }
 102     for my $elem (qw(ARRAY HASH CODE IO)) {
 103         if (exists $node->{$elem}) {
 104             if ($elem eq 'IO') {
 105                 $loader->warn('YAML_LOAD_WARN_GLOB_IO');
 106                 delete $node->{IO};
 107                 next;
 108             }
 109             *{"${package}::$name"} = $node->{$elem};
 110             delete $node->{$elem};
 111         }
 112     }
 113     for my $elem (sort keys %$node) {
 114         $loader->warn('YAML_LOAD_WARN_BAD_GLOB_ELEM', $elem);
 115     }
 116     return *{"${package}::$name"};
 117 }
 118
 119 #-------------------------------------------------------------------------------
 120 package YAML::Type::code;
 121
 122 my $dummy_warned = 0;
 123 my $default = '{ "DUMMY" }';
 124
 125 sub yaml_dump {
 126     my $self = shift;
 127     my $code;
 128     my ($dumpflag, $value) = @_;
 129     my ($class, $type) = YAML::Base->node_info($value);
 130     my $tag = "!perl/code";
 131     $tag .= ":$class" if defined $class;
 132     if (not $dumpflag) {
 133         $code = $default;
 134     }
 135     else {
 136         bless $value, "CODE" if $class;
 137         eval { use B::Deparse };
 138         return if $@;
 139         my $deparse = B::Deparse->new();
 140         eval {
 141             local $^W = 0;
 142             $code = $deparse->coderef2text($value);
 143         };
 144         if ($@) {
 145             warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W;
 146             $code = $default;
 147         }
 148         bless $value, $class if $class;
 149         chomp $code;
 150         $code .= "\n";
 151     }
 152     $_[2] = $code;
 153     YAML::Node->new($_[2], $tag);
 154 }
 155
 156 sub yaml_load {
 157     my $self = shift;
 158     my ($node, $class, $loader) = @_;
 159     if ($loader->load_code) {
 160         my $code = eval "package main; sub $node";
 161         if ($@) {
 162             $loader->warn('YAML_LOAD_WARN_PARSE_CODE', $@);
 163             return sub {};
 164         }
 165         else {
 166             CORE::bless $code, $class if $class;
 167             return $code;
 168         }
 169     }
 170     else {
 171         return CORE::bless sub {}, $class if $class;
 172         return sub {};
 173     }
 174 }
 175
 176 #-------------------------------------------------------------------------------
 177 package YAML::Type::ref;
 178
 179 sub yaml_dump {
 180     my $self = shift;
 181     YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, '!perl/ref')
 182 }
 183
 184 sub yaml_load {
 185     my $self = shift;
 186     my ($node, $class, $loader) = @_;
 187     $loader->die('YAML_LOAD_ERR_NO_DEFAULT_VALUE', 'ptr')
 188       unless exists $node->{&YAML::VALUE};
 189     return \$node->{&YAML::VALUE};
 190 }
 191
 192 #-------------------------------------------------------------------------------
 193 package YAML::Type::regexp;
 194
 195 # XXX Be sure to handle blessed regexps (if possible)
 196 sub yaml_dump {
 197     die "YAML::Type::regexp::yaml_dump not currently implemented";
 198 }
 199
 200 use constant _QR_TYPES => {
 201     '' => sub { qr{$_[0]} },
 202     x => sub { qr{$_[0]}x },
 203     i => sub { qr{$_[0]}i },
 204     s => sub { qr{$_[0]}s },
 205     m => sub { qr{$_[0]}m },
 206     ix => sub { qr{$_[0]}ix },
 207     sx => sub { qr{$_[0]}sx },
 208     mx => sub { qr{$_[0]}mx },
 209     si => sub { qr{$_[0]}si },
 210     mi => sub { qr{$_[0]}mi },
 211     ms => sub { qr{$_[0]}sm },
 212     six => sub { qr{$_[0]}six },
 213     mix => sub { qr{$_[0]}mix },
 214     msx => sub { qr{$_[0]}msx },
 215     msi => sub { qr{$_[0]}msi },
 216     msix => sub { qr{$_[0]}msix },
 217 };
 218
 219 sub yaml_load {
 220     my $self = shift;
 221     my ($node, $class) = @_;
 222     return qr{$node} unless $node =~ /^\(\?([\-xism]*):(.*)\)\z/s;
 223     my ($flags, $re) = ($1, $2);
 224     $flags =~ s/-.*//;
 225     my $sub = _QR_TYPES->{$flags} || sub { qr{$_[0]} };
 226     my $qr = &$sub($re);
 227     bless $qr, $class if length $class;
 228     return $qr;
 229 }
 230
 231 1;
 232
 233 __END__
 234
 235 =head1 NAME
 236
 237 YAML::Types - Marshall Perl internal data types to/from YAML
 238
 239 =head1 SYNOPSIS
 240
 241     $::foo = 42;
 242     print YAML::Dump(*::foo);
 243
 244     print YAML::Dump(qr{match me});
 245
 246 =head1 DESCRIPTION
 247
 248 This module has the helper classes for transferring objects,
 249 subroutines, references, globs, regexps and file handles to and
 250 from YAML.
 251
 252 =head1 AUTHOR
 253
 254 Ingy döt Net <ingy@cpan.org>
 255
 256 =head1 COPYRIGHT
 257
 258 Copyright (c) 2006. Ingy döt Net. All rights reserved.
 259
 260 This program is free software; you can redistribute it and/or modify it
 261 under the same terms as Perl itself.
 262
 263 See L<http://www.perl.com/perl/misc/Artistic.html>
 264
 265 =cut