← Index
NYTProf Performance Profile   « line view »
For svc/members/upsert
  Run on Tue Jan 13 11:50:22 2015
Reported on Tue Jan 13 12:09:48 2015

Filename/usr/share/perl5/Date/Manip/TZ_Base.pm
StatementsExecuted 281 statements in 1.88ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
29152109µs11.5msDate::Manip::TZ_Base::::_config_varDate::Manip::TZ_Base::_config_var
135237µs37µsDate::Manip::TZ_Base::::_configDate::Manip::TZ_Base::_config
11112µs16µsDate::Manip::TZ_Base::::BEGIN@10Date::Manip::TZ_Base::BEGIN@10
1118µs17µsDate::Manip::TZ_Base::::BEGIN@11Date::Manip::TZ_Base::BEGIN@11
1118µs97µsDate::Manip::TZ_Base::::BEGIN@12Date::Manip::TZ_Base::BEGIN@12
1117µs18µsDate::Manip::TZ_Base::::BEGIN@399Date::Manip::TZ_Base::BEGIN@399
1115µs12µsDate::Manip::TZ_Base::::BEGIN@403Date::Manip::TZ_Base::BEGIN@403
1112µs2µsDate::Manip::TZ_Base::::ENDDate::Manip::TZ_Base::END
0000s0sDate::Manip::TZ_Base::::_config_fileDate::Manip::TZ_Base::_config_file
0000s0sDate::Manip::TZ_Base::::_config_file_sectionDate::Manip::TZ_Base::_config_file_section
0000s0sDate::Manip::TZ_Base::::_config_file_varDate::Manip::TZ_Base::_config_file_var
0000s0sDate::Manip::TZ_Base::::_fix_yearDate::Manip::TZ_Base::_fix_year
0000s0sDate::Manip::TZ_Base::::_nowDate::Manip::TZ_Base::_now
0000s0sDate::Manip::TZ_Base::::_sortByLengthDate::Manip::TZ_Base::_sortByLength
0000s0sDate::Manip::TZ_Base::::_update_nowDate::Manip::TZ_Base::_update_now
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
1package Date::Manip::TZ_Base;
2# Copyright (c) 2010-2014 Sullivan Beck. All rights reserved.
3# This program is free software; you can redistribute it and/or modify it
4# under the same terms as Perl itself.
5
6########################################################################
7########################################################################
8
918µsrequire 5.010000;
10226µs221µs
# spent 16µs (12+5) within Date::Manip::TZ_Base::BEGIN@10 which was called: # once (12µs+5µs) by Date::Manip::Base::BEGIN@15 at line 10
use warnings;
# spent 16µs making 1 call to Date::Manip::TZ_Base::BEGIN@10 # spent 5µs making 1 call to warnings::import
11220µs226µs
# spent 17µs (8+9) within Date::Manip::TZ_Base::BEGIN@11 which was called: # once (8µs+9µs) by Date::Manip::Base::BEGIN@15 at line 11
use strict;
# spent 17µs making 1 call to Date::Manip::TZ_Base::BEGIN@11 # spent 9µs making 1 call to strict::import
1221.60ms2186µs
# spent 97µs (8+89) within Date::Manip::TZ_Base::BEGIN@12 which was called: # once (8µs+89µs) by Date::Manip::Base::BEGIN@15 at line 12
use IO::File;
# spent 97µs making 1 call to Date::Manip::TZ_Base::BEGIN@12 # spent 89µs making 1 call to Exporter::import
13
1410sour ($VERSION);
151300ns$VERSION='6.47';
1613µs
# spent 2µs within Date::Manip::TZ_Base::END which was called: # once (2µs+0s) by main::RUNTIME at line 131 of C4/Service.pm
END { undef $VERSION; }
17
18########################################################################
19# METHODS
20########################################################################
21
22
# spent 11.5ms (109µs+11.4) within Date::Manip::TZ_Base::_config_var which was called 29 times, avg 395µs/call: # 2 times (7µs+9.25ms) by Date::Manip::Base::_init_config at line 201 of Date/Manip/Base.pm, avg 4.63ms/call # 2 times (7µs+191µs) by Date::Manip::Base::_init_config at line 190 of Date/Manip/Base.pm, avg 99µs/call # 2 times (7µs+141µs) by Date::Manip::Base::_init_config at line 191 of Date/Manip/Base.pm, avg 74µs/call # 2 times (19µs+64µs) by Date::Manip::Base::_init_config at line 199 of Date/Manip/Base.pm, avg 41µs/call # 2 times (6µs+68µs) by Date::Manip::Base::_init_config at line 200 of Date/Manip/Base.pm, avg 37µs/call # 2 times (11µs+57µs) by Date::Manip::Base::_init_config at line 189 of Date/Manip/Base.pm, avg 34µs/call # 2 times (5µs+32µs) by Date::Manip::Base::_init_config at line 198 of Date/Manip/Base.pm, avg 19µs/call # 2 times (7µs+28µs) by Date::Manip::Base::_init_config at line 202 of Date/Manip/Base.pm, avg 18µs/call # 2 times (6µs+16µs) by Date::Manip::Base::_init_config at line 203 of Date/Manip/Base.pm, avg 11µs/call # 2 times (6µs+15µs) by Date::Manip::Base::_init_config at line 195 of Date/Manip/Base.pm, avg 10µs/call # 2 times (6µs+10µs) by Date::Manip::Base::_init_config at line 192 of Date/Manip/Base.pm, avg 8µs/call # 2 times (6µs+6µs) by Date::Manip::Base::_init_config at line 194 of Date/Manip/Base.pm, avg 6µs/call # 2 times (6µs+4µs) by Date::Manip::Base::_init_config at line 197 of Date/Manip/Base.pm, avg 5µs/call # 2 times (6µs+4µs) by Date::Manip::Base::_init_config at line 196 of Date/Manip/Base.pm, avg 5µs/call # once (6µs+1.47ms) by Date::Manip::Obj::config at line 250 of Date/Manip/Obj.pm
sub _config_var {
23298µs my($self,$var,$val) = @_;
24298µs $var = lc($var);
25
26 # A simple flag used to force a new configuration, but has
27 # no other affect.
28295µs return if ($var eq 'ignore');
29
30298µs my $istz = ref($self) eq 'Date::Manip::TZ';
31
32298µs11.47ms if ($istz && ($var eq 'tz' ||
# spent 1.47ms making 1 call to Date::Manip::TZ::_config_var_tz
33 $var eq 'forcedate' ||
34 $var eq 'setdate' ||
35 $var eq 'configfile')) {
36 return $self->_config_var_tz($var,$val);
37 } else {
38283µs my $base = ($istz ? $$self{'base'} : $self);
392863µs289.89ms return $base->_config_var_base($var,$val);
# spent 9.89ms making 28 calls to Date::Manip::Base::_config_var_base, avg 353µs/call
40 }
41}
42
43# This reads a config file
44#
45sub _config_file {
46 my($self,$file) = @_;
47
48 return if (! $file);
49
50 if (! -f $file) {
51 warn "ERROR: [config_file] file doesn't exist: $file\n";
52 return;
53 }
54 if (! -r $file) {
55 warn "ERROR: [config_file] file not readable: $file\n";
56 return;
57 }
58
59 my $in = new IO::File;
60 if (! $in->open($file)) {
61 warn "ERROR: [config_file] unable to open file: $file: $!\n";
62 return;
63 }
64 my @in = <$in>;
65 $in->close();
66
67 my $sect = 'conf';
68 my %sect;
69
70 chomp(@in);
71 foreach my $line (@in) {
72 $line =~ s/^\s+//o;
73 $line =~ s/\s+$//o;
74 next if (! $line or $line =~ /^\043/o);
75
76 if ($line =~ /^\*/o) {
77 # New section
78 $sect = $self->_config_file_section($line);
79 } else {
80 $sect{$sect} = 1;
81 $self->_config_file_var($sect,$line);
82 }
83 }
84
85 # If we did a holidays section, we need to create a regular
86 # expression with all of the holiday names.
87
88 my $istz = ref($self) eq 'Date::Manip::TZ';
89 my $base = ($istz ? $$self{'base'} : $self);
90
91 if (exists $sect{'holidays'}) {
92 my @hol = @{ $$base{'data'}{'sections'}{'holidays'} };
93 my @nam;
94 while (@hol) {
95 my $junk = shift(@hol);
96 my $hol = shift(@hol);
97 push(@nam,$hol) if ($hol);
98 }
99
100 if (@nam) {
101 @nam = sort _sortByLength(@nam);
102 my $hol = '(?<holiday>' . join('|',map { "\Q$_\E" } @nam) . ')';
103 my $yr = '(?<y>\d\d\d\d|\d\d)';
104
105 my $rx = "$hol\\s*$yr|" . # Christmas 2009
106 "$yr\\s*$hol|" . # 2009 Christmas
107 "$hol"; # Christmas
108
109 $$base{'data'}{'rx'}{'holidays'} = qr/^(?:$rx)$/i;
110 }
111 }
112}
113
114sub _config_file_section {
115 my($self,$line) = @_;
116
117 my $istz = ref($self) eq 'Date::Manip::TZ';
118 my $base = ($istz ? $$self{'base'} : $self);
119
120 $line =~ s/^\*//o;
121 $line =~ s/\s*$//o;
122 my $sect = lc($line);
123 if (! exists $$base{'data'}{'sections'}{$sect}) {
124 warn "WARNING: [config_file] unknown section created: $sect\n";
125 $base->_section($sect);
126 }
127 return $sect;
128}
129
130sub _config_file_var {
131 my($self,$sect,$line) = @_;
132
133 my $istz = ref($self) eq 'Date::Manip::TZ';
134 my $base = ($istz ? $$self{'base'} : $self);
135
136 my($var,$val);
137 if ($line =~ /^\s*(.*?)\s*=\s*(.*?)\s*$/o) {
138 ($var,$val) = ($1,$2);
139 } else {
140 die "ERROR: invalid Date::Manip config file line:\n $line\n";
141 }
142
143 if ($sect eq 'conf') {
144 $var = lc($var);
145 $self->_config($var,$val);
146 } else {
147 $base->_section($sect,$var,$val);
148 }
149}
150
151# $val = $self->config(VAR);
152# Returns the value of a variable.
153#
154# $self->config([SECT], VAR, VAL) sets the value of a variable
155# Sets the value of a variable.
156#
157
# spent 37µs within Date::Manip::TZ_Base::_config which was called 13 times, avg 3µs/call: # 4 times (12µs+0s) by Date::Manip::Base::_calc_workweek at line 213 of Date/Manip/Base.pm, avg 3µs/call # 4 times (7µs+0s) by Date::Manip::Base::_calc_workweek at line 214 of Date/Manip/Base.pm, avg 2µs/call # 2 times (6µs+0s) by Date::Manip::Base::_config_var_workweekbeg at line 1233 of Date/Manip/Base.pm, avg 3µs/call # 2 times (4µs+0s) by Date::Manip::Base::_config_var_workweekend at line 1250 of Date/Manip/Base.pm, avg 2µs/call # once (8µs+0s) by Date::Manip::Recur::_init at line 90 of Date/Manip/Recur.pm
sub _config {
158135µs my($self,$var,$val) = @_;
159
160132µs my $sect = 'conf';
161
162 #
163 # $self->_conf(VAR, VAL) sets the value of a variable
164 #
165
166135µs $var = lc($var);
167132µs if (defined $val) {
168 return $self->_config_var($var,$val);
169 }
170
171 #
172 # $self->_conf(VAR) returns the value of a variable
173 #
174
1751338µs if (exists $$self{'data'}{'sections'}{$sect}{$var}) {
176 return $$self{'data'}{'sections'}{$sect}{$var};
177 } else {
178 warn "ERROR: [config] invalid config variable: $var\n";
179 return '';
180 }
181}
182
183########################################################################
184
185sub _fix_year {
186 my($self,$y) = @_;
187 my $istz = ref($self) eq 'Date::Manip::TZ';
188 my $base = ($istz ? $self->base() : $self);
189
190 my $method = $base->_config('yytoyyyy');
191
192 return $y if (length($y)==4);
193 return undef if (length($y)!=2);
194
195 my $curr_y;
196 if (ref($self) eq 'Date::Manip::TZ') {
197 $curr_y = $self->_now('y',1);
198 } else {
199 $curr_y = ( localtime(time) )[5];
200 $curr_y += 1900;
201 }
202
203 if ($method eq 'c') {
204 return substr($curr_y,0,2) . $y;
205
206 } elsif ($method =~ /^c(\d\d)$/) {
207 return "$1$y";
208
209 } elsif ($method =~ /^c(\d\d)(\d\d)$/) {
210 return "$1$y" + ($y<$2 ? 100 : 0);
211
212 } else {
213 my $y1 = $curr_y - $method;
214 my $y2 = $y1 + 99;
215 $y1 =~ /^(\d\d)/;
216 $y = "$1$y";
217 if ($y<$y1) {
218 $y += 100;
219 }
220 if ($y>$y2) {
221 $y -= 100;
222 }
223 return $y;
224 }
225}
226
227###############################################################################
228# Functions for setting the default date/time
229
230# Many date operations use a default time and/or date to set some
231# or all values. This function may be used to set or examine the
232# default time.
233#
234# _now allows you to get the current date and/or time in the
235# local timezone.
236#
237# The function performed depends on $op and are described in the
238# following table:
239#
240# $op function
241# ------------------ ----------------------------------
242# undef Returns the current default values
243# (y,m,d,h,mn,s) without updating
244# the time (it'll update if it has
245# never been set).
246#
247# 'now' Updates now and returns
248# (y,m,d,h,mn,s)
249#
250# 'time' Updates now and Returns (h,mn,s)
251#
252# 'y' Returns the default value of one
253# 'm' of the fields (no update)
254# 'd'
255# 'h'
256# 'mn'
257# 's'
258#
259# 'systz' Returns the system timezone
260#
261# 'isdst' Returns the 'now' values if set,
262# 'tz' or system time values otherwise.
263# 'offset'
264# 'abb'
265#
266sub _now {
267 my($self,$op,$noupdate) = @_;
268 my $istz = ref($self) eq 'Date::Manip::TZ';
269 my $base = ($istz ? $self->base() : $self);
270
271 # Update "NOW" if we're checking 'now', 'time', or the date
272 # is not set already.
273
274 if (! defined $noupdate) {
275 if ($op =~ /(?:now|time)/) {
276 $noupdate = 0;
277 } else {
278 $noupdate = 1;
279 }
280 }
281 $noupdate = 0 if (! exists $$base{'data'}{'now'}{'date'});
282 $self->_update_now() unless ($noupdate);
283
284 # Now return the value of the operation
285
286 my @tmpnow = @{ $$base{'data'}{'tmpnow'} };
287 my @now = (@tmpnow ? @tmpnow : @{ $$base{'data'}{'now'}{'date'} });
288
289 if ($op eq 'tz') {
290 if (exists $$base{'data'}{'now'}{'tz'}) {
291 return $$base{'data'}{'now'}{'tz'};
292 } else {
293 return $$base{'data'}{'now'}{'systz'};
294 }
295
296 } elsif ($op eq 'systz') {
297 return $$base{'data'}{'now'}{'systz'};
298
299 } elsif ($op eq 'isdst') {
300 return $$base{'data'}{'now'}{'isdst'};
301
302 } elsif ($op eq 'offset') {
303 return @{ $$base{'data'}{'now'}{'offset'} };
304
305 } elsif ($op eq 'abb') {
306 return $$base{'data'}{'now'}{'abb'};
307
308 } elsif ($op eq 'now') {
309 return @now;
310
311 } elsif ($op eq 'y') {
312 return $now[0];
313
314 } elsif ($op eq 'time') {
315 return @now[3..5];
316
317 } elsif ($op eq 'm') {
318 return $now[1];
319
320 } elsif ($op eq 'd') {
321 return $now[2];
322
323 } elsif ($op eq 'h') {
324 return $now[3];
325
326 } elsif ($op eq 'mn') {
327 return $now[4];
328
329 } elsif ($op eq 's') {
330 return $now[5];
331
332 } else {
333 warn "ERROR: [now] invalid argument list: $op\n";
334 return ();
335 }
336}
337
338sub _update_now {
339 my($self) = @_;
340 my $istz = ref($self) eq 'Date::Manip::TZ';
341 my $base = ($istz ? $self->base() : $self);
342
343 # If we've called ForceDate, don't change it.
344 return if ($$base{'data'}{'now'}{'force'});
345
346 # If we've called SetDate (which will only happen if a
347 # Date::Manip:TZ object is available), figure out what 'now' is
348 # based on the number of seconds that have elapsed since it was
349 # set. This will ONLY happen if TZ has been loaded.
350
351 if ($$base{'data'}{'now'}{'set'}) {
352 my $date = $$base{'data'}{'now'}{'setdate'};
353 my $secs = time - $$base{'data'}{'now'}{'setsecs'};
354
355 $date = $base->calc_date_time($date,[0,0,$secs]); # 'now' in GMT
356 my $zone = $self->_now('tz',1);
357 my ($err,$date2,$offset,$isdst,$abbrev) = $self->convert_from_gmt($date,$zone);
358
359 $$base{'data'}{'now'}{'date'} = $date2;
360 $$base{'data'}{'now'}{'isdst'} = $isdst;
361 $$base{'data'}{'now'}{'offset'} = $offset;
362 $$base{'data'}{'now'}{'abb'} = $abbrev;
363 return;
364 }
365
366 # Otherwise, we'll use the system time.
367
368 my $time = time;
369 my($s,$mn,$h,$d,$m,$y,$wday,$yday,$isdst) = localtime($time);
370 my($s0,$mn0,$h0,$d0,$m0,$y0) = gmtime($time);
371
372 $y += 1900;
373 $m++;
374
375 $y0 += 1900;
376 $m0++;
377
378 my $off = $base->calc_date_date([$y,$m,$d,$h,$mn,$s],[$y0,$m0,$d0,$h0,$mn0,$s0],1);
379
380 $$base{'data'}{'now'}{'date'} = [$y,$m,$d,$h,$mn,$s];
381 $$base{'data'}{'now'}{'isdst'} = $isdst;
382 $$base{'data'}{'now'}{'offset'}= $off;
383
384 my $abb = '???';
385 if (ref($self) eq 'Date::Manip::TZ') {
386 my $zone = $self->_now('tz',1);
387 my $per = $self->date_period([$y,$m,$d,$h,$mn,$s],$zone,1,$isdst);
388 $abb = $$per[4];
389 }
390
391 $$base{'data'}{'now'}{'abb'} = $abb;
392
393 return;
394}
395
396###############################################################################
397# This sorts from longest to shortest element
398#
399245µs229µs
# spent 18µs (7+11) within Date::Manip::TZ_Base::BEGIN@399 which was called: # once (7µs+11µs) by Date::Manip::Base::BEGIN@15 at line 399
no strict 'vars';
# spent 18µs making 1 call to Date::Manip::TZ_Base::BEGIN@399 # spent 11µs making 1 call to strict::unimport
400sub _sortByLength {
401 return (length $b <=> length $a);
402}
403225µs220µs
# spent 12µs (5+7) within Date::Manip::TZ_Base::BEGIN@403 which was called: # once (5µs+7µs) by Date::Manip::Base::BEGIN@15 at line 403
use strict 'vars';
# spent 12µs making 1 call to Date::Manip::TZ_Base::BEGIN@403 # spent 7µs making 1 call to strict::import
404
40512µs1;
406# Local Variables:
407# mode: cperl
408# indent-tabs-mode: nil
409# cperl-indent-level: 3
410# cperl-continued-statement-offset: 2
411# cperl-continued-brace-offset: 0
412# cperl-brace-offset: 0
413# cperl-brace-imaginary-offset: 0
414# cperl-label-offset: 0
415# End:
Report produced by the NYTProf 5.06 Perl profiler, developed by Tim Bunce and Adam Kaplan.