Profile of Hash/Merge.pm

← Index
NYTProf Performance Profile «block view•line view•sub view»
For xt/tapper-mcp-scheduler-with-db-longrun.t
Run on Tue May 22 17:18:39 2012
Reported on Tue May 22 17:23:19 2012

Filename | /2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Hash/Merge.pm
Statements | Executed 307845 statements in 482ms

Subroutines
Calls | P | F | Exclusive Time | Inclusive Time | Subroutine
--- | --- | --- | --- | --- | ---
34199 | 1 | 1 | 401ms | 546ms | Hash::Merge::::mergeHash::Merge::merge
34200 | 2 | 1 | 81.6ms | 81.6ms | Hash::Merge::::_get_objHash::Merge::_get_obj
1 | 1 | 1 | 59µs | 67µs | Hash::Merge::::specify_behaviorHash::Merge::specify_behavior
1 | 1 | 1 | 47µs | 58µs | Hash::Merge::::BEGIN@3Hash::Merge::BEGIN@3
1 | 1 | 1 | 26µs | 157µs | Hash::Merge::::BEGIN@5Hash::Merge::BEGIN@5
1 | 1 | 1 | 25µs | 64µs | Hash::Merge::::BEGIN@4Hash::Merge::BEGIN@4
1 | 1 | 1 | 21µs | 21µs | Hash::Merge::::newHash::Merge::new
1 | 1 | 1 | 21µs | 221µs | Hash::Merge::::BEGIN@7Hash::Merge::BEGIN@7
1 | 1 | 1 | 20µs | 219µs | Hash::Merge::::BEGIN@8Hash::Merge::BEGIN@8
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:23]Hash::Merge::__ANON__[:23]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:24]Hash::Merge::__ANON__[:24]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:25]Hash::Merge::__ANON__[:25]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:284]Hash::Merge::__ANON__[:284]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:28]Hash::Merge::__ANON__[:28]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:291]Hash::Merge::__ANON__[:291]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:298]Hash::Merge::__ANON__[:298]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:29]Hash::Merge::__ANON__[:29]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:30]Hash::Merge::__ANON__[:30]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:33]Hash::Merge::__ANON__[:33]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:34]Hash::Merge::__ANON__[:34]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:35]Hash::Merge::__ANON__[:35]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:41]Hash::Merge::__ANON__[:41]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:42]Hash::Merge::__ANON__[:42]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:43]Hash::Merge::__ANON__[:43]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:46]Hash::Merge::__ANON__[:46]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:47]Hash::Merge::__ANON__[:47]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:48]Hash::Merge::__ANON__[:48]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:51]Hash::Merge::__ANON__[:51]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:52]Hash::Merge::__ANON__[:52]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:53]Hash::Merge::__ANON__[:53]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:59]Hash::Merge::__ANON__[:59]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:60]Hash::Merge::__ANON__[:60]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:61]Hash::Merge::__ANON__[:61]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:64]Hash::Merge::__ANON__[:64]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:65]Hash::Merge::__ANON__[:65]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:66]Hash::Merge::__ANON__[:66]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:69]Hash::Merge::__ANON__[:69]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:70]Hash::Merge::__ANON__[:70]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:71]Hash::Merge::__ANON__[:71]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:77]Hash::Merge::__ANON__[:77]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:78]Hash::Merge::__ANON__[:78]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:79]Hash::Merge::__ANON__[:79]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:82]Hash::Merge::__ANON__[:82]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:83]Hash::Merge::__ANON__[:83]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:84]Hash::Merge::__ANON__[:84]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:87]Hash::Merge::__ANON__[:87]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:88]Hash::Merge::__ANON__[:88]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::__ANON__[:89]Hash::Merge::__ANON__[:89]
0 | 0 | 0 | 0s | 0s | Hash::Merge::::_hashifyHash::Merge::_hashify
0 | 0 | 0 | 0s | 0s | Hash::Merge::::_merge_hashesHash::Merge::_merge_hashes
0 | 0 | 0 | 0s | 0s | Hash::Merge::::_my_cloneHash::Merge::_my_clone
0 | 0 | 0 | 0s | 0s | Hash::Merge::::get_behaviorHash::Merge::get_behavior
0 | 0 | 0 | 0s | 0s | Hash::Merge::::get_clone_behaviorHash::Merge::get_clone_behavior
0 | 0 | 0 | 0s | 0s | Hash::Merge::::set_behaviorHash::Merge::set_behavior
0 | 0 | 0 | 0s | 0s | Hash::Merge::::set_clone_behaviorHash::Merge::set_clone_behavior

