home *** CD-ROM | disk | FTP | other *** search
/ PC Professionell 2004 December / PCpro_2004_12.ISO / files / webserver / xampp / xampp-perl-addon-1.4.9-installer.exe / Transfer.pm < prev    next >
Encoding:
Perl POD Document  |  2002-06-24  |  2.8 KB  |  101 lines
  1. package YAML::Transfer;
  2. use strict;
  3.  
  4. use YAML::Node;
  5.  
  6. package YAML::Transfer::glob;
  7. sub yaml_dump {
  8.     my $ynode = YAML::Node->new({}, 'perl/glob:');
  9.     for my $type (qw(PACKAGE NAME SCALAR ARRAY HASH CODE IO)) {
  10.         my $value = *{$_[0]}{$type};
  11.         $value = $$value if $type eq 'SCALAR';
  12.         if (defined $value) {
  13.             if ($type eq 'IO') {
  14.                 my @stats = qw(device inode mode links uid gid rdev size
  15.                                atime mtime ctime blksize blocks);
  16.                 undef $value;
  17.                 $value->{stat} = YAML::Node->new({});
  18.                 map {$value->{stat}{shift @stats} = $_} stat(*{$_[0]});
  19.                 $value->{fileno} = fileno(*{$_[0]});
  20.                 {
  21.                     local $^W;
  22.                     $value->{tell} = tell(*{$_[0]});
  23.                 }
  24.             }
  25.             $ynode->{$type} = $value; 
  26.         }
  27.     }
  28.     return $ynode;
  29. }
  30.  
  31. package YAML::Transfer::blessed;
  32. my %sigil = (HASH => '', ARRAY => '@', SCALAR => '$');
  33. sub yaml_dump {
  34.     my ($value) = @_;
  35.     my ($class, $type) = YAML::Node::info($value);
  36.     my $family = "perl/$sigil{$type}$class";
  37.     if ($type eq 'SCALAR') {
  38.         $_[1] = $$value;
  39.         YAML::Node->new($_[1], $family)
  40.     } else {
  41.         YAML::Node->new($value, $family)
  42.     }
  43. }
  44.  
  45. package YAML::Transfer::code;
  46. my $dummy_warned = 0; 
  47. my $default = '{ "DUMMY" }';
  48. sub yaml_dump {
  49.     my $code;
  50.     my ($dumpflag, $value) = @_;
  51.     my ($class, $type) = YAML::Node::info($value);
  52.     $class ||= '';
  53.     my $family = "perl/code:$class";
  54.     if (not $dumpflag) {
  55.         $code = $default;
  56.     }
  57.     else {
  58.         bless $value, "CODE" if $class;
  59.         eval "use B::Deparse";
  60.         my $deparse = B::Deparse->new();
  61.         eval {
  62.             local $^W = 0;
  63.             $code = $deparse->coderef2text($value);
  64.         };
  65.         if ($@) {
  66.             warn YAML::YAML_DUMP_WARN_DEPARSE_FAILED() if $^W;
  67.             $code = $default;
  68.         }
  69.         bless $value, $class if $class;
  70.         chomp $code;
  71.         $code .= "\n";
  72.     }
  73.     $_[2] = $code;
  74.     YAML::Node->new($_[2], $family);
  75. }    
  76.  
  77. package YAML::Transfer::ref;
  78. sub yaml_dump {
  79.     YAML::Node->new({(&YAML::VALUE, ${$_[0]})}, 'perl/ref:')
  80. }
  81.  
  82. package YAML::Transfer::regexp;
  83. # XXX Be sure to handle blessed regexps (if possible)
  84. sub yaml_dump {
  85.     my ($value) = @_;
  86.     my ($regexp, $modifiers);
  87.     if ("$value" =~ /^\(\?(\w*)(?:\-\w+)?\:(.*)\)$/) {
  88.         $regexp = $2;
  89.         $modifiers = $1 || '';
  90.     }
  91.     else {
  92.         croak YAML::YAML_DUMP_ERR_BAD_REGEXP($value);
  93.     }
  94.     my $ynode = YAML::Node->new({}, 'perl/regexp:');
  95.     $ynode->{REGEXP} = $regexp; 
  96.     $ynode->{MODIFIERS} = $modifiers if $modifiers; 
  97.     return $ynode;
  98. }
  99.  
  100. 1;
  101.