← Index
NYTProf Performance Profile   « line view »
For starman worker -M FindBin --max-requests 50 --workers 2 --user=kohadev-koha --group kohadev-koha --pid /var/run/koha/kohadev/plack.pid --daemonize --access-log /var/log/koha/kohadev/plack.log --error-log /var/log/koha/kohadev/plack-error.log -E deployment --socket /var/run/koha/kohadev/plack.sock /etc/koha/sites/kohadev/plack.psgi
  Run on Fri Jan 8 14:31:06 2016
Reported on Fri Jan 8 14:33:30 2016

Filename/usr/share/perl5/Hash/Merge.pm
StatementsExecuted 837 statements in 1.37ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
325117.93ms9.84msHash::Merge::::mergeHash::Merge::merge
326211.09ms1.09msHash::Merge::::_get_objHash::Merge::_get_obj
11117µs30µsHash::Merge::::BEGIN@3Hash::Merge::BEGIN@3
11114µs16µsHash::Merge::::specify_behaviorHash::Merge::specify_behavior
11111µs50µsHash::Merge::::BEGIN@8Hash::Merge::BEGIN@8
11110µs19µsHash::Merge::::BEGIN@4Hash::Merge::BEGIN@4
11110µs58µsHash::Merge::::BEGIN@7Hash::Merge::BEGIN@7
1119µs46µsHash::Merge::::BEGIN@5Hash::Merge::BEGIN@5
1115µs5µsHash::Merge::::newHash::Merge::new
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
3243µs
# spent 30µs (17+13) within Hash::Merge::BEGIN@3 which was called: # once (17µs+13µs) by DBIx::Class::ResultSet::_merge_attr at line 3
use strict;
# spent 30µs making 1 call to Hash::Merge::BEGIN@3 # spent 13µs making 1 call to strict::import
4228µs
# spent 19µs (10+9) within Hash::Merge::BEGIN@4 which was called: # once (10µs+9µs) by DBIx::Class::ResultSet::_merge_attr at line 4
use warnings;
# spent 19µs making 1 call to Hash::Merge::BEGIN@4 # spent 9µs making 1 call to warnings::import
5284µs
# spent 46µs (9+37) within Hash::Merge::BEGIN@5 which was called: # once (9µs+37µs) by DBIx::Class::ResultSet::_merge_attr at line 5
use Carp;
# spent 46µs making 1 call to Hash::Merge::BEGIN@5 # spent 37µs making 1 call to Exporter::import
6
72108µs
# spent 58µs (10+49) within Hash::Merge::BEGIN@7 which was called: # once (10µs+49µs) by DBIx::Class::ResultSet::_merge_attr at line 7
use base 'Exporter';
# spent 58µs making 1 call to Hash::Merge::BEGIN@7 # spent 49µs making 1 call to base::import
8288µs
# spent 50µs (11+39) within Hash::Merge::BEGIN@8 which was called: # once (11µs+39µs) by DBIx::Class::ResultSet::_merge_attr at line 8
use vars qw($VERSION @ISA @EXPORT_OK %EXPORT_TAGS $context);
# spent 50µs making 1 call to Hash::Merge::BEGIN@8 # spent 39µs making 1 call to vars::import
9
10my ( $GLOBAL, $clone );
11
12$VERSION = '0.200';
13@EXPORT_OK = qw( merge _hashify _merge_hashes );
14%EXPORT_TAGS = ( 'custom' => [qw( _hashify _merge_hashes )] );
15
16$GLOBAL = {};
17bless $GLOBAL, __PACKAGE__;
18$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};
93
94$GLOBAL->{'behavior'} = 'LEFT_PRECEDENT';
95$GLOBAL->{'matrix'} = $GLOBAL->{behaviors}{ $GLOBAL->{'behavior'} };
96$GLOBAL->{'clone'} = 1;
97
98
# spent 1.09ms within Hash::Merge::_get_obj which was called 326 times, avg 3µs/call: # 325 times (1.09ms+0s) by Hash::Merge::merge at line 174, avg 3µs/call # once (2µs+0s) by Hash::Merge::specify_behavior at line 138
sub _get_obj {
999386µs if ( my $type = ref $_[0] ) {
10093325µs return shift() if $type eq __PACKAGE__ || eval { $_[0]->isa(__PACKAGE__) };
101 }
102
103 return $context;
104}
105
106
# spent 5µs within Hash::Merge::new which was called: # once (5µs+0s) by DBIx::Class::ResultSet::_merge_attr at line 3889 of DBIx/Class/ResultSet.pm
sub new {
107 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
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 16µs (14+2) within Hash::Merge::specify_behavior which was called: # once (14µs+2µs) by DBIx::Class::ResultSet::_merge_attr at line 3963 of DBIx/Class/ResultSet.pm
sub specify_behavior {
13812µs my $self = &_get_obj; # '&' + no args modifies current @_
# spent 2µ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 foreach my $right (@required) {
150 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
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 9.84ms (7.93+1.91) within Hash::Merge::merge which was called 325 times, avg 30µs/call: # 325 times (7.93ms+1.91ms) by DBIx::Class::ResultSet::_merge_attr at line 3967 of DBIx/Class/ResultSet.pm, avg 30µs/call
sub merge {
17493150µs3251.09ms my $self = &_get_obj; # '&' + no args modifies current @_
# spent 1.09ms making 325 calls to Hash::Merge::_get_obj, avg 3µs/call
175
1769340µs 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
18293116µs my $lefttype =
183 ref $left eq 'HASH' ? 'HASH'
184 : ref $left eq 'ARRAY' ? 'ARRAY'
185 : 'SCALAR';
186
1879369µs my $righttype =
188 ref $right eq 'HASH' ? 'HASH'
189 : ref $right eq 'ARRAY' ? 'ARRAY'
190 : 'SCALAR';
191
1929335µs if ( $self->{'clone'} ) {
193 $left = _my_clone( $left, 1 );
194 $right = _my_clone( $right, 1 );
195 }
196
1979359µs local $context = $self;
19893490µs325821µs return $self->{'matrix'}->{$lefttype}{$righttype}->( $left, $right );
# spent 809µs making 320 calls to DBIx::Class::ResultSet::__ANON__[DBIx/Class/ResultSet.pm:3926], avg 3µs/call # spent 6µs making 1 call to DBIx::Class::ResultSet::__ANON__[DBIx/Class/ResultSet.pm:3919] # spent 5µs making 4 calls to DBIx::Class::ResultSet::__ANON__[DBIx/Class/ResultSet.pm:3913], 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
3131;
314
315__END__
Report produced by the NYTProf 6.02 Perl profiler, developed by Tim Bunce and Adam Kaplan.