view release on metacpan or  search on metacpan

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

package Class::Cloneable;

use strict;
use warnings;

our $VERSION = '0.03';

sub clone {
    my ($self) = @_;
    return Class::Cloneable::Util::clone($self);
}

package Class::Cloneable::Util;

use strict;
use warnings;

use overload ();
use Carp qw(confess);
use Scalar::Util qw(blessed reftype weaken isweak);

our $VERSION = '0.03';

sub clone {
    (UNIVERSAL::isa((caller)[0], 'Class::Cloneable') || 
     UNIVERSAL::isa((caller)[0], 'Class::Cloneable::Util')) 
        || confess "Illegal Operation : This method can only be called by a subclass of Class::Cloneable";        
    my ($to_clone, $cache) = @_;
    (defined($to_clone)) 
        || confess "Insufficient Arguments : Must specify the object to clone";    
    # To start with, non-reference values are
    # not copied, just returned, cache or not
    return $to_clone unless ref($to_clone);
    # now check for an active cache
    unless(defined $cache) {
        # now we check to see what we have,
        # and deconstruct and deep copy the 
        # top-level Class::Cloneable objects
        if (blessed($to_clone) && $to_clone->isa('Class::Cloneable')) {
            # now copy the object's internals and
            # bless the new clone into the right class
            # storing it in the cache case we run 
            # into a circular ref
            return $cache->{$to_clone} = bless(
                cloneRef($to_clone, ($cache = {}), reftype($to_clone)), 
                blessed($to_clone)
            );    
        }
        # if it is not a Class::Cloneable, then 
        # we just proceed as normal
    }
    # if we have it in the cache them return the cached clone
    return $cache->{$to_clone} if exists $cache->{$to_clone};
    # now try it as an object, which will in
    # turn try it as ref if its not an object
    # now store it in case we run into a circular ref
    return $cache->{$to_clone} = cloneObject($to_clone, $cache);    
}

sub cloneObject {
    (UNIVERSAL::isa((caller)[0], 'Class::Cloneable') || 
     UNIVERSAL::isa((caller)[0], 'Class::Cloneable::Util')) 
        || confess "Illegal Operation : This method can only be called by a subclass of Class::Cloneable"; 
    my ($to_clone, $cache) = @_;
    (ref($to_clone) && (ref($cache) && ref($cache) eq 'HASH')) 
        || confess "Insufficient Arguments : Must specify the object to clone and a valid cache";    
    # check to see if we have an Class::Cloneable object,
    # or check to see if its an object, with a clone method    
    if (blessed($to_clone)) {
        # note, we want to be sure to respect any overriding of
        # the clone method with Class::Cloneable objects here
        # otherwise it would be faster to just send it directly
        # to the Class::Cloneable::Util::clone function above
        return $cache->{$to_clone} = ($to_clone->can('clone') ? 
                    $to_clone->clone()
                    : 
                    # or if we have an object, with no clone method, then
                    # we will respect its encapsulation, and not muck with 
                    # its internals. Basically, we assume it does not want
                    # to be cloned                    
                    $to_clone);
    }
    # if all else fails, it is likely a basic ref
    return $cache->{$to_clone} = cloneRef($to_clone, $cache);     
}

sub cloneRef {
    (UNIVERSAL::isa((caller)[0], 'Class::Cloneable') || 
     UNIVERSAL::isa((caller)[0], 'Class::Cloneable::Util')) 
        || confess "Illegal Operation : This method can only be called by a subclass of Class::Cloneable"; 
    my ($to_clone, $cache, $ref_type) = @_;
    (ref($to_clone) && (ref($cache) && ref($cache) eq 'HASH')) 
        || confess "Insufficient Arguments : Must specify the object to clone and a valid cache";        
    $ref_type = ref($to_clone) unless defined $ref_type;
    # check if it is weakened
    my $is_weak;
    $is_weak = 1 if isweak($to_clone);    
    my ($clone, $tied);
    if ($ref_type eq 'HASH') {
        $clone = {};
        tie %{$clone}, ref $tied if $tied = tied(%{$to_clone});
        %{$clone} = map { ref($_) ? clone($_, $cache) : $_ } %{$to_clone};
    } 
    elsif ($ref_type eq 'ARRAY') {
        $clone = [];
        tie @{$clone}, ref $tied if $tied = tied(@{$to_clone});
        @{$clone} = map { ref($_) ? clone($_, $cache) : $_ } @{$to_clone};
    } 
    elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') {
        my $var = "";
        $clone = \$var;
        tie ${$clone}, ref $tied if $tied = tied(${$to_clone});
        ${$clone} = clone(${$to_clone}, $cache);
    } 
    else {
        # shallow copy reference to code, glob, regex
        $clone = $to_clone;
    }
    # store it in our cache
    $cache->{$to_clone} = $clone;
    # and weaken it if appropriate
    weaken($clone) if $is_weak;
    # and return the clone
    return $clone;    
}

1;

__END__

=head1 NAME

Class::Cloneable - A base class for Cloneable objects.

=head1 SYNOPSIS

  package MyObject;
  our @ISA = ('Class::Cloneable');

  # calling clone on an instance of MyObject 
  # will give you full deep-cloning functionality

=head1 DESCRIPTION

This module provides a flexible base class for building objects with cloning capabilities. This module does it's best to respect the encapsulation of all other objects, including subclasses of itself. This is intended to be a stricter and more OO-ish...

=head1 METHODS

=head2 Public Method

=over 4

=item B<clone>

This provided method will deep copy itself and return the clone, while respecting the encapsulation of any objects contained within itself. 

For the most part, this will just "I<do the right thing>" and can be used as-is. If however, you need a more specialized approach, see the section below for details on how you can override and customize this methods functionality.

=back

=head2 Inner Package

Class::Cloneable::Util is a protected inner package, meaning that it can only be used by Class::Cloneable or it's subclasses. If an attempt is made to use it outside of that context, an exception is thrown. 

This inner package is provided as a means of performing fine grained custom cloning operations for users who choose to or need to override the C<clone> method provided by Class::Cloneable. Here is a basic example:

  package MyMoreComplexObject;
  our @ISA = ('Class::Cloneable');
  
  sub clone {
    my ($self) = @_;
    my $clone = {};
    $clone->{dont_clone_this} = $self->{dont_clone_this};
    $clone->{clone_this} = Class::Cloneable::Util::clone($self->{clone_this});
    return bless $clone, ref($self);
  }

B<NOTE:> Many of the functions provided in this package require a C<$cache> argument, which is a HASH reference that is used internally to keep track of the items already cloned to avoid cloning any circular references more than once. The only functi...

=over 4

=item B<clone ($to_clone, $cache)>