annotate Lib/IMPL/clone.pm @ 175:9057e4b95d10

corrected cloning method
author sourcer
date Wed, 05 Oct 2011 00:48:43 +0300
parents d920d2b70230
children 47dac58691ee
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
173
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
1 package IMPL::clone;
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
2
174
d920d2b70230 minor changes
sergey
parents: 173
diff changeset
3 use Scalar::Util qw(blessed reftype refaddr);
173
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
4
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
5 use base qw(Exporter);
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
6 our @EXPORT_OK = qw(&clone);
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
7
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
8 {
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
9 my %handlers = (
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
10 HASH => sub {
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
11 my $class = blessed($_[0]);
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
12
175
9057e4b95d10 corrected cloning method
sourcer
parents: 174
diff changeset
13 my $new = $_[1]->{ refaddr($_[0]) } = {};
173
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
14 while (my ($key,$val) = each %{$_[0]}) {
174
d920d2b70230 minor changes
sergey
parents: 173
diff changeset
15 $new->{$key} = clone($val,$_[1]);
173
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
16 }
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
17 $class ? bless $new, $class : $new;
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
18 },
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
19 ARRAY => sub {
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
20 my $class = blessed($_[0]);
175
9057e4b95d10 corrected cloning method
sourcer
parents: 174
diff changeset
21
9057e4b95d10 corrected cloning method
sourcer
parents: 174
diff changeset
22 my $new = $_[1]->{ refaddr($_[0]) } = [];
9057e4b95d10 corrected cloning method
sourcer
parents: 174
diff changeset
23
9057e4b95d10 corrected cloning method
sourcer
parents: 174
diff changeset
24 push @$new, clone($_,$_[1]) foreach @{$_[0]};
9057e4b95d10 corrected cloning method
sourcer
parents: 174
diff changeset
25
9057e4b95d10 corrected cloning method
sourcer
parents: 174
diff changeset
26 $class ? bless( $new, $class ) : $new;
173
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
27 },
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
28 SCALAR => sub {
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
29 my $class = blessed($_[0]);
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
30
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
31 my $v = ${$_[0]};
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
32 $class ? bless \$v, $class : \$v;
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
33 },
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
34 REF => sub {
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
35 my $class = blessed($_[0]);
175
9057e4b95d10 corrected cloning method
sourcer
parents: 174
diff changeset
36 my $v;
9057e4b95d10 corrected cloning method
sourcer
parents: 174
diff changeset
37 my $new = $_[1]->{ refaddr($_[0]) } = \$v;
9057e4b95d10 corrected cloning method
sourcer
parents: 174
diff changeset
38 $v = clone ( ${$_[0]},$_[1] );
173
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
39 $class ? bless \$v, $class : \$v;
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
40
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
41 },
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
42 REGEXP => sub {
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
43 $_[0];
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
44 }
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
45 );
174
d920d2b70230 minor changes
sergey
parents: 173
diff changeset
46
173
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
47 sub clone {
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
48 return unless @_;
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
49
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
50 return $_[0] unless ref $_[0];
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
51
175
9057e4b95d10 corrected cloning method
sourcer
parents: 174
diff changeset
52 return $_[1]->{refaddr($_[0])} || ($handlers{reftype($_[0])} || sub { die "Unknown reftype " . reftype($_[0])} )->(@_);
173
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
53 }
174
d920d2b70230 minor changes
sergey
parents: 173
diff changeset
54
173
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
55 }
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
56
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
57 1;