annotate Lib/IMPL/clone.pm @ 270:3f59fd828d5f

merge
author cin
date Fri, 25 Jan 2013 00:25:02 +0400
parents 4d0e1962161c
children
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 {
194
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
9 my %handlers = (
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
10 HASH => sub {
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
11 my $class = blessed($_[0]);
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
12
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
13 my $new = $_[1]->{ refaddr($_[0]) } = {};
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
14 while (my ($key,$val) = each %{$_[0]}) {
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
15 $new->{$key} = clone($val,$_[1]);
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
16 }
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
17 $class ? bless $new, $class : $new;
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
18 },
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
19 ARRAY => sub {
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
20 my $class = blessed($_[0]);
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
21
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
22 my $new = $_[1]->{ refaddr($_[0]) } = [];
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
23
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
24 push @$new, clone($_,$_[1]) foreach @{$_[0]};
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
25
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
26 $class ? bless( $new, $class ) : $new;
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
27 },
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
28 SCALAR => sub {
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
29 my $class = blessed($_[0]);
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
30
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
31 my $v = ${$_[0]};
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
32 $class ? bless \$v, $class : \$v;
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
33 },
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
34 REF => sub {
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
35 my $class = blessed($_[0]);
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
36 my $v;
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
37 my $new = $_[1]->{ refaddr($_[0]) } = \$v;
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
38 $v = clone ( ${$_[0]},$_[1] );
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
39 $class ? bless \$v, $class : \$v;
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
40
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
41 },
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
42 REGEXP => sub {
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
43 $_[0];
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
44 }
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
45 );
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
46
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
47 sub clone {
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
48 return unless @_;
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
49
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
50 return $_[0] unless ref $_[0];
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
51
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
52 return $_[1]->{refaddr($_[0])} || (UNIVERSAL::can($_[0],'_clone') || $handlers{reftype($_[0])} || sub { die "Unknown reftype " . reftype($_[0])} )->(@_);
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
diff changeset
53 }
4d0e1962161c Replaced tabs with spaces
cin
parents: 181
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;