File Coverage

blib/lib/Class/Cloneable.pm

Criterion	Covered	Total	%
statement	74	74	100.0
branch	44	46	95.6
condition	25	27	92.5
subroutine	11	11	100.0
pod	1	1	100.0
total	155	159	97.4

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__