view release on metacpan or  search on metacpan

lib/Data/Rebuilder.pm  view on Meta::CPAN

use strict;
use warnings;
package Data::Rebuilder;

=head1 NAME

Data::Rebuilder - Builds an object rebuilder.

=head1 VERSION

Version 0.01

=cut

our $VERSION = '0.01';

=head1 SYNOPSIS

  ###
  ### freeze composite ...
  ###
  
  my $builder = Data::Rebuilder->new;
  $builder->parameterize( driver => $driver );
  $builder->parameterize( user   => $user );
  my $icy_compsite = $builder->build_rebulder( $composite );
  
  ###
  ### restore composite with current context ...
  ###
  
  my $builder = eval $icy_composite;
  my $melted_composite = $builder->( driver => $driver,
                                     user   => $user );

=head1 DESCRIPTION

This approach is like to C<Data::Dumper> approach. Moreover,
an output of this module is not easy to read.

However this solution can rebuild tied values, weak references, 
and closures.
In addition, this solution can parameterize 
arbitrary nodes of composite. Users can give new objects as 
arguments of the subroutine which is result.

=cut

use B;
use Scalar::Util qw( isweak refaddr blessed looks_like_number);
use UNIVERSAL qw(isa  can);
use Carp;
use Sub::Name;
use Path::Class;
use Lexical::Alias;
use B::Deparse;
use PadWalker;
use Data::Polymorph;


=head1 STATIC METHODS

=over 4

=item safe_require

  safe_require ( $0 );                                # does not load
  safe_require ( Path::Class::file( $0 )->absolute ); # does not load
  safe_require ( 'path/to/module.pm' );               # loads
  safe_require ( '/absolute/path/to/module.pm');      # does not load

Loads module safery.

=cut


{
  my %loaded = ();
  sub safe_require ($){
    my $lib = shift;
    my $libabs = file($lib)->absolute;
    return if $loaded{$libabs};
    return if $libabs eq file($0)->absolute;
    $loaded{$libabs} = 1;
    require $lib unless grep{ $libabs eq file($_)->absolute } values %INC;
  }
}

sub _indent ($) {
  local $_ = shift;
  s/\n/\n  /mg;
  $_;
}

{ ############################################################
  package Data::Rebuilder::B::Deparse;
  our @ISA = qw( B::Deparse );

  sub coderef2textX{
    my $self = shift;
    my $code = $self->coderef2text( @_ );
    (
     globals => [ keys %{$self->{' globals '}} ],
     stashes => [ keys %{$self->{' stashes '}} ],
     code    => $code
    );
  }

  {
    my %globalnames =
      map (($_ => 1), qw(SIG STDIN STDOUT STDERR INC ENV ARGV ARGVOUT _));

    sub gv_name {
      my $self = shift;
      my $gv = shift;
      Carp::confess() unless ref($gv) eq "B::GV";
      my $stash = $gv->STASH->NAME;

lib/Data/Rebuilder.pm  view on Meta::CPAN

           },
          );


        my %freezer =
          (
           ###
           Any   => sub{ confess "caught unsupported type." },

           ###
           Undef => sub{ 'undef' },

           ###
           'Str' => sub{ B::perlstring( $_[0] ) },

           ###
           'Num' => sub{ $_[0] },

           ###
           'Glob' => sub{
             my $obj  = shift;
             my $name = "" . $obj;
             return "$name" unless $name =~ /^\*Symbol::GEN/;
             join("\n",
                  'do{',
                  '  # GrobRef',
                  '  require Symbol;',
                  '  my $__tmp = Symbol::gensym();',
                  ( map {
                    ( *{$obj}{$_}
                      ? ( sprintf('  *{$__tmp} = %s;',
                                  $self->freeze(*{$obj}{$_})) )
                      : () )
                    } qw( SCALAR
                          ARRAY
                          HASH
                          CODE )),
                  '  *$__tmp;',
                  '}' );
           },

           ###
           'ScalarRef' => sub{
             my $obj = shift;
             join( "\n",
                   'do{',
                   '  #ScalarRef',
                   '  my $__tmp = '.$self->freeze($$obj).';',
                   '  \\$__tmp;',
                   '}' );
           },

           #################################
           'CodeRef' => sub{
             my $cv     = shift;
             my $target = shift || $cv;
             my $var    = $self->ref_to_var($target);

             my $dp     =  ( $self->{_deparse}
                             ||= (__PACKAGE__."::B::Deparse")->new );
             my $closed = PadWalker::closed_over( $cv );
             my $b      = B::svref_2object($cv);
             my $name   = $b->GV->NAME;
             my @vars   = ();

             foreach my $key (keys %$closed) {

               my $val = $closed->{$key};

               if( $self->poly->type($val) eq 'RefRef' &&
                   $self->_is_cycled($$val)) {
                 push @vars,
                   sprintf('  my %s = undef; #cycled RefRef', $key);
                 my $lazy = $self->_lazy->{refaddr $$val} ||= [];

                 push
                   (@$lazy,
                    'require PadWalker;',
                    sprintf('${PadWalker::closed_over(%s)->{%s}} = %s;',
                            $var,
                            $self->freeze($key),
                            $self->freeze($$val))
                    );
               }
               else {
                 push( @vars,
                       sprintf ( "  my \%s = undef;\n".
                                 '  Lexical::Alias::alias_r( %s , \%s );',
                                 $key,
                                 $self->freeze($val),
                                 $key ) );
               }

             }

             my %info = $dp->coderef2textX($cv);

             foreach my $stash ( $b->STASH->NAME , @{$info{stashes}} ){
               $self->_stashes->{$stash} = 1;
             }

             join( "\n",
                   "do{",
                   '  # CodeRef',
                   (map{ sprintf('  %s = %s;',$_,$_) }@{$info{globals}}),
                   ( @vars ? '  require Lexical::Alias;' : () ),
                   @vars,
                   sprintf('  sub %s', _indent $info{code}),
                   "}",
                 );
           },

           #################################
           'ArrayRef' => sub{

             my $ref    = shift;
             my $target = shift || $ref;
             my $var    = $self->ref_to_var($target);

             my @body = ();
             my @tied = ();
             my @weak = ();
             local $_;

             for( my $i = 0; $i < @{$ref} ; $i++ ) {
               my $v = $ref->[$i];
               my $tied = tied ( $ref->[$i] );
               push @body, sprintf('    # %s', refaddr( \$ref->[$i] ));
               if( $tied ){

                 push @body, "    undef,";
                 push @tied , [$i => $tied];

               }
               elsif( $self->_is_cycled($v) ) {

                 push @body, "    undef,";
                 my $lazy = $self->_lazy->{ refaddr $v } ||= [];
                 push( @$lazy ,