view Lib/IMPL/clone.pm @ 178:658a80d19d33

new constructor syntax
author sourcer
date Wed, 12 Oct 2011 00:06:07 +0300
parents 9057e4b95d10
children 47dac58691ee
line wrap: on
line source

package IMPL::clone;

use Scalar::Util qw(blessed reftype refaddr);

use base qw(Exporter);
our @EXPORT_OK = qw(&clone);

{
	my %handlers = (
		HASH => sub {
			my $class = blessed($_[0]);
			
			my $new = $_[1]->{ refaddr($_[0]) } = {};
			while (my ($key,$val) = each %{$_[0]}) {
				$new->{$key} = clone($val,$_[1]);
			}
			$class ? bless $new, $class : $new;
		},
		ARRAY => sub {
			my $class = blessed($_[0]);
			
			my $new = $_[1]->{ refaddr($_[0]) } = [];
			
			push @$new, clone($_,$_[1]) foreach @{$_[0]};
			
			$class ? bless( $new, $class ) : $new;
		},
		SCALAR => sub {
			my $class = blessed($_[0]);
			
			my $v = ${$_[0]};
			$class ? bless \$v, $class : \$v;
		},
		REF => sub {
			my $class = blessed($_[0]);
			my $v;
			my $new = $_[1]->{ refaddr($_[0]) } = \$v;
			$v = clone ( ${$_[0]},$_[1] );
			$class ? bless \$v, $class : \$v;
			
		},
		REGEXP => sub {
			$_[0];
		}
	);
	
	sub clone {
		return unless @_;
		
		return $_[0] unless ref $_[0];
		
		return $_[1]->{refaddr($_[0])} || ($handlers{reftype($_[0])} || sub { die "Unknown reftype " . reftype($_[0])} )->(@_);
	}
	
}

1;