File Coverage

blib/lib/Clone/PP.pm
Criterion Covered Total %
statement 53 54 98.1
branch 31 34 91.1
condition 5 6 83.3
subroutine 9 9 100.0
pod 0 1 0.0
total 98 104 94.2


line stmt bran cond sub pod time code
1             package Clone::PP;
2              
3 7     7   3810 use 5.006;
  7         20  
4 7     7   28 use strict;
  7         7  
  7         163  
5 7     7   26 use warnings;
  7         10  
  7         255  
6 7     7   26 use vars qw($VERSION @EXPORT_OK);
  7         7  
  7         455  
7 7     7   33 use Exporter;
  7         9  
  7         620  
8              
9             $VERSION = 1.07;
10              
11             @EXPORT_OK = qw( clone );
12 7     7   4371 sub import { goto &Exporter::import } # lazy Exporter
13              
14             # These methods can be temporarily overridden to work with a given class.
15 7     7   34 use vars qw( $CloneSelfMethod $CloneInitMethod );
  7         10  
  7         431  
16             $CloneSelfMethod ||= 'clone_self';
17             $CloneInitMethod ||= 'clone_init';
18              
19             # Used to detect looped networks and avoid infinite recursion.
20 7     7   29 use vars qw( %CloneCache );
  7         9  
  7         3083  
21              
22             # Generic cloning function
23             sub clone {
24 55     55 0 11110 my $source = shift;
25              
26 55 100       117 return undef if not defined($source);
27            
28             # Optional depth limit: after a given number of levels, do shallow copy.
29 52         44 my $depth = shift;
30 52 100 100     144 return $source if ( defined $depth and $depth -- < 1 );
31            
32             # Maintain a shared cache during recursive calls, then clear it at the end.
33 47 100       108 local %CloneCache = ( undef => undef ) unless ( exists $CloneCache{undef} );
34            
35 47 100       119 return $CloneCache{ $source } if ( defined $CloneCache{ $source } );
36            
37             # Non-reference values are copied shallowly
38 39 100       87 my $ref_type = ref $source or return $source;
39            
40             # Extract both the structure type and the class name of referent
41 36         25 my $class_name;
42 36 100       681 if ( "$source" =~ /^\Q$ref_type\E\=([A-Z]+)\(0x[0-9a-f]+\)$/ ) {
43 9         16 $class_name = $ref_type;
44 9         26 $ref_type = $1;
45             # Some objects would prefer to clone themselves; check for clone_self().
46 9 50       83 return $CloneCache{ $source } = $source->$CloneSelfMethod()
47             if $source->can($CloneSelfMethod);
48             }
49            
50             # To make a copy:
51             # - Prepare a reference to the same type of structure;
52             # - Store it in the cache, to avoid looping if it refers to itself;
53             # - Tie in to the same class as the original, if it was tied;
54             # - Assign a value to the reference by cloning each item in the original;
55            
56 36         41 my $copy;
57 36 100 66     112 if ($ref_type eq 'HASH') {
    100          
    50          
58 17         39 $CloneCache{ $source } = $copy = {};
59 17 100       329 if ( my $tied = tied( %$source ) ) { tie %$copy, ref $tied }
  1         3  
60 17 100       70 %$copy = map { ! ref($_) ? $_ : clone($_, $depth) } %$source;
  54         144  
61             } elsif ($ref_type eq 'ARRAY') {
62 9         19 $CloneCache{ $source } = $copy = [];
63 9 100       28 if ( my $tied = tied( @$source ) ) { tie @$copy, ref $tied }
  1         4  
64 9 100       18 @$copy = map { ! ref($_) ? $_ : clone($_, $depth) } @$source;
  23         57  
65             } elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') {
66 10         23 $CloneCache{ $source } = $copy = \( my $var = "" );
67 10 100       20 if ( my $tied = tied( $$source ) ) { tie $$copy, ref $tied }
  1         3  
68 10         30 $$copy = clone($$source, $depth);
69             } else {
70             # Shallow copy anything else; this handles a reference to code, glob, regex
71 0         0 $CloneCache{ $source } = $copy = $source;
72             }
73            
74             # - Bless it into the same class as the original, if it was blessed;
75             # - If it has a post-cloning initialization method, call it.
76 36 100       95 if ( $class_name ) {
77 9         18 bless $copy, $class_name;
78 9 50       72 $copy->$CloneInitMethod() if $copy->can($CloneInitMethod);
79             }
80            
81 36         96 return $copy;
82             }
83              
84             1;
85              
86             __END__