File Coverage

File:local/lib/perl5/Clone/PP.pm
Coverage:76.7%

linestmtbrancondsubtimecode
1package Clone::PP;
2
3
2
2
2
16
2
use 5.006;
4
2
2
2
2
4
2
22
use strict;
5
2
2
2
2
4
1
24
use warnings;
6
2
2
2
2
4
2
45
use vars qw($VERSION @EXPORT_OK);
7
2
2
2
2
3
1
66
use Exporter;
8
9$VERSION = 1.05;
10
11@EXPORT_OK = qw( clone );
12
4
4
508
sub import { goto &Exporter::import } # lazy Exporter
13
14# These methods can be temporarily overridden to work with a given class.
15
2
2
2
2
4
2
40
use vars qw( $CloneSelfMethod $CloneInitMethod );
16$CloneSelfMethod ||= 'clone_self';
17$CloneInitMethod ||= 'clone_init';
18
19# Used to detect looped networks and avoid infinite recursion.
20
2
2
2
2
3
1
347
use vars qw( %CloneCache );
21
22# Generic cloning function
23sub clone {
24
1072
1072
471
  my $source = shift;
25
26
1072
50
813
  return undef if not defined($source);
27
28  # Optional depth limit: after a given number of levels, do shallow copy.
29
1072
460
  my $depth = shift;
30
1072
50
33
969
  return $source if ( defined $depth and $depth -- < 1 );
31
32  # Maintain a shared cache during recursive calls, then clear it at the end.
33
1072
100
918
  local %CloneCache = ( undef => undef ) unless ( exists $CloneCache{undef} );
34
35
1072
50
977
  return $CloneCache{ $source } if ( defined $CloneCache{ $source } );
36
37  # Non-reference values are copied shallowly
38
1072
100
920
  my $ref_type = ref $source or return $source;
39
40  # Extract both the structure type and the class name of referent
41
1052
412
  my $class_name;
42
1052
50
5451
  if ( "$source" =~ /^\Q$ref_type\E\=([A-Z]+)\(0x[0-9a-f]+\)$/ ) {
43
0
0
    $class_name = $ref_type;
44
0
0
    $ref_type = $1;
45    # Some objects would prefer to clone themselves; check for clone_self().
46
0
0
0
    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
1052
508
  my $copy;
57
1052
100
100
100
67
1591
  if ($ref_type eq 'HASH') {
58
120
126
    $CloneCache{ $source } = $copy = {};
59
120
0
50
114
0
    if ( my $tied = tied( %$source ) ) { tie %$copy, ref $tied }
60
120
3472
100
247
2888
    %$copy = map { ! ref($_) ? $_ : clone($_, $depth) } %$source;
61  } elsif ($ref_type eq 'ARRAY') {
62
438
417
    $CloneCache{ $source } = $copy = [];
63
438
0
50
362
0
    if ( my $tied = tied( @$source ) ) { tie @$copy, ref $tied }
64
438
474
50
222
446
    @$copy = map { ! ref($_) ? $_ : clone($_, $depth) } @$source;
65  } elsif ($ref_type eq 'REF' or $ref_type eq 'SCALAR') {
66
20
29
    $CloneCache{ $source } = $copy = \( my $var = "" );
67
20
0
50
31
0
    if ( my $tied = tied( $$source ) ) { tie $$copy, ref $tied }
68
20
20
    $$copy = clone($$source, $depth);
69  } else {
70    # Shallow copy anything else; this handles a reference to code, glob, regex
71
474
394
    $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
1052
50
887
  if ( $class_name ) {
77
0
0
    bless $copy, $class_name;
78
0
0
0
    $copy->$CloneInitMethod() if $copy->can($CloneInitMethod);
79  }
80
81
1052
1054
  return $copy;
82}
83
841;
85