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