annotate Lib/IMPL/clone.pm @ 250:129e48bb5afb

DOM refactoring ObjectToDOM methods are virtual QueryToDOM uses inflators Fixed transform for the complex values in the ObjectToDOM QueryToDOM doesn't allow to use complex values (HASHes) as values for nodes (overpost problem)
author sergey
date Wed, 07 Nov 2012 04:17:53 +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;