view release on metacpan or  search on metacpan

lib/Class/Rebirth.pm  view on Meta::CPAN

#
#
# or 
#
#   use Class::Rebirth;
#   my $object = Class::Rebirth::rebirth( $zombie );
#
# 
# It is also able to use a data dump instead of an object.
#
#   my $object = Class::Rebirth::rebirth( $dump );
#
# 
#
# AUTHOR
# ======
# Andreas Hernitscheck  ahernit(AT)cpan.org


# @brief Takes a death object and and creates a living object of it.
# Such a zombie class looks like a normal class when you dump it.
# But it is not alive, means methods won't work. An Effect which
# happens by deserializing classes from a store (dumped data).
sub rebirth { # $object ($zombie)
  my $zombie = shift or croak "requires zombie";
  my $obj;

  # if zombie is dump string, build an object first
  if ($zombie =~ /^\$/){
    $zombie = _createObjectByDump( $zombie );
  }


  my @pkgs = _getUsedPackagesOfObject($zombie);

  foreach my $p (@pkgs){
    eval("require $p;");
    if ($@){die $@};
  }

  ## rerun an eval to realy bring it back to life
  my $target;
  my $ser = Data::Dumper->Dump([$zombie],['$target']);
  eval $ser;
  if ($@){die $@};


  return $target;
}


# Can use a data dump'ed string which
# starts with a variable assignment like $VAR1=
# @return object
sub _createObjectByDump{
  my $dump = shift;
  my $target;


  # relace var with own var
  $dump =~ s/^(\$[a-z0-9]+)/\$target/i;

  eval $dump;

  if ($@){die $@};

  return $target;
}



# Does a deep search in object for
# used package names.
# @return list of packages
sub _getUsedPackagesOfObject{
  my $obj = shift;
  my @list;


  if (Scalar::Util::blessed $obj){
    push @list, ref($obj);
  }


  foreach my $k (keys %$obj){
    my $value = $obj->{$k};

    # walk down any hash to find more blessed objects
    if (ref $obj->{$k} eq 'HASH'){

      my @sublist = _getUsedPackagesOfObject( $value );

      push @list, @sublist;
    }

    # is blessed object
    if (Scalar::Util::blessed $value){
      push @list, ref($obj);

      my @sublist = _getUsedPackagesOfObject( $value );
      push @list, @sublist;
    }  
  }

  # make unique strings
  @list = uniq @list;

  return @list;
}






1;




#################### pod generated by Pod::Autopod - keep this line to make pod updates possible ####################