|
407
|
1 package IMPL::clone;
|
|
|
2
|
|
|
3 use Scalar::Util qw(blessed reftype refaddr);
|
|
|
4
|
|
|
5 use base qw(Exporter);
|
|
|
6 our @EXPORT_OK = qw(&clone);
|
|
|
7
|
|
|
8 {
|
|
|
9 my %handlers = (
|
|
|
10 HASH => sub {
|
|
|
11 my $class = blessed($_[0]);
|
|
|
12
|
|
|
13 my $new = $_[1]->{ refaddr($_[0]) } = {};
|
|
|
14 while (my ($key,$val) = each %{$_[0]}) {
|
|
|
15 $new->{$key} = clone($val,$_[1]);
|
|
|
16 }
|
|
|
17 $class ? bless $new, $class : $new;
|
|
|
18 },
|
|
|
19 ARRAY => sub {
|
|
|
20 my $class = blessed($_[0]);
|
|
|
21
|
|
|
22 my $new = $_[1]->{ refaddr($_[0]) } = [];
|
|
|
23
|
|
|
24 push @$new, clone($_,$_[1]) foreach @{$_[0]};
|
|
|
25
|
|
|
26 $class ? bless( $new, $class ) : $new;
|
|
|
27 },
|
|
|
28 SCALAR => sub {
|
|
|
29 my $class = blessed($_[0]);
|
|
|
30
|
|
|
31 my $v = ${$_[0]};
|
|
|
32 $class ? bless \$v, $class : \$v;
|
|
|
33 },
|
|
|
34 REF => sub {
|
|
|
35 my $class = blessed($_[0]);
|
|
|
36 my $v;
|
|
|
37 my $new = $_[1]->{ refaddr($_[0]) } = \$v;
|
|
|
38 $v = clone ( ${$_[0]},$_[1] );
|
|
|
39 $class ? bless \$v, $class : \$v;
|
|
|
40
|
|
|
41 },
|
|
|
42 REGEXP => sub {
|
|
|
43 $_[0];
|
|
|
44 }
|
|
|
45 );
|
|
|
46
|
|
|
47 sub clone {
|
|
|
48 return unless @_;
|
|
|
49
|
|
|
50 return $_[0] unless ref $_[0];
|
|
|
51
|
|
|
52 return $_[1]->{refaddr($_[0])} || (UNIVERSAL::can($_[0],'_clone') || $handlers{reftype($_[0])} || sub { die "Unknown reftype " . reftype($_[0])} )->(@_);
|
|
|
53 }
|
|
|
54
|
|
|
55 }
|
|
|
56
|
|
|
57 1;
|
