view release on metacpan or  search on metacpan

scripts/dex  view on Meta::CPAN

      my $name = delete $globdata{NAME} or die "Missing NAME in perl/glob";
      my $pkg = delete $globdata{PACKAGE};
      $pkg = 'main' unless defined $pkg;
      my @allowed = qw(SCALAR ARRAY HASH CODE IO);
      delete @globdata{ @allowed };
      if (my @keys = keys %globdata) {
          die "Unexpected keys in perl/glob: @keys";
      }
      no strict 'refs';
      return *{"${pkg}::$name"};
  }
  
  sub construct_scalar {
      my ($self, $list) = @_;
      if (@$list != 2) {
          die "Unexpected data in perl/scalar construction";
      }
      my ($key, $value) = @$list;
      unless ($key eq '=') {
          die "Unexpected data in perl/scalar construction";
      }
      return $value;
  }
  
  sub construct_ref {
      &construct_scalar;
  }
  
  sub represent_scalar {
      my ($self, $value) = @_;
      return { '=' => $$value };
  }
  
  sub represent_ref {
      &represent_scalar;
  }
  
  sub represent_code {
      my ($self, $code) = @_;
      require B::Deparse;
      my $deparse = B::Deparse->new("-p", "-sC");
      return $deparse->coderef2text($code);
  }
  
  
  my @stats = qw/ device inode mode links uid gid rdev size
      atime mtime ctime blksize blocks /;
  sub represent_glob {
      my ($self, $glob) = @_;
      my %glob;
      for my $type (qw/ PACKAGE NAME SCALAR ARRAY HASH CODE IO /) {
          my $value = *{ $glob }{ $type };
          if ($type eq 'SCALAR') {
              $value = $$value;
          }
          elsif ($type eq 'IO') {
              if (defined $value) {
                  undef $value;
                  $value->{stat} = {};
                  if ($value->{fileno} = fileno(*{ $glob })) {
                      @{ $value->{stat} }{ @stats } = stat(*{ $glob });
                      $value->{tell} = tell *{ $glob };
                  }
              }
          }
          $glob{ $type } = $value if defined $value;
      }
      return \%glob;
  }
  
  sub represent_regex {
      my ($self, $regex) = @_;
      $regex = "$regex";
      if ($regex =~ m/^$qr_prefix(.*)\)\z/s) {
          $regex = $1;
      }
      return $regex;
  }
  
  sub object {
      my ($self, $data, $class) = @_;
      return bless $data, $class;
  }
  
  1;
  
  __END__
  
  =pod
  
  =encoding utf-8
  
  =head1 NAME
  
  YAML::PP::Schema::Perl - Schema for serializing perl objects and special types
  
  =head1 SYNOPSIS
  
      use YAML::PP;
      # This can be dangerous when loading untrusted YAML!
      my $yp = YAML::PP->new( schema => [qw/ + Perl /] );
      # or
      my $yp = YAML::PP->new( schema => [qw/ Core Perl /] );
      my $yaml = $yp->dump_string(sub { return 23 });
  
      # loading code references
      # This is very dangerous when loading untrusted YAML!!
      my $yp = YAML::PP->new( schema => [qw/ + Perl +loadcode /] );
      my $code = $yp->load_string(<<'EOM');
      --- !perl/code |
          {
              use 5.010;
              my ($name) = @_;
              say "Hello $name!";
          }
      EOM
      $code->("Ingy");
  
  =head1 DESCRIPTION
  
  This schema allows you to load and dump perl objects and special types.