annotate lib/IMPL/clone.pm @ 417:3ed0c58e9da3 ref20150831

working on di container, tests
author cin
date Mon, 02 Nov 2015 01:56:53 +0300
parents c6e90e02dd17
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
407
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
1 package IMPL::clone;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
2
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
3 use Scalar::Util qw(blessed reftype refaddr);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
4
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
5 use base qw(Exporter);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
6 our @EXPORT_OK = qw(&clone);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
7
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
8 {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
9 my %handlers = (
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
10 HASH => sub {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
11 my $class = blessed($_[0]);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
12
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
13 my $new = $_[1]->{ refaddr($_[0]) } = {};
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
14 while (my ($key,$val) = each %{$_[0]}) {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
15 $new->{$key} = clone($val,$_[1]);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
16 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
17 $class ? bless $new, $class : $new;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
18 },
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
19 ARRAY => sub {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
20 my $class = blessed($_[0]);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
21
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
22 my $new = $_[1]->{ refaddr($_[0]) } = [];
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
23
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
24 push @$new, clone($_,$_[1]) foreach @{$_[0]};
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
25
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
26 $class ? bless( $new, $class ) : $new;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
27 },
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
28 SCALAR => sub {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
29 my $class = blessed($_[0]);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
30
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
31 my $v = ${$_[0]};
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
32 $class ? bless \$v, $class : \$v;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
33 },
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
34 REF => sub {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
35 my $class = blessed($_[0]);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
36 my $v;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
37 my $new = $_[1]->{ refaddr($_[0]) } = \$v;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
38 $v = clone ( ${$_[0]},$_[1] );
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
39 $class ? bless \$v, $class : \$v;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
40
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
41 },
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
42 REGEXP => sub {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
43 $_[0];
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
44 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
45 );
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
46
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
47 sub clone {
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
48 return unless @_;
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
49
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
50 return $_[0] unless ref $_[0];
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
51
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
52 return $_[1]->{refaddr($_[0])} || (UNIVERSAL::can($_[0],'_clone') || $handlers{reftype($_[0])} || sub { die "Unknown reftype " . reftype($_[0])} )->(@_);
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
53 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
54
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
55 }
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
56
c6e90e02dd17 renamed Lib->lib
cin
parents:
diff changeset
57 1;