annotate Lib/IMPL/clone.pm @ 173:aaab45153411

minor bugfixes
author sourcer
date Wed, 14 Sep 2011 18:59:01 +0400
parents
children d920d2b70230
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
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
3 use Scalar::Util qw(blessed reftype);
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
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
13 my $new = {};
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
14 while (my ($key,$val) = each %{$_[0]}) {
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
15 $new->{$key} = clone($val);
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]);
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
21 $class ? bless( [ map clone($_), @{$_[0]} ], $class ) : [ map clone($_), @{$_[0]} ];
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
22 },
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
23 SCALAR => sub {
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
24 my $class = blessed($_[0]);
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
25
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
26 my $v = ${$_[0]};
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
27 $class ? bless \$v, $class : \$v;
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
28 },
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
29 REF => sub {
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
30 my $class = blessed($_[0]);
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
31 my $v = clone ( ${$_[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 },
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
35 REGEXP => sub {
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
36 $_[0];
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
37 }
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
38 );
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
39 sub clone {
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
40 return unless @_;
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
41
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
42 return $_[0] unless ref $_[0];
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
43
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
44 return ($handlers{reftype($_[0])} || sub { die "Unknown reftype " . reftype($_[0])} )->($_[0]);
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
45 }
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
46 }
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
47
aaab45153411 minor bugfixes
sourcer
parents:
diff changeset
48 1;