← 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:24:06 2012

Filename/2home/ss5/perl5/perlbrew/perls/perl-5.12.3/lib/site_perl/5.12.3/Hash/Merge.pm
StatementsExecuted 307845 statements in 482ms
Subroutines
Calls P F Exclusive
Time
Inclusive
Time
Subroutine
3419911401ms546msHash::Merge::::mergeHash::Merge::merge
342002181.6ms81.6msHash::Merge::::_get_objHash::Merge::_get_obj
11159µs67µsHash::Merge::::specify_behaviorHash::Merge::specify_behavior
11147µs58µsHash::Merge::::BEGIN@3Hash::Merge::BEGIN@3
11126µs157µsHash::Merge::::BEGIN@5Hash::Merge::BEGIN@5
11125µs64µsHash::Merge::::BEGIN@4Hash::Merge::BEGIN@4
11121µs21µsHash::Merge::::newHash::Merge::new
11121µs221µsHash::Merge::::BEGIN@7Hash::Merge::BEGIN@7
11120µs219µsHash::Merge::::BEGIN@8Hash::Merge::BEGIN@8
0000s0sHash::Merge::::__ANON__[:23]Hash::Merge::__ANON__[:23]
0000s0sHash::Merge::::__ANON__[:24]Hash::Merge::__ANON__[:24]
0000s0sHash::Merge::::__ANON__[:25]Hash::Merge::__ANON__[:25]
0000s0sHash::Merge::::__ANON__[:284]Hash::Merge::__ANON__[:284]
0000s0sHash::Merge::::__ANON__[:28]Hash::Merge::__ANON__[:28]
0000s0sHash::Merge::::__ANON__[:291]Hash::Merge::__ANON__[:291]
0000s0sHash::Merge::::__ANON__[:298]Hash::Merge::__ANON__[:298]
0000s0sHash::Merge::::__ANON__[:29]Hash::Merge::__ANON__[:29]
0000s0sHash::Merge::::__ANON__[:30]Hash::Merge::__ANON__[:30]
0000s0sHash::Merge::::__ANON__[:33]Hash::Merge::__ANON__[:33]
0000s0sHash::Merge::::__ANON__[:34]Hash::Merge::__ANON__[:34]
0000s0sHash::Merge::::__ANON__[:35]Hash::Merge::__ANON__[:35]
0000s0sHash::Merge::::__ANON__[:41]Hash::Merge::__ANON__[:41]
0000s0sHash::Merge::::__ANON__[:42]Hash::Merge::__ANON__[:42]
0000s0sHash::Merge::::__ANON__[:43]Hash::Merge::__ANON__[:43]
0000s0sHash::Merge::::__ANON__[:46]Hash::Merge::__ANON__[:46]
0000s0sHash::Merge::::__ANON__[:47]Hash::Merge::__ANON__[:47]
0000s0sHash::Merge::::__ANON__[:48]Hash::Merge::__ANON__[:48]
0000s0sHash::Merge::::__ANON__[:51]Hash::Merge::__ANON__[:51]
0000s0sHash::Merge::::__ANON__[:52]Hash::Merge::__ANON__[:52]
0000s0sHash::Merge::::__ANON__[:53]Hash::Merge::__ANON__[:53]
0000s0sHash::Merge::::__ANON__[:59]Hash::Merge::__ANON__[:59]
0000s0sHash::Merge::::__ANON__[:60]Hash::Merge::__ANON__[:60]
0000s0sHash::Merge::::__ANON__[:61]Hash::Merge::__ANON__[:61]
0000s0sHash::Merge::::__ANON__[:64]Hash::Merge::__ANON__[:64]
0000s0sHash::Merge::::__ANON__[:65]Hash::Merge::__ANON__[:65]
0000s0sHash::Merge::::__ANON__[:66]Hash::Merge::__ANON__[:66]
0000s0sHash::Merge::::__ANON__[:69]Hash::Merge::__ANON__[:69]
0000s0sHash::Merge::::__ANON__[:70]Hash::Merge::__ANON__[:70]
0000s0sHash::Merge::::__ANON__[:71]Hash::Merge::__ANON__[:71]
0000s0sHash::Merge::::__ANON__[:77]Hash::Merge::__ANON__[:77]
0000s0sHash::Merge::::__ANON__[:78]Hash::Merge::__ANON__[:78]
0000s0sHash::Merge::::__ANON__[:79]Hash::Merge::__ANON__[:79]
0000s0sHash::Merge::::__ANON__[:82]Hash::Merge::__ANON__[:82]
0000s0sHash::Merge::::__ANON__[:83]Hash::Merge::__ANON__[:83]
0000s0sHash::Merge::::__ANON__[:84]Hash::Merge::__ANON__[:84]
0000s0sHash::Merge::::__ANON__[:87]Hash::Merge::__ANON__[:87]
0000s0sHash::Merge::::__ANON__[:88]Hash::Merge::__ANON__[:88]
0000s0sHash::Merge::::__ANON__[:89]Hash::Merge::__ANON__[:89]
0000s0sHash::Merge::::_hashifyHash::Merge::_hashify
0000s0sHash::Merge::::_merge_hashesHash::Merge::_merge_hashes
0000s0sHash::Merge::::_my_cloneHash::Merge::_my_clone
0000s0sHash::Merge::::get_behaviorHash::Merge::get_behavior
0000s0sHash::Merge::::get_clone_behaviorHash::Merge::get_clone_behavior
0000s0sHash::Merge::::set_behaviorHash::Merge::set_behavior
0000s0sHash::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
1package Hash::Merge;
2
3368µs270µ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
4361µs2102µ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
5372µs2288µ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
7377µs2421µ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
834.81ms2418µ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
1011µsmy ( $GLOBAL, $clone );
11
1212µs$VERSION = '0.12';
1315µs@EXPORT_OK = qw( merge _hashify _merge_hashes );
1418µs%EXPORT_TAGS = ( 'custom' => [qw( _hashify _merge_hashes )] );
15
1612µs$GLOBAL = {};
17134µsbless $GLOBAL, __PACKAGE__;
181800ns$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 },
921165µs};
93
9412µs$GLOBAL->{'behavior'} = 'LEFT_PRECEDENT';
9513µs$GLOBAL->{'matrix'} = $GLOBAL->{behaviors}{ $GLOBAL->{'behavior'} };
9612µ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 {
993420026.0ms if ( my $type = ref $_[0] ) {
1003420099.4ms 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 {
10712µs my $pkg = shift;
1081900ns $pkg = ref $pkg || $pkg;
10913µs my $beh = shift || $context->{'behavior'};
110
11112µs croak "Behavior '$beh' does not exist" if !exists $context->{'behaviors'}{$beh};
112
113125µs return bless {
114 'behavior' => $beh,
115 'matrix' => $context->{'behaviors'}{$beh},
116 }, $pkg;
117}
118
119sub 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
132sub 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 {
13814µs18µs my $self = &_get_obj; # '&' + no args modifies current @_
# spent 8µs making 1 call to Hash::Merge::_get_obj
13912µs my ( $matrix, $name ) = @_;
1401400ns $name ||= 'user defined';
14112µs if ( exists $self->{'behaviors'}{$name} ) {
142 carp "Behavior '$name' was already defined. Please take another name";
143 return;
144 }
145
14614µs my @required = qw( SCALAR ARRAY HASH );
147
14814µs foreach my $left (@required) {
14937µs foreach my $right (@required) {
150918µs if ( !exists $matrix->{$left}->{$right} ) {
151 carp "Behavior does not specify action for '$left' merging with '$right'";
152 return;
153 }
154 }
155 }
156
15712µs $self->{'behavior'} = $name;
158115µs $self->{'behaviors'}{$name} = $self->{'matrix'} = $matrix;
159}
160
161sub 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
168sub 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 {
1743419946.6ms3419981.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
1763419926.4ms 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
1823419938.7ms my $lefttype =
183 ref $left eq 'HASH' ? 'HASH'
184 : ref $left eq 'ARRAY' ? 'ARRAY'
185 : 'SCALAR';
186
1873419929.9ms my $righttype =
188 ref $right eq 'HASH' ? 'HASH'
189 : ref $right eq 'ARRAY' ? 'ARRAY'
190 : 'SCALAR';
191
1923419916.7ms if ( $self->{'clone'} ) {
193 $left = _my_clone( $left, 1 );
194 $right = _my_clone( $right, 1 );
195 }
196
1973419915.4ms local $context = $self;
19834199178ms3419963.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
204sub _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
236sub _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
270sub _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
313168µs1;
314
315__END__