Call graph for these subroutines as a Graphviz dot language file.

Line | State ments | Time on line | Calls | Time in subs | Code
--- | --- | --- | --- | --- | ---
1 |  |  |  |  | package Hash::Merge;
2 |  |  |  |  |
3 | 3 | 68µs | 2 | 70µs | # spent 58µs (47+12) within Hash::Merge::BEGIN@3 which was called: # once (47µs+12µs) by DBIx::Class::ResultSet::_merge_attr at line 3 use strict; # spent 58µs making 1 call to Hash::Merge::BEGIN@3 # spent 12µs making 1 call to strict::import
4 | 3 | 61µs | 2 | 102µs | # spent 64µs (25+38) within Hash::Merge::BEGIN@4 which was called: # once (25µs+38µs) by DBIx::Class::ResultSet::_merge_attr at line 4 use warnings; # spent 64µs making 1 call to Hash::Merge::BEGIN@4 # spent 38µs making 1 call to warnings::import
5 | 3 | 72µs | 2 | 288µs | # spent 157µs (26+131) within Hash::Merge::BEGIN@5 which was called: # once (26µs+131µs) by DBIx::Class::ResultSet::_merge_attr at line 5 use Carp; # spent 157µs making 1 call to Hash::Merge::BEGIN@5 # spent 131µs making 1 call to Exporter::import
6 |  |  |  |  |
7 | 3 | 77µs | 2 | 421µs | # spent 221µs (21+200) within Hash::Merge::BEGIN@7 which was called: # once (21µs+200µs) by DBIx::Class::ResultSet::_merge_attr at line 7 use base 'Exporter'; # spent 221µs making 1 call to Hash::Merge::BEGIN@7 # spent 200µs making 1 call to base::import
8 | 3 | 4.81ms | 2 | 418µs | # spent 219µs (20+199) within Hash::Merge::BEGIN@8 which was called: # once (20µs+199µs) by DBIx::Class::ResultSet::_merge_attr at line 8 use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS $context); # spent 219µs making 1 call to Hash::Merge::BEGIN@8 # spent 199µs making 1 call to vars::import
9 |  |  |  |  |
10 | 1 | 1µs |  |  | my ( $GLOBAL, $clone );
11 |  |  |  |  |
12 | 1 | 2µs |  |  | $VERSION = '0.12';
13 | 1 | 5µs |  |  | @EXPORT_OK = qw( merge _hashify _merge_hashes );
14 | 1 | 8µs |  |  | %EXPORT_TAGS = ( 'custom' => [qw( _hashify _merge_hashes )] );
15 |  |  |  |  |
16 | 1 | 2µs |  |  | $GLOBAL = {};
17 | 1 | 34µs |  |  | bless $GLOBAL, __PACKAGE__;
18 | 1 | 800ns |  |  | $context = $GLOBAL; # $context is a variable for merge and _merge_hashes. used by functions to respect calling context
19 |  |  |  |  |
20 |  |  |  |  | $GLOBAL->{'behaviors'} = {
21 |  |  |  |  | 'LEFT_PRECEDENT' => {
22 |  |  |  |  | 'SCALAR' => {
23 |  |  |  |  | 'SCALAR' => sub { $_[0] },
24 |  |  |  |  | 'ARRAY' => sub { $_[0] },
25 |  |  |  |  | 'HASH' => sub { $_[0] },
26 |  |  |  |  | },
27 |  |  |  |  | 'ARRAY' => {
28 |  |  |  |  | 'SCALAR' => sub { [ @{ $_[0] }, $_[1] ] },
29 |  |  |  |  | 'ARRAY' => sub { [ @{ $_[0] }, @{ $_[1] } ] },
30 |  |  |  |  | 'HASH' => sub { [ @{ $_[0] }, values %{ $_[1] } ] },
31 |  |  |  |  | },
32 |  |  |  |  | 'HASH' => {
33 |  |  |  |  | 'SCALAR' => sub { $_[0] },
34 |  |  |  |  | 'ARRAY' => sub { $_[0] },
35 |  |  |  |  | 'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
36 |  |  |  |  | },
37 |  |  |  |  | },
38 |  |  |  |  |
39 |  |  |  |  | 'RIGHT_PRECEDENT' => {
40 |  |  |  |  | 'SCALAR' => {
41 |  |  |  |  | 'SCALAR' => sub { $_[1] },
42 |  |  |  |  | 'ARRAY' => sub { [ $_[0], @{ $_[1] } ] },
43 |  |  |  |  | 'HASH' => sub { $_[1] },
44 |  |  |  |  | },
45 |  |  |  |  | 'ARRAY' => {
46 |  |  |  |  | 'SCALAR' => sub { $_[1] },
47 |  |  |  |  | 'ARRAY' => sub { [ @{ $_[0] }, @{ $_[1] } ] },
48 |  |  |  |  | 'HASH' => sub { $_[1] },
49 |  |  |  |  | },
50 |  |  |  |  | 'HASH' => {
51 |  |  |  |  | 'SCALAR' => sub { $_[1] },
52 |  |  |  |  | 'ARRAY' => sub { [ values %{ $_[0] }, @{ $_[1] } ] },
53 |  |  |  |  | 'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
54 |  |  |  |  | },
55 |  |  |  |  | },
56 |  |  |  |  |
57 |  |  |  |  | 'STORAGE_PRECEDENT' => {
58 |  |  |  |  | 'SCALAR' => {
59 |  |  |  |  | 'SCALAR' => sub { $_[0] },
60 |  |  |  |  | 'ARRAY' => sub { [ $_[0], @{ $_[1] } ] },
61 |  |  |  |  | 'HASH' => sub { $_[1] },
62 |  |  |  |  | },
63 |  |  |  |  | 'ARRAY' => {
64 |  |  |  |  | 'SCALAR' => sub { [ @{ $_[0] }, $_[1] ] },
65 |  |  |  |  | 'ARRAY' => sub { [ @{ $_[0] }, @{ $_[1] } ] },
66 |  |  |  |  | 'HASH' => sub { $_[1] },
67 |  |  |  |  | },
68 |  |  |  |  | 'HASH' => {
69 |  |  |  |  | 'SCALAR' => sub { $_[0] },
70 |  |  |  |  | 'ARRAY' => sub { $_[0] },
71 |  |  |  |  | 'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
72 |  |  |  |  | },
73 |  |  |  |  | },
74 |  |  |  |  |
75 |  |  |  |  | 'RETAINMENT_PRECEDENT' => {
76 |  |  |  |  | 'SCALAR' => {
77 |  |  |  |  | 'SCALAR' => sub { [ $_[0], $_[1] ] },
78 |  |  |  |  | 'ARRAY' => sub { [ $_[0], @{ $_[1] } ] },
79 |  |  |  |  | 'HASH' => sub { _merge_hashes( _hashify( $_[0] ), $_[1] ) },
80 |  |  |  |  | },
81 |  |  |  |  | 'ARRAY' => {
82 |  |  |  |  | 'SCALAR' => sub { [ @{ $_[0] }, $_[1] ] },
83 |  |  |  |  | 'ARRAY' => sub { [ @{ $_[0] }, @{ $_[1] } ] },
84 |  |  |  |  | 'HASH' => sub { _merge_hashes( _hashify( $_[0] ), $_[1] ) },
85 |  |  |  |  | },
86 |  |  |  |  | 'HASH' => {
87 |  |  |  |  | 'SCALAR' => sub { _merge_hashes( $_[0], _hashify( $_[1] ) ) },
88 |  |  |  |  | 'ARRAY' => sub { _merge_hashes( $_[0], _hashify( $_[1] ) ) },
89 |  |  |  |  | 'HASH' => sub { _merge_hashes( $_[0], $_[1] ) },
90 |  |  |  |  | },
91 |  |  |  |  | },
92 | 1 | 165µs |  |  | };
93 |  |  |  |  |
94 | 1 | 2µs |  |  | $GLOBAL->{'behavior'} = 'LEFT_PRECEDENT';
95 | 1 | 3µs |  |  | $GLOBAL->{'matrix'} = $GLOBAL->{behaviors}{ $GLOBAL->{'behavior'} };
96 | 1 | 2µs |  |  | $GLOBAL->{'clone'} = 1;
97 |  |  |  |  |
98 |  |  |  |  | # spent 81.6ms within Hash::Merge::_get_obj which was called 34200 times, avg 2µs/call: # 34199 times (81.6ms+0s) by Hash::Merge::merge at line 174, avg 2µs/call # once (8µs+0s) by Hash::Merge::specify_behavior at line 138 sub _get_obj {
99 | 68400 | 125ms |  |  | if ( my $type = ref $_[0] ) {
100 |  |  |  |  | return shift() if $type eq __PACKAGE__ || eval { $_[0]->isa(__PACKAGE__) };
101 |  |  |  |  | }
102 |  |  |  |  |
103 |  |  |  |  | return $context;
104 |  |  |  |  | }
105 |  |  |  |  |
106 |  |  |  |  | # spent 21µs within Hash::Merge::new which was called: # once (21µs+0s) by DBIx::Class::ResultSet::_merge_attr at line 3469 of DBIx/Class/ResultSet.pm sub new {
107 | 5 | 33µs |  |  | my $pkg = shift;
108 |  |  |  |  | $pkg = ref $pkg || $pkg;
109 |  |  |  |  | my $beh = shift || $context->{'behavior'};
110 |  |  |  |  |
111 |  |  |  |  | croak "Behavior '$beh' does not exist" if !exists $context->{'behaviors'}{$beh};
112 |  |  |  |  |
113 |  |  |  |  | return bless {
114 |  |  |  |  | 'behavior' => $beh,
115 |  |  |  |  | 'matrix' => $context->{'behaviors'}{$beh},
116 |  |  |  |  | }, $pkg;
117 |  |  |  |  | }
118 |  |  |  |  |
119 |  |  |  |  | sub set_behavior {
120 |  |  |  |  | my $self = &_get_obj; # '&' + no args modifies current @_
121 |  |  |  |  | my $value = uc(shift);
122 |  |  |  |  | if ( !exists $self->{'behaviors'}{$value} and !exists $GLOBAL->{'behaviors'}{$value} ) {
123 |  |  |  |  | carp 'Behavior must be one of : ' . join( ', ', keys %{ $self->{'behaviors'} }, keys %{ $GLOBAL->{'behaviors'}{$value} } );
124 |  |  |  |  | return;
125 |  |  |  |  | }
126 |  |  |  |  | my $oldvalue = $self->{'behavior'};
127 |  |  |  |  | $self->{'behavior'} = $value;
128 |  |  |  |  | $self->{'matrix'} = $self->{'behaviors'}{$value} || $GLOBAL->{'behaviors'}{$value};
129 |  |  |  |  | return $oldvalue; # Use classic POSIX pattern for get/set: set returns previous value
130 |  |  |  |  | }
131 |  |  |  |  |
132 |  |  |  |  | sub get_behavior {
133 |  |  |  |  | my $self = &_get_obj; # '&' + no args modifies current @_
134 |  |  |  |  | return $self->{'behavior'};
135 |  |  |  |  | }
136 |  |  |  |  |
137 |  |  |  |  | # spent 67µs (59+8) within Hash::Merge::specify_behavior which was called: # once (59µs+8µs) by DBIx::Class::ResultSet::_merge_attr at line 3543 of DBIx/Class/ResultSet.pm sub specify_behavior {
138 | 8 | 33µs | 1 | 8µs | my $self = &_get_obj; # '&' + no args modifies current @_ # spent 8µs making 1 call to Hash::Merge::_get_obj
139 |  |  |  |  | my ( $matrix, $name ) = @_;
140 |  |  |  |  | $name ||= 'user defined';
141 |  |  |  |  | if ( exists $self->{'behaviors'}{$name} ) {
142 |  |  |  |  | carp "Behavior '$name' was already defined. Please take another name";
143 |  |  |  |  | return;
144 |  |  |  |  | }
145 |  |  |  |  |
146 |  |  |  |  | my @required = qw( SCALAR ARRAY HASH );
147 |  |  |  |  |
148 |  |  |  |  | foreach my $left (@required) {
149 | 3 | 7µs |  |  | foreach my $right (@required) {
150 | 9 | 18µs |  |  | if ( !exists $matrix->{$left}->{$right} ) {
151 |  |  |  |  | carp "Behavior does not specify action for '$left' merging with '$right'";
152 |  |  |  |  | return;
153 |  |  |  |  | }
154 |  |  |  |  | }
155 |  |  |  |  | }
156 |  |  |  |  |
157 |  |  |  |  | $self->{'behavior'} = $name;
158 |  |  |  |  | $self->{'behaviors'}{$name} = $self->{'matrix'} = $matrix;
159 |  |  |  |  | }
160 |  |  |  |  |
161 |  |  |  |  | sub set_clone_behavior {
162 |  |  |  |  | my $self = &_get_obj; # '&' + no args modifies current @_
163 |  |  |  |  | my $oldvalue = $self->{'clone'};
164 |  |  |  |  | $self->{'clone'} = shift() ? 1 : 0;
165 |  |  |  |  | return $oldvalue;
166 |  |  |  |  | }
167 |  |  |  |  |
168 |  |  |  |  | sub get_clone_behavior {
169 |  |  |  |  | my $self = &_get_obj; # '&' + no args modifies current @_
170 |  |  |  |  | return $self->{'clone'};
171 |  |  |  |  | }
172 |  |  |  |  |
173 |  |  |  |  | # spent 546ms (401+145) within Hash::Merge::merge which was called 34199 times, avg 16µs/call: # 34199 times (401ms+145ms) by DBIx::Class::ResultSet::_merge_attr at line 3547 of DBIx/Class/ResultSet.pm, avg 16µs/call sub merge {
174 | 239393 | 352ms | 34199 | 81.6ms | my $self = &_get_obj; # '&' + no args modifies current @_ # spent 81.6ms making 34199 calls to Hash::Merge::_get_obj, avg 2µs/call
175 |  |  |  |  |
176 |  |  |  |  | my ( $left, $right ) = @_;
177 |  |  |  |  |
178 |  |  |  |  | # For the general use of this module, we want to create duplicates
179 |  |  |  |  | # of all data that is merged. This behavior can be shut off, but
180 |  |  |  |  | # can create havoc if references are used heavily.
181 |  |  |  |  |
182 |  |  |  |  | my $lefttype =
183 |  |  |  |  | ref $left eq 'HASH' ? 'HASH'
184 |  |  |  |  | : ref $left eq 'ARRAY' ? 'ARRAY'
185 |  |  |  |  | : 'SCALAR';
186 |  |  |  |  |
187 |  |  |  |  | my $righttype =
188 |  |  |  |  | ref $right eq 'HASH' ? 'HASH'
189 |  |  |  |  | : ref $right eq 'ARRAY' ? 'ARRAY'
190 |  |  |  |  | : 'SCALAR';
191 |  |  |  |  |
192 |  |  |  |  | if ( $self->{'clone'} ) {
193 |  |  |  |  | $left = _my_clone( $left, 1 );
194 |  |  |  |  | $right = _my_clone( $right, 1 );
195 |  |  |  |  | }
196 |  |  |  |  |
197 |  |  |  |  | local $context = $self;
198 |  |  | 34199 | 63.0ms | return $self->{'matrix'}->{$lefttype}{$righttype}->( $left, $right ); # spent 34.4ms making 14678 calls to DBIx::Class::ResultSet::__ANON__[DBIx/Class/ResultSet.pm:3506], avg 2µs/call # spent 28.6ms making 19521 calls to DBIx::Class::ResultSet::__ANON__[DBIx/Class/ResultSet.pm:3493], avg 1µs/call
199 |  |  |  |  | }
200 |  |  |  |  |
201 |  |  |  |  | # This does a straight merge of hashes, delegating the merge-specific
202 |  |  |  |  | # work to 'merge'
203 |  |  |  |  |
204 |  |  |  |  | sub _merge_hashes {
205 |  |  |  |  | my $self = &_get_obj; # '&' + no args modifies current @_
206 |  |  |  |  |
207 |  |  |  |  | my ( $left, $right ) = ( shift, shift );
208 |  |  |  |  | if ( ref $left ne 'HASH' || ref $right ne 'HASH' ) {
209 |  |  |  |  | carp 'Arguments for _merge_hashes must be hash references';
210 |  |  |  |  | return;
211 |  |  |  |  | }
212 |  |  |  |  |
213 |  |  |  |  | my %newhash;
214 |  |  |  |  | foreach my $leftkey ( keys %$left ) {
215 |  |  |  |  | if ( exists $right->{$leftkey} ) {
216 |  |  |  |  | $newhash{$leftkey} = $self->merge( $left->{$leftkey}, $right->{$leftkey} );
217 |  |  |  |  | }
218 |  |  |  |  | else {
219 |  |  |  |  | $newhash{$leftkey} = $self->{clone} ? $self->_my_clone( $left->{$leftkey} ) : $left->{$leftkey};
220 |  |  |  |  | }
221 |  |  |  |  | }
222 |  |  |  |  |
223 |  |  |  |  | foreach my $rightkey ( keys %$right ) {
224 |  |  |  |  | if ( !exists $left->{$rightkey} ) {
225 |  |  |  |  | $newhash{$rightkey} = $self->{clone} ? $self->_my_clone( $right->{$rightkey} ) : $right->{$rightkey};
226 |  |  |  |  | }
227 |  |  |  |  | }
228 |  |  |  |  |
229 |  |  |  |  | return \%newhash;
230 |  |  |  |  | }
231 |  |  |  |  |
232 |  |  |  |  | # Given a scalar or an array, creates a new hash where for each item in
233 |  |  |  |  | # the passed scalar or array, the key is equal to the value. Returns
234 |  |  |  |  | # this new hash
235 |  |  |  |  |
236 |  |  |  |  | sub _hashify {
237 |  |  |  |  | my $self = &_get_obj; # '&' + no args modifies current @_
238 |  |  |  |  | my $arg = shift;
239 |  |  |  |  | if ( ref $arg eq 'HASH' ) {
240 |  |  |  |  | carp 'Arguement for _hashify must not be a HASH ref';
241 |  |  |  |  | return;
242 |  |  |  |  | }
243 |  |  |  |  |
244 |  |  |  |  | my %newhash;
245 |  |  |  |  | if ( ref $arg eq 'ARRAY' ) {
246 |  |  |  |  | foreach my $item (@$arg) {
247 |  |  |  |  | my $suffix = 2;
248 |  |  |  |  | my $name = $item;
249 |  |  |  |  | while ( exists $newhash{$name} ) {
250 |  |  |  |  | $name = $item . $suffix++;
251 |  |  |  |  | }
252 |  |  |  |  | $newhash{$name} = $item;
253 |  |  |  |  | }
254 |  |  |  |  | }
255 |  |  |  |  | else {
256 |  |  |  |  | $newhash{$arg} = $arg;
257 |  |  |  |  | }
258 |  |  |  |  | return \%newhash;
259 |  |  |  |  | }
260 |  |  |  |  |
261 |  |  |  |  | # This adds some checks to the clone process, to deal with problems that
262 |  |  |  |  | # the current distro of ActiveState perl has (specifically, it uses 0.09
263 |  |  |  |  | # of Clone, which does not support the cloning of scalars). This simply
264 |  |  |  |  | # wraps around clone as to prevent a scalar from being cloned via a
265 |  |  |  |  | # Clone 0.09 process. This might mean that CODEREFs and anything else
266 |  |  |  |  | # not a HASH or ARRAY won't be cloned.
267 |  |  |  |  |
268 |  |  |  |  | # $clone is global, which should point to coderef
269 |  |  |  |  |
270 |  |  |  |  | sub _my_clone {
271 |  |  |  |  | my $self = &_get_obj; # '&' + no args modifies current @_
272 |  |  |  |  | my ( $arg, $depth ) = @_;
273 |  |  |  |  |
274 |  |  |  |  | if ( $self->{clone} && !$clone ) {
275 |  |  |  |  | if ( eval { require Clone; 1 } ) {
276 |  |  |  |  | $clone = sub {
277 |  |  |  |  | if ( !( $Clone::VERSION || 0 ) > 0.09
278 |  |  |  |  | && ref $_[0] ne 'HASH'
279 |  |  |  |  | && ref $_[0] ne 'ARRAY' ) {
280 |  |  |  |  | my $var = shift; # Forced clone
281 |  |  |  |  | return $var;
282 |  |  |  |  | }
283 |  |  |  |  | Clone::clone( shift, $depth );
284 |  |  |  |  | };
285 |  |  |  |  | }
286 |  |  |  |  | elsif ( eval { require Storable; 1 } ) {
287 |  |  |  |  | $clone = sub {
288 |  |  |  |  | my $var = shift; # Forced clone
289 |  |  |  |  | return $var if !ref($var);
290 |  |  |  |  | Storable::dclone($var);
291 |  |  |  |  | };
292 |  |  |  |  | }
293 |  |  |  |  | elsif ( eval { require Clone::PP; 1 } ) {
294 |  |  |  |  | $clone = sub {
295 |  |  |  |  | my $var = shift; # Forced clone
296 |  |  |  |  | return $var if !ref($var);
297 |  |  |  |  | Clone::PP::clone( $var, $depth );
298 |  |  |  |  | };
299 |  |  |  |  | }
300 |  |  |  |  | else {
301 |  |  |  |  | croak "Can't load Clone, Storable, or Clone::PP for cloning purpose";
302 |  |  |  |  | }
303 |  |  |  |  | }
304 |  |  |  |  |
305 |  |  |  |  | if ( $self->{'clone'} ) {
306 |  |  |  |  | return $clone->($arg);
307 |  |  |  |  | }
308 |  |  |  |  | else {
309 |  |  |  |  | return $arg;
310 |  |  |  |  | }
311 |  |  |  |  | }
312 |  |  |  |  |
313 | 1 | 68µs |  |  | 1;
314 |  |  |  |  |
315 |  |  |  |  | __END__