← Index
NYTProf Performance Profile   « block view • line view • sub view »
For /usr/share/koha/opac/cgi-bin/opac/opac-search.pl
  Run on Tue Oct 15 11:58:52 2013
Reported on Tue Oct 15 12:01:04 2013

Filename/usr/share/perl5/Date/Manip/Base.pm
StatementsExecuted 7978 statements in 29.7ms
Subroutines
Calls P F Exclusive
Time		 Inclusive
Time		 Subroutine
261316.79ms9.28msDate::Manip::Base::::_rx_wordlistsDate::Manip::Base::_rx_wordlists
296412.62ms2.62msDate::Manip::Base::::CORE:sortDate::Manip::Base::CORE:sort (opcode)
2111.17ms14.8msDate::Manip::Base::::_languageDate::Manip::Base::_language
37192943µs18.4msDate::Manip::Base::::_config_varDate::Manip::Base::_config_var
631477µs810µsDate::Manip::Base::::_rx_replaceDate::Manip::Base::_rx_replace
1051298µs382µsDate::Manip::Base::::_rx_wordlistDate::Manip::Base::_rx_wordlist
211271µs17.2msDate::Manip::Base::::_init_configDate::Manip::Base::_init_config
2331236µs236µsDate::Manip::Base::::CORE:regcompDate::Manip::Base::CORE:regcomp (opcode)
3251232µs303µsDate::Manip::Base::::_is_intDate::Manip::Base::_is_int
821214µs444µsDate::Manip::Base::::_normalize_hmsDate::Manip::Base::_normalize_hms
8561174µs174µsDate::Manip::Base::::CORE:matchDate::Manip::Base::CORE:match (opcode)
111173µs1.52msDate::Manip::Base::::_config_var_setdateDate::Manip::Base::_config_var_setdate
3921112µs112µsDate::Manip::Base::::_init_dataDate::Manip::Base::_init_data
421109µs715µsDate::Manip::Base::::_config_var_workdaybegendDate::Manip::Base::_config_var_workdaybegend
42295µs129µsDate::Manip::Base::::_osDate::Manip::Base::_os
266191µs91µsDate::Manip::Base::::CORE:qrDate::Manip::Base::CORE:qr (opcode)
41179µs319µsDate::Manip::Base::::splitDate::Manip::Base::split
21172µs17.4msDate::Manip::Base::::_initDate::Manip::Base::_init
41158µs287µsDate::Manip::Base::::joinDate::Manip::Base::join
95257µs57µsDate::Manip::Base::::_configDate::Manip::Base::_config
63156µs56µsDate::Manip::Base::::_rx_simpleDate::Manip::Base::_rx_simple
11142µs54µsDate::Manip::Base::::BEGIN@2029Date::Manip::Base::BEGIN@2029
21135µs72µsDate::Manip::Base::::_config_var_workweekbegDate::Manip::Base::_config_var_workweekbeg
41135µs35µsDate::Manip::Base::::_config_var_workday24hrDate::Manip::Base::_config_var_workday24hr
21133µs33µsDate::Manip::Base::::_init_eventsDate::Manip::Base::_init_events
42133µs33µsDate::Manip::Base::::_init_languageDate::Manip::Base::_init_language
21133µs61µsDate::Manip::Base::::_config_var_recurrangeDate::Manip::Base::_config_var_recurrange
11132µs41µsDate::Manip::Base::::BEGIN@2523Date::Manip::Base::BEGIN@2523
21130µs57µsDate::Manip::Base::::_config_var_workweekendDate::Manip::Base::_config_var_workweekend
21127µs27µsDate::Manip::Base::::_init_cacheDate::Manip::Base::_init_cache
21124µs38µsDate::Manip::Base::::_config_var_firstdayDate::Manip::Base::_config_var_firstday
21123µs23µsDate::Manip::Base::::_join_dateDate::Manip::Base::_join_date
21121µs53µsDate::Manip::Base::::_config_var_recurnumfudgedaysDate::Manip::Base::_config_var_recurnumfudgedays
11121µs54µsDate::Manip::Base::::BEGIN@1828Date::Manip::Base::BEGIN@1828
11119µs53µsDate::Manip::Base::::BEGIN@1845Date::Manip::Base::BEGIN@1845
11118µs18µsDate::Manip::Base::::BEGIN@14Date::Manip::Base::BEGIN@14
11116µs214µsDate::Manip::Base::::BEGIN@21Date::Manip::Base::BEGIN@21
11116µs21µsDate::Manip::Base::::BEGIN@378Date::Manip::Base::BEGIN@378
11116µs88µsDate::Manip::Base::::BEGIN@17Date::Manip::Base::BEGIN@17
21115µs15µsDate::Manip::Base::::_init_holidaysDate::Manip::Base::_init_holidays
21115µs15µsDate::Manip::Base::::_init_nowDate::Manip::Base::_init_now
11115µs19µsDate::Manip::Base::::BEGIN@18Date::Manip::Base::BEGIN@18
11113µs17µsDate::Manip::Base::::BEGIN@562Date::Manip::Base::BEGIN@562
11113µs16µsDate::Manip::Base::::BEGIN@2568Date::Manip::Base::BEGIN@2568
11112µs28µsDate::Manip::Base::::BEGIN@2025Date::Manip::Base::BEGIN@2025
11112µs25µsDate::Manip::Base::::BEGIN@22Date::Manip::Base::BEGIN@22
11112µs27µsDate::Manip::Base::::BEGIN@1894Date::Manip::Base::BEGIN@1894
21112µs12µsDate::Manip::Base::::_config_var_defaulttimeDate::Manip::Base::_config_var_defaulttime
11110µs38µsDate::Manip::Base::::BEGIN@25Date::Manip::Base::BEGIN@25
11110µs23µsDate::Manip::Base::::BEGIN@19Date::Manip::Base::BEGIN@19
11110µs12µsDate::Manip::Base::::BEGIN@20Date::Manip::Base::BEGIN@20
2118µs8µsDate::Manip::Base::::cmpDate::Manip::Base::cmp
0000s0sDate::Manip::Base::::_ExpandTildeDate::Manip::Base::_ExpandTilde
0000s0sDate::Manip::Base::::_SearchPathDate::Manip::Base::_SearchPath
0000s0sDate::Manip::Base::::_calc_date_time_stringsDate::Manip::Base::_calc_date_time_strings
0000s0sDate::Manip::Base::::_calc_date_ymwdDate::Manip::Base::_calc_date_ymwd
0000s0sDate::Manip::Base::::_calc_hms_hmsDate::Manip::Base::_calc_hms_hms
0000s0sDate::Manip::Base::::_config_fileDate::Manip::Base::_config_file
0000s0sDate::Manip::Base::::_config_file_sectionDate::Manip::Base::_config_file_section
0000s0sDate::Manip::Base::::_config_file_varDate::Manip::Base::_config_file_var
0000s0sDate::Manip::Base::::_critical_dateDate::Manip::Base::_critical_date
0000s0sDate::Manip::Base::::_delta_convertDate::Manip::Base::_delta_convert
0000s0sDate::Manip::Base::::_fix_yearDate::Manip::Base::_fix_year
0000s0sDate::Manip::Base::::_methodDate::Manip::Base::_method
0000s0sDate::Manip::Base::::_mod_addDate::Manip::Base::_mod_add
0000s0sDate::Manip::Base::::_normalize_businessDate::Manip::Base::_normalize_business
0000s0sDate::Manip::Base::::_normalize_dateDate::Manip::Base::_normalize_date
0000s0sDate::Manip::Base::::_normalize_deltaDate::Manip::Base::_normalize_delta
0000s0sDate::Manip::Base::::_normalize_dhmsDate::Manip::Base::_normalize_dhms
0000s0sDate::Manip::Base::::_normalize_offsetDate::Manip::Base::_normalize_offset
0000s0sDate::Manip::Base::::_normalize_timeDate::Manip::Base::_normalize_time
0000s0sDate::Manip::Base::::_normalize_wDate::Manip::Base::_normalize_w
0000s0sDate::Manip::Base::::_normalize_wdhmsDate::Manip::Base::_normalize_wdhms
0000s0sDate::Manip::Base::::_normalize_ymDate::Manip::Base::_normalize_ym
0000s0sDate::Manip::Base::::_nowDate::Manip::Base::_now
0000s0sDate::Manip::Base::::_sectionDate::Manip::Base::_section
0000s0sDate::Manip::Base::::_sortByLengthDate::Manip::Base::_sortByLength
0000s0sDate::Manip::Base::::_update_nowDate::Manip::Base::_update_now
0000s0sDate::Manip::Base::::_week1_day1Date::Manip::Base::_week1_day1
0000s0sDate::Manip::Base::::_week_of_yearDate::Manip::Base::_week_of_year
0000s0sDate::Manip::Base::::_weeks_in_yearDate::Manip::Base::_weeks_in_year
0000s0sDate::Manip::Base::::calc_date_dateDate::Manip::Base::calc_date_date
0000s0sDate::Manip::Base::::calc_date_daysDate::Manip::Base::calc_date_days
0000s0sDate::Manip::Base::::calc_date_deltaDate::Manip::Base::calc_date_delta
0000s0sDate::Manip::Base::::calc_date_timeDate::Manip::Base::calc_date_time
0000s0sDate::Manip::Base::::calc_time_timeDate::Manip::Base::calc_time_time
0000s0sDate::Manip::Base::::checkDate::Manip::Base::check
0000s0sDate::Manip::Base::::check_timeDate::Manip::Base::check_time
0000s0sDate::Manip::Base::::configDate::Manip::Base::config
0000s0sDate::Manip::Base::::day_of_weekDate::Manip::Base::day_of_week
0000s0sDate::Manip::Base::::day_of_yearDate::Manip::Base::day_of_year
0000s0sDate::Manip::Base::::days_in_monthDate::Manip::Base::days_in_month
0000s0sDate::Manip::Base::::days_in_yearDate::Manip::Base::days_in_year
0000s0sDate::Manip::Base::::days_since_1BCDate::Manip::Base::days_since_1BC
0000s0sDate::Manip::Base::::leapyearDate::Manip::Base::leapyear
0000s0sDate::Manip::Base::::nth_day_of_weekDate::Manip::Base::nth_day_of_week
0000s0sDate::Manip::Base::::secs_since_1970Date::Manip::Base::secs_since_1970
0000s0sDate::Manip::Base::::week1_day1Date::Manip::Base::week1_day1
0000s0sDate::Manip::Base::::week_of_yearDate::Manip::Base::week_of_year
0000s0sDate::Manip::Base::::weeks_in_yearDate::Manip::Base::weeks_in_year
Call graph for these subroutines as a Graphviz dot language file.
Line State
ments		 Time
on line		 Calls Time
in subs		 Code
0188µsProfile data that couldn't be associated with a specific line:
# spent 88µs making 1 call to Date::Manip::Base::BEGIN@17
1112µspackage Date::Manip::Base;
2# Copyright (c) 1995-2010 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# Any routine that starts with an underscore (_) is NOT intended for
8# public use. They are for internal use in the the Date::Manip
9# modules and are subject to change without warning or notice.
10#
11# ABSOLUTELY NO USER SUPPORT IS OFFERED FOR THESE ROUTINES!
12###############################################################################
13
14380µs118µs
# spent 18µs within Date::Manip::Base::BEGIN@14 which was called: # once (18µs+0s) by Date::Manip::Obj::BEGIN@15 at line 14
use Date::Manip::Obj;
# spent 18µs making 1 call to Date::Manip::Base::BEGIN@14
15119µs@ISA = ('Date::Manip::Obj');
16
17475µs172µs
# spent 88µs (16+72) within Date::Manip::Base::BEGIN@17 which was called: # once (16µs+72µs) by Date::Manip::Obj::BEGIN@15 at line 0
require 5.010000;
# spent 72µs making 1 call to feature::import
18331µs224µs
# spent 19µs (15+5) within Date::Manip::Base::BEGIN@18 which was called: # once (15µs+5µs) by Date::Manip::Obj::BEGIN@15 at line 18
use strict;
# spent 19µs making 1 call to Date::Manip::Base::BEGIN@18 # spent 4µs making 1 call to strict::import
19327µs236µs
# spent 23µs (10+13) within Date::Manip::Base::BEGIN@19 which was called: # once (10µs+13µs) by Date::Manip::Obj::BEGIN@15 at line 19
use warnings;
# spent 23µs making 1 call to Date::Manip::Base::BEGIN@19 # spent 13µs making 1 call to warnings::import
20324µs215µs
# spent 12µs (10+3) within Date::Manip::Base::BEGIN@20 which was called: # once (10µs+3µs) by Date::Manip::Obj::BEGIN@15 at line 20
use integer;
# spent 12µs making 1 call to Date::Manip::Base::BEGIN@20 # spent 3µs making 1 call to integer::import
21344µs2413µs
# spent 214µs (16+198) within Date::Manip::Base::BEGIN@21 which was called: # once (16µs+198µs) by Date::Manip::Obj::BEGIN@15 at line 21
use IO::File;
# spent 214µs making 1 call to Date::Manip::Base::BEGIN@21 # spent 198µs making 1 call to Exporter::import
22353µs237µs
# spent 25µs (12+13) within Date::Manip::Base::BEGIN@22 which was called: # once (12µs+13µs) by Date::Manip::Obj::BEGIN@15 at line 22
use feature 'switch';
# spent 25µs making 1 call to Date::Manip::Base::BEGIN@22 # spent 13µs making 1 call to feature::import
231169µsrequire Date::Manip::Lang::index;
24
2531.34ms266µs
# spent 38µs (10+28) within Date::Manip::Base::BEGIN@25 which was called: # once (10µs+28µs) by Date::Manip::Obj::BEGIN@15 at line 25
use vars qw($VERSION);
# spent 38µs making 1 call to Date::Manip::Base::BEGIN@25 # spent 28µs making 1 call to vars::import
261900ns$VERSION='6.11';
27
28###############################################################################
29# BASE METHODS
30###############################################################################
31
32
# spent 17.4ms (72µs+17.3) within Date::Manip::Base::_init which was called 2 times, avg 8.69ms/call: # 2 times (72µs+17.3ms) by Date::Manip::Obj::new at line 152 of Date/Manip/Obj.pm, avg 8.69ms/call
sub _init {
331456µs my($self) = @_;
34
35227µs $self->_init_cache();
# spent 27µs making 2 calls to Date::Manip::Base::_init_cache, avg 13µs/call
36220µs $self->_init_language();
# spent 20µs making 2 calls to Date::Manip::Base::_init_language, avg 10µs/call
37217.2ms $self->_init_config();
# spent 17.2ms making 2 calls to Date::Manip::Base::_init_config, avg 8.60ms/call
38233µs $self->_init_events();
# spent 33µs making 2 calls to Date::Manip::Base::_init_events, avg 17µs/call
39215µs $self->_init_holidays();
# spent 15µs making 2 calls to Date::Manip::Base::_init_holidays, avg 8µs/call
40215µs $self->_init_now();
# spent 15µs making 2 calls to Date::Manip::Base::_init_now, avg 8µs/call
41}
42
43# The base object has some config-independant information which is
44# always reused, and only needs to be initialized once.
45
# spent 27µs within Date::Manip::Base::_init_cache which was called 2 times, avg 13µs/call: # 2 times (27µs+0s) by Date::Manip::Base::_init at line 35, avg 13µs/call
sub _init_cache {
461232µs my($self) = @_;
47 return if (exists $$self{'cache'}{'init'});
48 $$self{'cache'}{'init'} = 1;
49
50 # ly => {Y} = 0/1 1 if it is a leap year
51 # ds1_mon => {Y}{M} = N days since 1BC for Y/M/1
52 # dow_mon => {Y}{M} = DOW day of week of Y/M/1
53
54 $$self{'cache'}{'ly'} = {} if (! exists $$self{'cache'}{'ly'});
55 $$self{'cache'}{'ds1_mon'} = {} if (! exists $$self{'cache'}{'ds1_mon'});
56 $$self{'cache'}{'dow_mon'} = {} if (! exists $$self{'cache'}{'dow_mon'});
57}
58
59# Config dependent data. Needs to be reset every time the config is reset.
60
# spent 112µs within Date::Manip::Base::_init_data which was called 39 times, avg 3µs/call: # 37 times (100µs+0s) by Date::Manip::Base::_config_var at line 1327, avg 3µs/call # 2 times (12µs+0s) by Date::Manip::Base::_init_config at line 71, avg 6µs/call
sub _init_data {
6180164µs my($self,$force) = @_;
62 return if (exists $$self{'data'}{'calc'} && ! $force);
63
64 $$self{'data'}{'calc'} = {}; # Calculated values
65}
66
67# Initializes config dependent data
68
# spent 17.2ms (271µs+16.9) within Date::Manip::Base::_init_config which was called 2 times, avg 8.60ms/call: # 2 times (271µs+16.9ms) by Date::Manip::Base::_init at line 37, avg 8.60ms/call
sub _init_config {
6948210µs my($self,$force) = @_;
70 return if (exists $$self{'data'}{'sections'}{'conf'} && ! $force);
71212µs $self->_init_data();
# spent 12µs making 2 calls to Date::Manip::Base::_init_data, avg 6µs/call
72
73 $$self{'data'}{'sections'}{'conf'} =
74 {
75 # Reset config, holiday lists, or events lists
76 'defaults' => '',
77 'eraseholidays' => '',
78 'eraseevents' => '',
79
80 # Which language to use when parsing dates.
81 'language' => '',
82
83 # 12/10 = Dec 10 (US) or Oct 12 (anything else)
84 'dateformat' => '',
85
86 # Define the work week (1=monday, 7=sunday)
87 #
88 # These have to be predefined to avoid a bootstrap
89 # issue, but the true defaults are defined below.
90 'workweekbeg' => 1,
91 'workweekend' => 5,
92
93 # If non-nil, a work day is treated as 24 hours
94 # long (WorkDayBeg/WorkDayEnd ignored)
95 'workday24hr' => '',
96
97 # Start and end time of the work day (any time
98 # format allowed, seconds ignored). If the
99 # defaults change, be sure to change the starting
100 # value of bdlength above.
101 'workdaybeg' => '',
102 'workdayend' => '',
103
104 # 2 digit years fall into the 100
105 # year period given by [ CURR-N,
106 # CURR+(99-N) ] where N is 0-99.
107 # Default behavior is 89, but
108 # other useful numbers might be 0
109 # (forced to be this year or
110 # later) and 99 (forced to be this
111 # year or earlier). It can also
112 # be set to 'c' (current century)
113 # or 'cNN' (i.e. c18 forces the
114 # year to bet 1800-1899). Also
115 # accepts the form cNNNN to give
116 # the 100 year period NNNN to
117 # NNNN+99.
118 'yytoyyyy' => '',
119
120 # First day of the week (1=monday,
121 # 7=sunday). ISO 8601 says
122 # monday.
123 'firstday' => '',
124
125 # If this is 0, use the ISO 8601
126 # standard that Jan 4 is in week
127 # 1. If 1, make week 1 contain
128 # Jan 1.
129 'jan1week1' => '',
130
131 # Date::Manip printable format
132 # 0 = YYYYMMDDHH:MN:SS
133 # 1 = YYYYHHMMDDHHMNSS
134 # 2 = YYYY-MM-DD-HH:MN:SS
135 'printable' => '',
136
137 # If 'today' is a holiday, we look either to
138 # 'tomorrow' or 'yesterday' for the nearest
139 # business day. By default, we'll always look
140 # 'tomorrow' first.
141 'tomorrowfirst' => 1,
142
143 # Use an international character set.
144 'intcharset' => 0,
145
146 # Used to set the current date/time/timezone.
147 'forcedate' => 0,
148 'setdate' => 0,
149
150 # Use this to set the default range of the
151 # recurrence.
152 'recurrange' => '',
153
154 # Use this to set the fudge factor for days
155 # when applying business day modifiers.
156 'recurnumfudgedays' => 10,
157
158 # Use this to set the default time.
159 'defaulttime' => 'midnight',
160
161 # *** DEPRECATED ***
162 'tz' => '',
163 'convtz' => '',
164 'globalcnf' => '',
165 'ignoreglobalcnf' => '',
166 'personalcnf' => '',
167 'personalcnfpath' => '',
168 'pathsep' => '',
169 'oldconfigfiles' => '',
170 'internal' => '',
171 'resetworkday' => 0,
172 'deltasigns' => 0,
173 'updatecurrtz' => 0,
174 };
175
176 # Set config defaults
177
178 # In order to avoid a bootstrap issue, set the default work day here.
1792100µs $self->_config_var('workday24hr', 1);
# spent 100µs making 2 calls to Date::Manip::Base::_config_var, avg 50µs/call
1802496µs $self->_config_var('workdaybeg', '08:00:00');
# spent 496µs making 2 calls to Date::Manip::Base::_config_var, avg 248µs/call
1812317µs $self->_config_var('workdayend', '17:00:00');
# spent 317µs making 2 calls to Date::Manip::Base::_config_var, avg 159µs/call
182239µs $self->_config_var('workday24hr', 0);
# spent 39µs making 2 calls to Date::Manip::Base::_config_var, avg 19µs/call
183
184246µs $self->_config_var('dateformat', 'US');
# spent 46µs making 2 calls to Date::Manip::Base::_config_var, avg 23µs/call
185243µs $self->_config_var('yytoyyyy', 89);
# spent 43µs making 2 calls to Date::Manip::Base::_config_var, avg 22µs/call
186232µs $self->_config_var('jan1week1', 0);
# spent 32µs making 2 calls to Date::Manip::Base::_config_var, avg 16µs/call
187231µs $self->_config_var('printable', 0);
# spent 31µs making 2 calls to Date::Manip::Base::_config_var, avg 15µs/call
188277µs $self->_config_var('firstday', 1);
# spent 77µs making 2 calls to Date::Manip::Base::_config_var, avg 38µs/call
1892124µs $self->_config_var('workweekbeg', 1);
# spent 124µs making 2 calls to Date::Manip::Base::_config_var, avg 62µs/call
190289µs $self->_config_var('workweekend', 5);
# spent 89µs making 2 calls to Date::Manip::Base::_config_var, avg 45µs/call
191214.9ms $self->_config_var('language', 'english');
# spent 14.9ms making 2 calls to Date::Manip::Base::_config_var, avg 7.44ms/call
1922164µs $self->_config_var('recurrange', 'none');
# spent 164µs making 2 calls to Date::Manip::Base::_config_var, avg 82µs/call
1932123µs $self->_config_var('recurnumfudgedays',5);
# spent 123µs making 2 calls to Date::Manip::Base::_config_var, avg 61µs/call
194259µs $self->_config_var('defaulttime', 'midnight');
# spent 59µs making 2 calls to Date::Manip::Base::_config_var, avg 30µs/call
195
196 # Set OS specific defaults
197
198264µs my $os = $self->_os();
# spent 64µs making 2 calls to Date::Manip::Base::_os, avg 32µs/call
199
200 # *** DEPRECATED ***
201 if ($os eq 'Windows') {
202 $self->_config_var('pathsep',';');
203 $self->_config_var('personalcnf','Manip.cnf');
204 $self->_config_var('personalcnfpath','.');
205
206 } elsif ($os eq 'Other') {
207 $self->_config_var('pathsep',':');
208 $self->_config_var('personalcnf','Manip.cnf');
209 $self->_config_var('personalcnfpath','.');
210
211 } elsif ($os eq 'VMS') {
212 # VMS doesn't like files starting with '.'
213 $self->_config_var('pathsep',',');
214 $self->_config_var('personalcnf','Manip.cnf');
215 $self->_config_var('personalcnfpath','/sys$login');
216
217 } else {
218 # Unix
219297µs $self->_config_var('pathsep',':');
# spent 97µs making 2 calls to Date::Manip::Base::_config_var, avg 49µs/call
220261µs $self->_config_var('personalcnf','.DateManip.cnf');
# spent 61µs making 2 calls to Date::Manip::Base::_config_var, avg 31µs/call
221270µs $self->_config_var('personalcnfpath','.:~');
# spent 70µs making 2 calls to Date::Manip::Base::_config_var, avg 35µs/call
222 }
223}
224
225# Events and holidays are reset only when they are read in.
226
# spent 33µs within Date::Manip::Base::_init_events which was called 2 times, avg 17µs/call: # 2 times (33µs+0s) by Date::Manip::Base::_init at line 38, avg 17µs/call
sub _init_events {
2271235µs my($self,$force) = @_;
228 return if (exists $$self{'data'}{'events'} && ! $force);
229
230 # {data}{sections}{events} = [ STRING, EVENT_NAME, ... ]
231 #
232 # {data}{events}{I}{type} = TYPE
233 # {name} = NAME
234 # TYPE: specified An event with a start/end date (only parsed once)
235 # {beg} = DATE_OBJECT
236 # {end} = DATE_OBJECT
237 # TYPE: ym
238 # {beg} = YM_STRING
239 # {end} = YM_STRING (only for YM;YM)
240 # {YEAR} = [ DATE_OBJECT, DATE_OBJECT ]
241 # TYPE: date An event specified by a date string and delta
242 # {beg} = DATE_STRING
243 # {end} = DATE_STRING (only for Date;Date)
244 # {delta} = DELTA_OBJECT (only for Date;Delta)
245 # {YEAR} = [ DATE_OBJECT, DATE_OBJECT ]
246 # TYPE: recur
247 # {recur} = RECUR_OBJECT
248 # {delta} = DELTA_OBJECT
249 #
250 # {data}{eventyears}{YEAR} = 0/1
251 # {data}{eventobjs} = 0/1
252
253 $$self{'data'}{'events'} = {};
254 $$self{'data'}{'sections'}{'events'} = [];
255 $$self{'data'}{'eventyears'} = {};
256 $$self{'data'}{'eventobjs'} = 0;
257}
258
259
# spent 15µs within Date::Manip::Base::_init_holidays which was called 2 times, avg 8µs/call: # 2 times (15µs+0s) by Date::Manip::Base::_init at line 39, avg 8µs/call
sub _init_holidays {
260818µs my($self,$force) = @_;
261 return if (exists $$self{'data'}{'holidays'} && ! $force);
262
263 # {data}{sections}{holidays} = [ STRING, HOLIDAY_NAME, ... ]
264 #
265 # {data}{holidays}{YEAR} = 1 if this year has been parsed
266 # 2 if YEAR-1 and YEAR+1 have been parsed
267 # (both must be done before holidays can
268 # be known so that New Years can be
269 # celebrated on Dec 31 if Jan 1 is weekend)
270 # {date} = DATE_OBJ
271 # a Date::Manip::Date object to use for holidays
272 # {hols} = [ RECUR_OBJ|DATE_STRING, HOLIDAY_NAME, ... ]
273 # DATE_STRING is suitable for parse_date
274 # using DATE_OBJ. RECUR_OBJ is a Date::Manip::Recur
275 # object that can be used once the start and
276 # end date is set.
277 # {dates} = { Y => M => D => NAME }
278
279 $$self{'data'}{'holidays'} = {};
280 $$self{'data'}{'sections'}{'holidays'} = [];
281}
282
283
# spent 15µs within Date::Manip::Base::_init_now which was called 2 times, avg 8µs/call: # 2 times (15µs+0s) by Date::Manip::Base::_init at line 40, avg 8µs/call
sub _init_now {
284819µs my($self) = @_;
285
286 # {'data'}{'now'} = {
287 # date => [Y,M,D,H,MN,S] now
288 # isdst => ISDST
289 # offset => [H,MN,S]
290 # abb => ABBREV
291 #
292 # force => 0/1 SetDate/ForceDate information
293 # set => 0/1
294 # setsecs => SECS time (in secs since epoch) when
295 # SetDate was called
296 # setdate => [Y,M,D,H,MN,S] the date (IN GMT) we're calling
297 # now when SetDate was called
298 #
299 # tz => ZONE timezone we're working in
300 # systz => ZONE timezone of the system
301 # }
302 #
303
304 $$self{'data'}{'now'} = {};
305 $$self{'data'}{'now'}{'force'} = 0;
306 $$self{'data'}{'now'}{'set'} = 0;
307}
308
309# Language information only needs to be initialized if the language changes.
310
# spent 33µs within Date::Manip::Base::_init_language which was called 4 times, avg 8µs/call: # 2 times (20µs+0s) by Date::Manip::Base::_init at line 36, avg 10µs/call # 2 times (13µs+0s) by Date::Manip::Base::_language at line 1840, avg 6µs/call
sub _init_language {
3112441µs my($self,$force) = @_;
312 return if (exists $$self{'data'}{'lang'} && ! $force);
313
314 $$self{'data'}{'lang'} = {}; # Current language info
315 $$self{'data'}{'rx'} = {}; # Regexps generated from language
316 $$self{'data'}{'words'} = {}; # Types of words in the language
317 $$self{'data'}{'wordval'} = {}; # Value of words in the language
318}
319
320sub config {
321 my($self,@config) = @_;
322
323 while (@config) {
324 my $var = shift(@config);
325 my $val = shift(@config);
326 $self->_config_var($var,$val);
327 }
328}
329
330###############################################################################
331# MAIN METHODS
332###############################################################################
333
334sub leapyear {
335 my($self,$y) = @_;
336 $y += 0;
337 return $$self{'cache'}{'ly'}{$y}
338 if (exists $$self{'cache'}{'ly'}{$y});
339
340 $$self{'cache'}{'ly'}{$y} = 0, return 0 unless ($y % 4 == 0);
341 $$self{'cache'}{'ly'}{$y} = 1, return 1 unless ($y % 100 == 0);
342 $$self{'cache'}{'ly'}{$y} = 0, return 0 unless ($y % 400 == 0);
343 $$self{'cache'}{'ly'}{$y} = 1, return 1;
344}
345
346sub days_in_year {
347 my($self,$y) = @_;
348 return ($self->leapyear($y) ? 366 : 365);
349}
350
351{
35223µs my(@leap)=(31,29,31,30, 31,30,31,31, 30,31,30,31);
35311µs my(@nonl)=(31,28,31,30, 31,30,31,31, 30,31,30,31);
354
355 sub days_in_month {
356 my($self,$y,$m) = @_;
357
358 if ($m) {
359 return ($self->leapyear($y) ? $leap[$m-1] : $nonl[$m-1]);
360 } else {
361 return ($self->leapyear($y) ? @leap : @nonl);
362 }
363 }
364}
365
366{
367 # DinM = (31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31)
36822µs my(@doy_days) = ( 0, 31, 59, 90,120,151,181,212,243,273,304,334,365);
369
370 # Note: I tested storing both leap year and non-leap year days in
371 # a hash, but it was slightly slower.
372
37311µs my($lyd,$n,$remain,$day,$y,$m,$d,$h,$mn,$s,$arg);
374
375 sub day_of_year {
376 my($self,@args) = @_;
377
37831.03ms227µs
# spent 21µs (16+5) within Date::Manip::Base::BEGIN@378 which was called: # once (16µs+5µs) by Date::Manip::Obj::BEGIN@15 at line 378
no integer;
# spent 21µs making 1 call to Date::Manip::Base::BEGIN@378 # spent 5µs making 1 call to integer::unimport
379 if ($#args == 1) {
380
381 # $date = day_of_year($y,$day);
382 ($y,$n) = @args;
383
384 $lyd = $self->leapyear($y);
385 $remain = ($n - int($n));
386 $n = int($n);
387
388 # Calculate the month and the day
389 for ($m=1; $m<=12; $m++) {
390 last if ($n<=($doy_days[$m] + ($m==1 ? 0 : $lyd)));
391 }
392 $d = $n-($doy_days[$m-1] + (($m-1)<2 ? 0 : $lyd));
393 return [$y,$m,$d] if (! $remain);
394
395 # Calculate the hours, minutes, and seconds into the day.
396 $remain *= 24;
397 $h = int($remain);
398 $remain = ($remain - $h)*60;
399 $mn = int($remain);
400 $remain = ($remain - $mn)*60;
401 $s = $remain;
402
403 return [$y,$m,$d,$h,$mn,$s];
404
405 } else {
406 $arg = $args[0];
407 @args = @$arg;
408
409 ($y,$m,$d,$h,$mn,$s) = @args;
410 $lyd = $self->leapyear($y);
411 $lyd = 0 if ($m <= 2);
412 $day = ($doy_days[$m-1]+$d+$lyd);
413 return $day if ($#args==2);
414
415 $day += ($h*3600 + $mn*60 + $s)/(24*3600);
416 return $day;
417 }
418 }
419}
420
421sub days_since_1BC {
422 my($self,$arg) = @_;
423
424 if (ref($arg)) {
425 my($y,$m,$d) = @$arg;
426 $y += 0;
427 $m += 0;
428
429 if (! exists $$self{'cache'}{'ds1_mon'}{$y}{$m}) {
430
431 if (! exists $$self{'cache'}{'ds1_mon'}{$y}{1}) {
432
433 my($Ny,$N4,$N100,$N400,$cc,$yy);
434
435 my $yyyy = "0000$y";
436
437 $yyyy =~ /(\d\d)(\d\d)$/;
438 ($cc,$yy) = ($1,$2);
439
440 # Number of full years since Dec 31, 1BC (starting at 0001)
441 $Ny = $y - 1;
442
443 # Number of full 4th years (0004, 0008, etc.) since Dec 31, 1BC
444 $N4 = int($Ny/4);
445
446 # Number of full 100th years (0100, 0200, etc.)
447 $N100 = $cc + 0;
448 $N100-- if ($yy==0);
449
450 # Number of full 400th years (0400, 0800, etc.)
451 $N400 = int($N100/4);
452
453 $$self{'cache'}{'ds1_mon'}{$y}{1} =
454 $Ny*365 + $N4 - $N100 + $N400 + 1;
455 }
456
457 my($i,$j);
458 my @mon = $self->days_in_month($y,0);
459 for ($i=2; $i<=12; $i++) {
460 $j = shift(@mon);
461 $$self{'cache'}{'ds1_mon'}{$y}{$i} =
462 $$self{'cache'}{'ds1_mon'}{$y}{$i-1} + $j;
463 }
464 }
465
466 return ($$self{'cache'}{'ds1_mon'}{$y}{$m} + $d - 1);
467
468 } else {
469 my($days) = $arg;
470 my($y,$m,$d);
471
472 $y = int($days/365.2425)+1;
473 while ($self->days_since_1BC([$y,1,1]) > $days) {
474 $y--;
475 }
476 $m = 12;
477 while ( ($d=$self->days_since_1BC([$y,$m,1])) > $days ) {
478 $m--;
479 }
480 $d = ($days-$d+1);
481 return [$y,$m,$d];
482 }
483}
484
485sub day_of_week {
486 my($self,$date) = @_;
487 my($y,$m,$d) = @$date;
488 $y += 0;
489 $m += 0;
490
491 my($dayofweek,$dec31) = ();
492 if (! exists $$self{'cache'}{'dow_mon'}{$y}{$m}) {
493 $dec31 = 7; # Dec 31, 1BC was Sunday
494 $$self{'cache'}{'dow_mon'}{$y}{$m} =
495 ( $self->days_since_1BC([$y,$m,1])+$dec31 ) % 7;
496 }
497 $dayofweek = ($$self{'cache'}{'dow_mon'}{$y}{$m}+$d-1) % 7;
498 $dayofweek = 7 if ($dayofweek==0);
499 return $dayofweek;
500}
501
502# Can be the nth DoW of year or month (if $m given). Returns undef if
503# the date doesn't exists (i.e. 5th Sunday in a month with only 4).
504#
505sub nth_day_of_week {
506 my($self,$y,$n,$dow,$m) = @_;
507 $y += 0;
508 $m = ($m ? $m+0 : 0);
509
510 # $d is the current DoM (if $m) or DoY
511 # $max is the max value allowed for $d
512 # $ddow is the DoW of $d
513
514 my($d,$max,$ddow);
515
516 if ($m) {
517 $max = $self->days_in_month($y,$m);
518 $d = ($n<0 ? $max : 1);
519 $ddow = $self->day_of_week([$y,$m,$d]);
520 } else {
521 $max = $self->days_in_year($y);
522 $d = ($n<0 ? $max : 1);
523 if ($n<0) {
524 $d = $max;
525 $ddow = $self->day_of_week([$y,12,31]);
526 } else {
527 $d = 1;
528 $ddow = $self->day_of_week([$y,1,1]);
529 }
530 }
531
532 # Find the first occurrence of $dow on or after $d (if $n>0)
533 # or the last occurrence of $dow on or before $d (if ($n<0);
534
535 if ($dow < $ddow) {
536 $d += 7 - ($ddow-$dow);
537 } else {
538 $d += ($dow-$ddow);
539 }
540 $d -= 7 if ($d > $max);
541
542 # Find the nth occurrence of $dow
543
544 if ($n > 1) {
545 $d += 7*($n-1);
546 return undef if ($d > $max);
547 } elsif ($n < -1) {
548 $d -= 7*(-1*$n-1);
549 return undef if ($d < 1);
550 }
551
552 # Return the date
553
554 if ($m) {
555 return [$y,$m,$d];
556 }
557 return $self->day_of_year($y,$d);
558}
559
560{
561 # Integer arithmetic doesn't work due to the size of the numbers.
56247.03ms220µs
# spent 17µs (13+3) within Date::Manip::Base::BEGIN@562 which was called: # once (13µs+3µs) by Date::Manip::Obj::BEGIN@15 at line 562
no integer;
# spent 17µs making 1 call to Date::Manip::Base::BEGIN@562 # spent 3µs making 1 call to integer::unimport
563 # my $sec_70 =($self->days_since_1BC([1970,1,1])-1)*24*3600;
5641300ns my $sec_70 = 62135596800;
565
566 # Using 'global' variables saves 4%
5671600ns my($y,$m,$d,$h,$mn,$s,$sec,$sec_0,$tmp);
568 sub secs_since_1970 {
569 my($self,$arg) = @_;
570
571 if (ref($arg)) {
572 ($y,$m,$d,$h,$mn,$s) = @$arg;
573 $sec_0 = ($self->days_since_1BC([$y,$m,$d])-1)*24*3600 + $h*3600 +
574 $mn*60 + $s;
575 $sec = $sec_0 - $sec_70;
576 return $sec;
577
578 } else {
579 ($sec) = $arg;
580 $sec_0 = $sec_70 + $sec;
581 $tmp = int($sec_0/24/3600)+1;
582 my $ymd = $self->days_since_1BC($tmp);
583 ($y,$m,$d) = @$ymd;
584 $sec_0 -= ($tmp-1)*24*3600;
585 $h = int($sec_0/3600);
586 $sec_0 -= $h*3600;
587 $mn = int($sec_0/60);
588 $s = $sec_0 - $mn*60;
589 return [$y,$m,$d,$h,$mn,$s];
590 }
591 }
592}
593
594sub check {
595 my($self,$date) = @_;
596 my($y,$m,$d,$h,$mn,$s) = @$date;
597
598 return 0 if (! $self->check_time([$h,$mn,$s]) ||
599 ($y<1 || $y>9999) ||
600 ($m<1 || $m>12));
601
602 my $days = $self->days_in_month($y,$m);
603
604 return 0 if ($d<1 || $d>$days);
605 return 1;
606}
607
608sub check_time {
609 my($self,$hms) = @_;
610 my($h,$mn,$s) = @$hms;
611
612 return 0 if (! $self->_is_int($h,0,24));
613 return 1 if ($h==24 && ! $mn && ! $s);
614 return 0 if ($h==24 ||
615 ($mn<0 || $mn>59) ||
616 ($s<0 || $s>59));
617 return 1;
618}
619
620sub week1_day1 {
621 my($self,$year) = @_;
622 my $firstday = $self->_config('firstday');
623 return $self->_week1_day1($firstday,$year);
624}
625
626sub _week1_day1 {
627 my($self,$firstday,$year) = @_;
628 my $jan1week1 = $self->_config('jan1week1');
629 return $$self{'cache'}{'week1day1'}{$firstday}{$jan1week1}{$year}
630 if (exists $$self{'cache'}{'week1day1'}{$firstday}{$jan1week1}{$year});
631
632 # First week contains either Jan 4 (default) or Jan 1
633
634 my($y,$m,$d) = ($year,1,4);
635 $d = 1 if ($jan1week1);
636
637 # Go back to the previous (counting today) $firstday
638
639 my $dow = $self->day_of_week([$y,$m,$d]);
640 if ($dow != $firstday) {
641 $firstday = 0 if ($firstday == 7);
642 $d -= ($dow-$firstday);
643 if ($d<1) {
644 $y--;
645 $m = 12;
646 $d += 31;
647 }
648 }
649
650 $$self{'cache'}{'week1day1'}{$firstday}{$jan1week1}{$year} = [ $y,$m,$d ];
651 return [$y,$m,$d];
652}
653
654sub weeks_in_year {
655 my($self,$y) = @_;
656 my $firstday = $self->_config('firstday');
657 return $self->_weeks_in_year($firstday,$y);
658}
659
660sub _weeks_in_year {
661 my($self,$firstday,$y) = @_;
662 my $jan1week1 = $self->_config('jan1week1');
663 return $$self{'cache'}{'wiy'}{$firstday}{$jan1week1}{$y}
664 if (exists $$self{'cache'}{'wiy'}{$firstday}{$jan1week1}{$y});
665
666 # Get the week1 day1 dates for this year and the next one.
667 my ($y1,$m1,$d1) = @{ $self->_week1_day1($firstday,$y) };
668 my ($y2,$m2,$d2) = @{ $self->_week1_day1($firstday,$y+1) };
669
670 # Calculate the number of days between them.
671 my $diy = $self->days_in_year($y);
672 if ($y1 < $y) {
673 $diy += (32-$d1);
674 } else {
675 $diy -= ($d1-1);
676 }
677 if ($y2 < $y+1) {
678 $diy -= (32-$d2);
679 } else {
680 $diy += ($d2-1);
681 }
682
683 $diy = $diy/7;
684 $$self{'cache'}{'wiy'}{$firstday}{$jan1week1}{$y} = $diy;
685 return $diy;
686}
687
688sub week_of_year {
689 my($self,@args) = @_;
690 my $firstday = $self->_config('firstday');
691 $self->_week_of_year($firstday,@args);
692}
693
694sub _week_of_year {
695 my($self,$firstday,@args) = @_;
696 my $jan1week1 = $self->_config('jan1week1');
697
698 if ($#args == 1) {
699 # (y,m,d) = week_of_year(y,w)
700 my($year,$w) = @args;
701
702 return $self->_week1_day1($firstday,$year) if ($w == 1);
703
704 return $$self{'cache'}{'woy1'}{$firstday}{$jan1week1}{$year}{$w}
705 if (exists $$self{'cache'}{'woy1'}{$firstday}{$jan1week1}{$year}{$w});
706
707 my($y,$m,$d,$w0,$ymd);
708 ($y,$m,$d) = @{ $self->_week1_day1($firstday,$year) };
709 if ($y<$year) {
710 $y = $year;
711 $m = 1;
712 $d = 7-(31-$d);
713 $w0 = $w-2;
714 } else {
715 $w0 = $w-1;
716 }
717 $ymd = $self->day_of_year($y,$d + $w0*7) if ($w0>0);
718
719 $$self{'cache'}{'woy1'}{$firstday}{$jan1week1}{$year}{$w} = $ymd;
720 return $ymd;
721 }
722
723 # (y,w) = week_of_year([y,m,d])
724 my($y,$m,$d) = @{ $args[0] };
725
726 # Get the first day of the first week. If the date is before that,
727 # it's the last week of last year.
728
729 my($y0,$m0,$d0) = @{ $self->_week1_day1($firstday,$y) };
730 if ($y0==$y && $m==1 && $d<$d0) {
731 return($y-1,$self->_weeks_in_year($firstday,$y-1));
732 }
733
734 # Otherwise, we'll figure out how many days are between the two and
735 # divide by 7 to figure out how many weeks in it is.
736
737 my $n = $self->day_of_year([$y,$m,$d]);
738 if ($y0<$y) {
739 $n += (32-$d0);
740 } else {
741 $n -= ($d0-1);
742 }
743 my $w = 1+int(($n-1)/7);
744
745 # Make sure we're not into the first week of next year.
746
747 if ($w>$self->_weeks_in_year($firstday,$y)) {
748 return($y+1,1);
749 }
750 return($y,$w);
751}
752
753###############################################################################
754# CALC METHODS
755###############################################################################
756
757sub calc_date_date {
758 my($self,$date0,$date1) = @_;
759
760 # Order them so date0 < date1
761 # If $minus = 1, then the delta is negative
762
763 my $minus = 0;
764 my $cmp = $self->cmp($date0,$date1);
765
766 if ($cmp == 0) {
767 return [0,0,0];
768
769 } elsif ($cmp == 1) {
770 $minus = 1;
771 my $tmp = $date1;
772 $date1 = $date0;
773 $date0 = $tmp;
774 }
775
776 my($y0,$m0,$d0,$h0,$mn0,$s0) = @$date0;
777 my($y1,$m1,$d1,$h1,$mn1,$s1) = @$date1;
778
779 my $sameday = ($y0 == $y1 && $m0 == $m1 && $d0 == $d1 ? 1 : 0);
780
781 # Handle the various cases.
782
783 my($dh,$dm,$ds);
784 if ($sameday) {
785 ($dh,$dm,$ds) = @{ $self->_calc_hms_hms([$h0,$mn0,$s0],[$h1,$mn1,$s1]) };
786
787 } else {
788 # y0-m0-d0 h0:mn0:s0 -> y0-m0-d0 24:00:00
789 # y1-m1-d1 h1:mn1:s1 -> y1-m1-d1 00:00:00
790
791 my $t1 = $self->_calc_hms_hms([$h0,$mn0,$s0],[24,0,0]);
792 my $t2 = $self->_calc_hms_hms([0,0,0],[$h1,$mn1,$s1]);
793 ($dh,$dm,$ds) = @{ $self->calc_time_time($t1,$t2) };
794
795 my $dd0 = $self->days_since_1BC([$y0,$m0,$d0]);
796 $dd0++;
797 my $dd1 = $self->days_since_1BC([$y1,$m1,$d1]);
798 $dh += ($dd1-$dd0)*24;
799 }
800
801 if ($minus) {
802 $dh *= -1;
803 $dm *= -1;
804 $ds *= -1;
805 }
806 return [$dh,$dm,$ds];
807}
808
809sub calc_date_days {
810 my($self,$date,$n,$subtract) = @_;
811 my($y,$m,$d,$h,$mn,$s) = @$date;
812 my($ymdonly) = (defined $h ? 0 : 1);
813
814 $n *= -1 if ($subtract);
815 my $d1bc = $self->days_since_1BC([$y,$m,$d]);
816 $d1bc += $n;
817 my $ymd = $self->days_since_1BC($d1bc);
818
819 if ($ymdonly) {
820 return $ymd;
821 } else {
822 return [@$ymd,$h*1,$mn*1,$s*1];
823 }
824}
825
826sub calc_date_delta {
827 my($self,$date,$delta,$subtract) = @_;
828 my($y,$m,$d,$h,$mn,$s,$dy,$dm,$dw,$dd,$dh,$dmn,$ds) = (@$date,@$delta);
829
830 ($y,$m,$d) = @{ $self->_calc_date_ymwd([$y,$m,$d], [$dy,$dm,$dw,$dd],
831 $subtract) };
832 return $self->calc_date_time([$y,$m,$d,$h,$mn,$s],[$dh,$dmn,$ds],$subtract);
833}
834
835sub calc_date_time {
836 my($self,$date,$time,$subtract) = @_;
837 my($y,$m,$d,$h,$mn,$s,$dh,$dmn,$ds) = (@$date,@$time);
838
839 if ($ds > 59 || $ds < -59) {
840 $dmn += int($ds/60);
841 $ds = $ds % 60;
842 }
843 if ($dmn > 59 || $dmn < -59) {
844 $dh += int($dmn/60);
845 $dmn = $dmn % 60;
846 }
847 my $dd = 0;
848 if ($dh > 23 || $dh < -23) {
849 $dd = int($dh/24);
850 $dh = $dh % 24;
851 }
852
853 # Handle subtraction
854 if ($subtract) {
855 $dh *= -1;
856 $dmn *= -1;
857 $ds *= -1;
858 $dd *= -1;
859 }
860
861 if ($dd == 0) {
862 $y *= 1;
863 $m *= 1;
864 $d *= 1;
865 } else {
866 ($y,$m,$d) = @{ $self->calc_date_days([$y,$m,$d],$dd) };
867 }
868
869 $self->_mod_add(60,$ds,\$s,\$mn);
870 $self->_mod_add(60,$dmn,\$mn,\$h);
871 $self->_mod_add(24,$dh,\$h,\$d);
872
873 if ($d<1) {
874 $m--;
875 $y--, $m=12 if ($m<1);
876 my $day_in_mon = $self->days_in_month($y,$m);
877 $d += $day_in_mon;
878 } else {
879 my $day_in_mon = $self->days_in_month($y,$m);
880 if ($d>$day_in_mon) {
881 $d -= $day_in_mon;
882 $m++;
883 $y++, $m=1 if ($m>12);
884 }
885 }
886
887 return [$y,$m,$d,$h,$mn,$s];
888}
889
890sub _calc_date_time_strings {
891 my($self,$date,$time,$subtract) = @_;
892 my @date = @{ $self->split('date',$date) };
893 return '' if (! @date);
894 my @time = @{ $self->split('time',$time) };
895
896 my @date2 = @{ $self->calc_date_time(\@date,\@time,$subtract) };
897
898 return $self->join('date',\@date2);
899}
900
901sub _calc_date_ymwd {
902 my($self,$date,$ymwd,$subtract) = @_;
903 my($y,$m,$d,$h,$mn,$s) = @$date;
904 my($dy,$dm,$dw,$dd) = @$ymwd;
905 my($ymdonly) = (defined $h ? 0 : 1);
906
907 $dd += $dw*7;
908
909 if ($subtract) {
910 $y -= $dy;
911 $self->_mod_add(-12,-1*$dm,\$m,\$y);
912 $dd *= -1;
913
914 } else {
915 $y += $dy;
916 $self->_mod_add(-12,$dm,\$m,\$y);
917 }
918
919 my $ymd;
920 if ($dd == 0) {
921 $ymd = [$y,$m,$d];
922 } else {
923 $ymd = $self->calc_date_days([$y,$m,$d],$dd);
924 }
925
926 if ($ymdonly) {
927 return $ymd;
928 } else {
929 return [@$ymd,$h,$mn,$s];
930 }
931}
932
933sub _calc_hms_hms {
934 my($self,$hms0,$hms1) = @_;
935 my($h0,$m0,$s0,$h1,$m1,$s1) = (@$hms0,@$hms1);
936
937 my($s) = ($h1-$h0)*3600 + ($m1-$m0)*60 + $s1-$s0;
938 my($m) = int($s/60);
939 $s -= $m*60;
940 my($h) = int($m/60);
941 $m -= $h*60;
942 return [$h,$m,$s];
943}
944
945sub calc_time_time {
946 my($self,$time0,$time1,$subtract) = @_;
947 my($h0,$m0,$s0,$h1,$m1,$s1) = (@$time0,@$time1);
948
949 if ($subtract) {
950 $h1 *= -1;
951 $m1 *= -1;
952 $s1 *= -1;
953 }
954 my($s) = (($h0+$h1)*60 + ($m0+$m1))*60 + $s0+$s1;
955 my($m) = int($s/60);
956 $s -= $m*60;
957 my($h) = int($m/60);
958 $m -= $h*60;
959
960 return [$h,$m,$s];
961}
962
963###############################################################################
964
965# Returns -1 if date0 is before date1, 0 if date0 is the same as date1, and
966# 1 if date0 is after date1.
967#
968
# spent 8µs within Date::Manip::Base::cmp which was called 2 times, avg 4µs/call: # 2 times (8µs+0s) by Date::Manip::TZ::zone at line 788 of Date/Manip/TZ.pm, avg 4µs/call
sub cmp {
969410µs my($self,$date0,$date1) = @_;
970 return ($$date0[0] <=> $$date1[0] ||
971 $$date0[1] <=> $$date1[1] ||
972 $$date0[2] <=> $$date1[2] ||
973 $$date0[3] <=> $$date1[3] ||
974 $$date0[4] <=> $$date1[4] ||
975 $$date0[5] <=> $$date1[5]);
976}
977
978###############################################################################
979# This determines the OS.
980
981
# spent 129µs (95+34) within Date::Manip::Base::_os which was called 4 times, avg 32µs/call: # 2 times (50µs+16µs) by Date::Manip::TZ::_init at line 78 of Date/Manip/TZ.pm, avg 33µs/call # 2 times (45µs+18µs) by Date::Manip::Base::_init_config at line 198, avg 32µs/call
sub _os {
98220135µs my($self) = @_;
983
984 my $os = '';
985
9863234µs if ($^O =~ /MSWin32/i ||
# spent 34µs making 32 calls to Date::Manip::Base::CORE:match, avg 1µs/call
987 $^O =~ /Windows_95/i ||
988 $^O =~ /Windows_NT/i
989 ) {
990 $os = 'Windows';
991
992 } elsif ($^O =~ /MacOS/i ||
993 $^O =~ /MPE/i ||
994 $^O =~ /OS2/i ||
995 $^O =~ /NetWare/i
996 ) {
997 $os = 'Other';
998
999 } elsif ($^O =~ /VMS/i) {
1000 $os = 'VMS';
1001
1002 } else {
1003 $os = 'Unix';
1004 }
1005
1006 return $os;
1007}
1008
1009###############################################################################
1010# Functions for setting the default date/time
1011
1012# Many date operations use a default time and/or date to set some
1013# or all values. This function may be used to set or examine the
1014# default time.
1015#
1016# _now allows you to get the current date and/or time in the
1017# local timezone.
1018#
1019# The function performed depends on $op and are described in the
1020# following table:
1021#
1022# $op function
1023# ------------------ ----------------------------------
1024# undef Returns the current default values
1025# (y,m,d,h,mn,s) without updating
1026# the time (it'll update if it has
1027# never been set).
1028#
1029# 'now' Updates now and returns
1030# (y,m,d,h,mn,s)
1031#
1032# 'time' Updates now and Returns (h,mn,s)
1033#
1034# 'y' Returns the default value of one
1035# 'm' of the fields (no update)
1036# 'd'
1037# 'h'
1038# 'mn'
1039# 's'
1040#
1041# 'systz' Returns the system timezone
1042#
1043# 'isdst' Returns the 'now' values if set,
1044# 'tz' or system time values otherwise.
1045# 'offset'
1046# 'abb'
1047#
1048sub _now {
1049 my($self,@op) = @_;
1050 my($noupdate,@ret);
1051
1052 # Update "NOW" if we're checking 'now', 'time', or the date
1053 # is not set already.
1054
1055 if (@op && ($op[$#op] eq "0" || $op[$#op] eq "1")) {
1056 $noupdate = pop(@op);
1057 } else {
1058 $noupdate = 1;
1059 my $op = join(" ",@op);
1060 $noupdate = 0 if ($op =~ /\b(?:now|time)\b/);
1061 }
1062
1063 $noupdate = 0 if (! exists $$self{'data'}{'now'}{'date'});
1064 $self->_update_now() unless ($noupdate);
1065
1066 # Get the appropriate values.
1067
1068 foreach my $op (@op) {
1069
1070 if ($op eq 'now') {
1071 push (@ret,@{ $$self{'data'}{'now'}{'date'} });
1072
1073 } elsif ($op eq 'tz') {
1074 if (exists $$self{'data'}{'now'}{'tz'}) {
1075 push (@ret,$$self{'data'}{'now'}{'tz'});
1076 } else {
1077 push (@ret,$$self{'data'}{'now'}{'systz'});
1078 }
1079
1080 } elsif ($op eq 'y') {
1081 push (@ret,$$self{'data'}{'now'}{'date'}[0]);
1082
1083 } elsif ($op eq 'systz') {
1084 push (@ret,$$self{'data'}{'now'}{'systz'});
1085
1086 } elsif ($op eq 'time') {
1087 push (@ret,@{ $$self{'data'}{'now'}{'date'} }[3..5]);
1088
1089 } elsif ($op eq 'm') {
1090 push (@ret,$$self{'data'}{'now'}{'date'}[1]);
1091
1092 } elsif ($op eq 'd') {
1093 push (@ret,$$self{'data'}{'now'}{'date'}[2]);
1094
1095 } elsif ($op eq 'h') {
1096 push (@ret,$$self{'data'}{'now'}{'date'}[3]);
1097
1098 } elsif ($op eq 'mn') {
1099 push (@ret,$$self{'data'}{'now'}{'date'}[4]);
1100
1101 } elsif ($op eq 's') {
1102 push (@ret,$$self{'data'}{'now'}{'date'}[5]);
1103
1104 } elsif ($op eq 'isdst') {
1105 push (@ret,$$self{'data'}{'now'}{'isdst'});
1106
1107 } elsif ($op eq 'offset') {
1108 push (@ret,@{ $$self{'data'}{'now'}{'offset'} });
1109
1110 } elsif ($op eq 'abb') {
1111 push (@ret,$$self{'data'}{'now'}{'abb'});
1112
1113 } else {
1114 warn "ERROR: [now] invalid argument list: @op\n";
1115 return ();
1116 }
1117 }
1118
1119 return @ret;
1120}
1121
1122sub _update_now {
1123 my($self) = @_;
1124
1125 # If we've called ForceDate, don't change it.
1126 return if ($$self{'data'}{'now'}{'force'});
1127
1128 # If we've called SetDate, figure out what 'now' is based
1129 # on the number of seconds that have elapsed since it was
1130 # set. This will ONLY happen if TZ has been loaded.
1131
1132 if ($$self{'data'}{'now'}{'set'}) {
1133 my $date = $$self{'data'}{'now'}{'setdate'};
1134 my $secs = time - $$self{'data'}{'now'}{'setsecs'};
1135
1136 $date = $self->calc_date_time($date,[0,0,$secs]); # 'now' in GMT
1137 my $dmt = $$self{'objs'}{'tz'};
1138 my ($zone) = $self->_now('tz',1);
1139 my ($err,$date2,$offset,$isdst,$abbrev) = $dmt->convert_from_gmt($date,$zone);
1140
1141 $$self{'data'}{'now'}{'date'} = $date2;
1142 $$self{'data'}{'now'}{'isdst'} = $isdst;
1143 $$self{'data'}{'now'}{'offset'} = $offset;
1144 $$self{'data'}{'now'}{'abb'} = $abbrev;
1145 return;
1146 }
1147
1148 # Otherwise, we'll use the system time.
1149
1150 my $time = time;
1151 my($s,$mn,$h,$d,$m,$y,$wday,$yday,$isdst) = localtime($time);
1152 my($s0,$mn0,$h0,$d0,$m0,$y0) = gmtime($time);
1153
1154 $y += 1900;
1155 $m++;
1156
1157 $y0 += 1900;
1158 $m0++;
1159
1160 my $off = $self->calc_date_date([$y,$m,$d,$h,$mn,$s],[$y0,$m0,$d0,$h0,$mn0,$s0],1);
1161
1162 $$self{'data'}{'now'}{'date'} = [$y,$m,$d,$h,$mn,$s];
1163 $$self{'data'}{'now'}{'isdst'} = $isdst;
1164 $$self{'data'}{'now'}{'offset'}= $off;
1165
1166 my $abb = '???';
1167 if (exists $$self{'objs'}{'tz'}) {
1168 my $dmt = $$self{'objs'}{'tz'};
1169 my ($zone) = $self->_now('tz',1);
1170 my $per = $dmt->date_period([$y,$m,$d,$h,$mn,$s],$zone,1,$isdst);
1171 $abb = $$per[4];
1172 }
1173
1174 $$self{'data'}{'now'}{'abb'} = $abb;
1175
1176 return;
1177}
1178
1179###############################################################################
1180# Config file functions
1181
1182# This reads a config file
1183#
1184sub _config_file {
1185 my($self,$file) = @_;
1186
1187 return if (! $file);
1188
1189 if (! -f $file) {
1190 warn "ERROR: [config_file] file doesn't exist: $file\n";
1191 return;
1192 }
1193 if (! -r $file) {
1194 warn "ERROR: [config_file] file not readable: $file\n";
1195 return;
1196 }
1197
1198 my $in = new IO::File;
1199 if (! $in->open($file)) {
1200 warn "ERROR: [config_file] unable to open file: $file: $!\n";
1201 return;
1202 }
1203 my @in = <$in>;
1204 $in->close();
1205
1206 my $sect = 'conf';
1207 chomp(@in);
1208 foreach my $line (@in) {
1209 $line =~ s/^\s+//;
1210 $line =~ s/\s+$//;
1211 next if (! $line or $line =~ /^\043/);
1212
1213 if ($line =~ /^\*/) {
1214 # New section
1215 $sect = $self->_config_file_section($line);
1216 } else {
1217 $self->_config_file_var($sect,$line);
1218 }
1219 }
1220}
1221
1222sub _config_file_section {
1223 my($self,$line) = @_;
1224
1225 $line =~ s/^\*//;
1226 $line =~ s/\s*$//;
1227 my $sect = lc($line);
1228 if (! exists $$self{'data'}{'sections'}{$sect}) {
1229 warn "WARNING: [config_file] unknown section created: $sect\n";
1230 $self->_section($sect);
1231 }
1232 return $sect;
1233}
1234
1235sub _config_file_var {
1236 my($self,$sect,$line) = @_;
1237
1238 my($var,$val);
1239 if ($line =~ /^\s*(.*?)\s*=\s*(.*?)\s*$/) {
1240 ($var,$val) = ($1,$2);
1241 } else {
1242 die "ERROR: invalid Date::Manip config file line:\n $line\n";
1243 }
1244
1245 if ($sect eq 'conf') {
1246 $var = lc($var);
1247 $self->_config($var,$val);
1248 } else {
1249 $self->_section($sect,$var,$val);
1250 }
1251}
1252
1253###############################################################################
1254# Config variable functions
1255
1256# $self->config(SECT);
1257# Creates a new section.
1258#
1259# $self->config(SECT,'_vars');
1260# Returns a list of (VAR VAL VAR VAL ...)
1261#
1262# $self->config(SECT,VAR,VAL);
1263# Adds (VAR,VAL) to the list.
1264#
1265sub _section {
1266 my($self,$sect,$var,$val) = @_;
1267 $sect = lc($sect);
1268
1269 #
1270 # $self->_section(SECT) creates a new section
1271 #
1272
1273 if (! defined $var) {
1274 if ($sect eq 'conf') {
1275 $$self{'data'}{'sections'}{$sect} = {};
1276 } else {
1277 $$self{'data'}{'sections'}{$sect} = [];
1278 }
1279 return '';
1280 }
1281
1282 if ($var eq '_vars') {
1283 return @{ $$self{'data'}{'sections'}{$sect} };
1284 }
1285
1286 push @{ $$self{'data'}{'sections'}{$sect} },($var,$val);
1287 return;
1288}
1289
1290# $val = $self->config(VAR);
1291# Returns the value of a variable.
1292#
1293# $self->config([SECT], VAR, VAL) sets the value of a variable
1294# Sets the value of a variable.
1295#
1296
# spent 57µs within Date::Manip::Base::_config which was called 9 times, avg 6µs/call: # 2 times (15µs+0s) by Date::Manip::Base::_config_var_workweekbeg at line 1542, avg 8µs/call # 2 times (8µs+0s) by Date::Manip::Base::_config_var_workweekend at line 1559, avg 4µs/call # 2 times (7µs+0s) by Date::Manip::Base::_config_var_workweekend at line 1564, avg 3µs/call # 2 times (7µs+0s) by Date::Manip::Base::_config_var_workweekbeg at line 1547, avg 3µs/call # once (20µs+0s) by Date::Manip::Recur::_init at line 52 of Date/Manip/Recur.pm
sub _config {
12974575µs my($self,$var,$val) = @_;
1298
1299 my $sect = 'conf';
1300
1301 #
1302 # $self->_conf(VAR, VAL) sets the value of a variable
1303 #
1304
1305 $var = lc($var);
1306 if (defined $val) {
1307 return $self->_config_var($var,$val);
1308 }
1309
1310 #
1311 # $self->_conf(VAR) returns the value of a variable
1312 #
1313
1314 if (exists $$self{'data'}{'sections'}{$sect}{$var}) {
1315 return $$self{'data'}{'sections'}{$sect}{$var};
1316 } else {
1317 warn "ERROR: [config] invalid config variable: $var\n";
1318 return '';
1319 }
1320}
1321
1322# This sets a config variable. It also performs all side effects from
1323# setting that variable.
1324#
1325
# spent 18.4ms (943µs+17.5) within Date::Manip::Base::_config_var which was called 37 times, avg 499µs/call: # 2 times (48µs+14.8ms) by Date::Manip::Base::_init_config at line 191, avg 7.44ms/call # 2 times (46µs+450µs) by Date::Manip::Base::_init_config at line 180, avg 248µs/call # 2 times (41µs+277µs) by Date::Manip::Base::_init_config at line 181, avg 159µs/call # 2 times (92µs+72µs) by Date::Manip::Base::_init_config at line 192, avg 82µs/call # 2 times (47µs+77µs) by Date::Manip::Base::_init_config at line 189, avg 62µs/call # 2 times (62µs+61µs) by Date::Manip::Base::_init_config at line 193, avg 61µs/call # 2 times (65µs+35µs) by Date::Manip::Base::_init_config at line 179, avg 50µs/call # 2 times (88µs+9µs) by Date::Manip::Base::_init_config at line 219, avg 49µs/call # 2 times (28µs+61µs) by Date::Manip::Base::_init_config at line 190, avg 45µs/call # 2 times (35µs+41µs) by Date::Manip::Base::_init_config at line 188, avg 38µs/call # 2 times (63µs+7µs) by Date::Manip::Base::_init_config at line 221, avg 35µs/call # 2 times (56µs+5µs) by Date::Manip::Base::_init_config at line 220, avg 31µs/call # 2 times (43µs+16µs) by Date::Manip::Base::_init_config at line 194, avg 30µs/call # 2 times (43µs+4µs) by Date::Manip::Base::_init_config at line 184, avg 23µs/call # 2 times (31µs+13µs) by Date::Manip::Base::_init_config at line 185, avg 22µs/call # 2 times (29µs+10µs) by Date::Manip::Base::_init_config at line 182, avg 19µs/call # 2 times (28µs+4µs) by Date::Manip::Base::_init_config at line 186, avg 16µs/call # 2 times (27µs+4µs) by Date::Manip::Base::_init_config at line 187, avg 15µs/call # once (69µs+1.52ms) by Date::Manip::Obj::config at line 211 of Date/Manip/Obj.pm
sub _config_var {
1326873900µs my($self,$var,$val) = @_;
132737100µs $self->_init_data();
# spent 100µs making 37 calls to Date::Manip::Base::_init_data, avg 3µs/call
1328 $var = lc($var);
1329
1330 # A simple flag used to force a new configuration, but has
1331 # no other affect.
1332 return if ($var eq 'ignore');
1333
1334 given ($var) {
1335
1336 when ('defaults') {
1337 # Reset the configuration if desired.
1338 $self->_init_config(1);
1339 return;
1340 }
1341
1342 when ('eraseholidays') {
1343 $self->_init_holidays(1);
1344 return;
1345 }
1346
1347 when ('eraseevents') {
1348 $self->_init_events(1);
1349 return;
1350 }
1351
1352 when ('configfile') {
1353 $self->_config_file($val);
1354 return;
1355 }
1356
1357 when ('language') {
1358214.8ms my $err = $self->_language($val);
# spent 14.8ms making 2 calls to Date::Manip::Base::_language, avg 7.42ms/call
1359 return if ($err);
1360 }
1361
1362 when ('yytoyyyy') {
1363 $val = lc($val);
136469µs if ($val ne 'c' &&
# spent 9µs making 6 calls to Date::Manip::Base::CORE:match, avg 2µs/call
1365 $val !~ /^c\d\d$/ &&
1366 $val !~ /^c\d\d\d\d$/ &&
1367 $val !~ /^\d+$/) {
1368 warn "ERROR: [config_var] invalid: YYtoYYYY: $val\n";
1369 return;
1370 }
1371 }
1372
1373 when ('workweekbeg') {
1374272µs my $err = $self->_config_var_workweekbeg($val);
# spent 72µs making 2 calls to Date::Manip::Base::_config_var_workweekbeg, avg 36µs/call
1375 return if ($err);
1376 }
1377
1378 when ('workweekend') {
1379257µs my $err = $self->_config_var_workweekend($val);
# spent 57µs making 2 calls to Date::Manip::Base::_config_var_workweekend, avg 28µs/call
1380 return if ($err);
1381 }
1382
1383 when ('workday24hr') {
1384435µs my $err = $self->_config_var_workday24hr($val);
# spent 35µs making 4 calls to Date::Manip::Base::_config_var_workday24hr, avg 9µs/call
1385 return if ($err);
1386 }
1387
1388 when ('workdaybeg') {
13892444µs my $err = $self->_config_var_workdaybegend(\$val,'WorkDayBeg');
# spent 444µs making 2 calls to Date::Manip::Base::_config_var_workdaybegend, avg 222µs/call
1390 return if ($err);
1391 }
1392
1393 when ('workdayend') {
13942272µs my $err = $self->_config_var_workdaybegend(\$val,'WorkDayEnd');
# spent 272µs making 2 calls to Date::Manip::Base::_config_var_workdaybegend, avg 136µs/call
1395 return if ($err);
1396 }
1397
1398 when ('firstday') {
1399238µs my $err = $self->_config_var_firstday($val);
# spent 38µs making 2 calls to Date::Manip::Base::_config_var_firstday, avg 19µs/call
1400 return if ($err);
1401 }
1402
1403 when (['tz','forcedate','setdate']) {
1404 # These can only be used if the Date::Manip::TZ module has been loaded
1405 if (! exists $$self{'objs'}{'tz'}) {
1406 warn "ERROR: [config_var] $var config variable requires TZ module\n";
1407 return;
1408 }
1409 continue;
1410 }
1411
1412 when ('tz') {
1413 my $err = $self->_config_var_setdate("now,$val",0);
1414 return if ($err);
1415 $$self{'data'}{'sections'}{'conf'}{'forcedate'} = 0;
1416 $val = 1;
1417 }
1418
1419 when ('setdate') {
142051.53ms my $err = $self->_config_var_setdate($val,0);
# spent 1.52ms making 1 call to Date::Manip::Base::_config_var_setdate # spent 9µs making 4 calls to Regexp::DESTROY, avg 2µs/call
1421 return if ($err);
1422 $$self{'data'}{'sections'}{'conf'}{'forcedate'} = 0;
1423 $val = 1;
1424 }
1425
1426 when ('forcedate') {
1427 my $err = $self->_config_var_setdate($val,1);
1428 return if ($err);
1429 $$self{'data'}{'sections'}{'conf'}{'setdate'} = 0;
1430 $val = 1;
1431 }
1432
1433 when ('recurrange') {
1434261µs my $err = $self->_config_var_recurrange($val);
# spent 61µs making 2 calls to Date::Manip::Base::_config_var_recurrange, avg 31µs/call
1435 return if ($err);
1436 }
1437
1438 when ('recurnumfudgedays') {
1439253µs my $err = $self->_config_var_recurnumfudgedays($val);
# spent 53µs making 2 calls to Date::Manip::Base::_config_var_recurnumfudgedays, avg 26µs/call
1440 return if ($err);
1441 }
1442
1443 when ('defaulttime') {
1444212µs my $err = $self->_config_var_defaulttime($val);
# spent 12µs making 2 calls to Date::Manip::Base::_config_var_defaulttime, avg 6µs/call
1445 return if ($err);
1446 }
1447
1448 when (['dateformat',
1449 'jan1week1',
1450 'printable',
1451 'tomorrowfirst',
1452 'intcharset']) {
1453 # do nothing
1454 }
1455
1456 #
1457 # Deprecated ones
1458 #
1459
1460 when (['convtz',
1461 'globalcnf',
1462 'ignoreglobalcnf',
1463 'personalcnf',
1464 'personalcnfpath',
1465 'pathsep',
1466 'resetworkday',
1467 'deltasigns',
1468 'internal',
1469 'udpatecurrtz']) {
1470 # do nothing
1471 }
1472
1473 when ('oldconfigfiles') {
1474 # This actually reads in the old-style config files
1475 if ($self->_config('globalcnf') &&
1476 ! $self->_config('ignoreglobalcnf')) {
1477 my $file = $self->_config('globalcnf');
1478 $file = $self->_ExpandTilde($file);
1479 $self->_config_file($file);
1480 }
1481
1482 if ($self->_config('personalcnf')) {
1483 my $file = $self->_config('personalcnf');
1484 my $path = $self->_config('personalcnfpath');
1485 my $sep = $self->_config('pathsep');
1486 $file = $self->_SearchPath($file,$path,$sep);
1487 $self->_config_file($file) if ($file);
1488 }
1489 return;
1490 }
1491
1492 default {
1493 warn "ERROR: [config_var] invalid config variable: $var\n";
1494 return '';
1495 }
1496 }
1497
1498 #
1499 # Deprecated
1500 #
1501
1502 if ($var eq 'internal') {
1503 $var = 'printable';
1504 }
1505
1506 $$self{'data'}{'sections'}{'conf'}{$var} = $val;
1507 return;
1508}
1509
1510###############################################################################
1511# Specific config variable functions
1512
1513
# spent 53µs (21+32) within Date::Manip::Base::_config_var_recurnumfudgedays which was called 2 times, avg 26µs/call: # 2 times (21µs+32µs) by Date::Manip::Base::_config_var at line 1439, avg 26µs/call
sub _config_var_recurnumfudgedays {
1514619µs my($self,$val) = @_;
1515
1516232µs if (! $self->_is_int($val,1)) {
# spent 32µs making 2 calls to Date::Manip::Base::_is_int, avg 16µs/call
1517 warn "ERROR: [config_var] invalid: RecurNumFudgeDays: $val\n";
1518 return 1;
1519 }
1520 return 0;
1521}
1522
1523
# spent 61µs (33+28) within Date::Manip::Base::_config_var_recurrange which was called 2 times, avg 31µs/call: # 2 times (33µs+28µs) by Date::Manip::Base::_config_var at line 1434, avg 31µs/call
sub _config_var_recurrange {
1524664µs my($self,$val) = @_;
1525
1526 $val = lc($val);
1527228µs if ($val =~ /^(none|year|month|week|day|all)$/) {
# spent 28µs making 2 calls to Date::Manip::Base::CORE:match, avg 14µs/call
1528 return 0;
1529 }
1530
1531 warn "ERROR: [config_var] invalid: RecurRange: $val\n";
1532 return 1;
1533}
1534
1535
# spent 72µs (35+37) within Date::Manip::Base::_config_var_workweekbeg which was called 2 times, avg 36µs/call: # 2 times (35µs+37µs) by Date::Manip::Base::_config_var at line 1374, avg 36µs/call
sub _config_var_workweekbeg {
15361039µs my($self,$val) = @_;
1537
1538215µs if (! $self->_is_int($val,1,7)) {
# spent 15µs making 2 calls to Date::Manip::Base::_is_int, avg 7µs/call
1539 warn "ERROR: [config_var] invalid: WorkWeekBeg: $val\n";
1540 return 1;
1541 }
1542215µs if ($val >= $self->_config('workweekend')) {
# spent 15µs making 2 calls to Date::Manip::Base::_config, avg 8µs/call
1543 warn "ERROR: [config_var] WorkWeekBeg must be before WorkWeekEnd\n";
1544 return 1;
1545 }
1546
154727µs $$self{'data'}{'calc'}{'workweek'} =
# spent 7µs making 2 calls to Date::Manip::Base::_config, avg 3µs/call
1548 $self->_config('workweekend') - $val + 1;
1549 return 0;
1550}
1551
1552
# spent 57µs (30+27) within Date::Manip::Base::_config_var_workweekend which was called 2 times, avg 28µs/call: # 2 times (30µs+27µs) by Date::Manip::Base::_config_var at line 1379, avg 28µs/call
sub _config_var_workweekend {
15531024µs my($self,$val) = @_;
1554
1555212µs if (! $self->_is_int($val,1,7)) {
# spent 12µs making 2 calls to Date::Manip::Base::_is_int, avg 6µs/call
1556 warn "ERROR: [config_var] invalid: WorkWeekBeg: $val\n";
1557 return 1;
1558 }
155928µs if ($val <= $self->_config('workweekbeg')) {
# spent 8µs making 2 calls to Date::Manip::Base::_config, avg 4µs/call
1560 warn "ERROR: [config_var] WorkWeekEnd must be after WorkWeekBeg\n";
1561 return 1;
1562 }
1563
156427µs $$self{'data'}{'calc'}{'workweek'} =
# spent 7µs making 2 calls to Date::Manip::Base::_config, avg 3µs/call
1565 $val - $self->_config('workweekbeg') + 1;
1566 return 0;
1567}
1568
1569
# spent 35µs within Date::Manip::Base::_config_var_workday24hr which was called 4 times, avg 9µs/call: # 4 times (35µs+0s) by Date::Manip::Base::_config_var at line 1384, avg 9µs/call
sub _config_var_workday24hr {
15702237µs my($self,$val) = @_;
1571
1572 if ($val) {
1573 $$self{'data'}{'sections'}{'conf'}{'workdaybeg'} = '00:00:00';
1574 $$self{'data'}{'sections'}{'conf'}{'workdayend'} = '24:00:00';
1575 $$self{'data'}{'calc'}{'workdaybeg'} = [0,0,0];
1576 $$self{'data'}{'calc'}{'workdayend'} = [24,0,0];
1577 $$self{'data'}{'calc'}{'bdlength'} = 86400; # 24*60*60
1578 }
1579
1580 return 0;
1581}
1582
1583
# spent 715µs (109+606) within Date::Manip::Base::_config_var_workdaybegend which was called 4 times, avg 179µs/call: # 2 times (68µs+375µs) by Date::Manip::Base::_config_var at line 1389, avg 222µs/call # 2 times (41µs+231µs) by Date::Manip::Base::_config_var at line 1394, avg 136µs/call
sub _config_var_workdaybegend {
158452106µs my($self,$val,$conf) = @_;
1585
1586 # Must be a valid time. Entered as H, H:M, or H:M:S
1587
15884319µs my $tmp = $self->split('hms',$$val);
# spent 319µs making 4 calls to Date::Manip::Base::split, avg 80µs/call
1589 if (! defined $tmp) {
1590 warn "ERROR: [config_var] invalid: $conf: $$val\n";
1591 return 1;
1592 }
1593 $$self{'data'}{'calc'}{lc($conf)} = $tmp;
15944287µs $$val = $self->join('hms',$tmp);
# spent 287µs making 4 calls to Date::Manip::Base::join, avg 72µs/call
1595
1596 # workdaybeg < workdayend
1597
1598 my @beg = @{ $$self{'data'}{'calc'}{'workdaybeg'} };
1599 my @end = @{ $$self{'data'}{'calc'}{'workdayend'} };
1600 my $beg = $beg[0]*3600 + $beg[1]*60 + $beg[2];
1601 my $end = $end[0]*3600 + $end[1]*60 + $end[2];
1602
1603 if ($beg > $end) {
1604 warn "ERROR: [config_var] WorkDayBeg not before WorkDayEnd\n";
1605 return 1;
1606 }
1607
1608 # Calculate bdlength (unless 24 hour work day set)
1609
1610 $$self{'data'}{'sections'}{'conf'}{'workday24hr'} = 0;
1611 $$self{'data'}{'calc'}{'bdlength'} =
1612 ($end[0]-$beg[0])*3600 + ($end[1]-$beg[1])*60 + ($end[2]-$beg[2]);
1613
1614 return 0;
1615}
1616
1617
# spent 38µs (24+14) within Date::Manip::Base::_config_var_firstday which was called 2 times, avg 19µs/call: # 2 times (24µs+14µs) by Date::Manip::Base::_config_var at line 1399, avg 19µs/call
sub _config_var_firstday {
1618617µs my($self,$val) = @_;
1619
1620214µs if (! $self->_is_int($val,1,7)) {
# spent 14µs making 2 calls to Date::Manip::Base::_is_int, avg 7µs/call
1621 warn "ERROR: [config_var] invalid: FirstDay: $val\n";
1622 return 1;
1623 }
1624
1625 return 0;
1626}
1627
1628
# spent 12µs within Date::Manip::Base::_config_var_defaulttime which was called 2 times, avg 6µs/call: # 2 times (12µs+0s) by Date::Manip::Base::_config_var at line 1444, avg 6µs/call
sub _config_var_defaulttime {
1629415µs my($self,$val) = @_;
1630
1631 if (lc($val) eq 'midnight' ||
1632 lc($val) eq 'curr') {
1633 return 0;
1634 }
1635 warn "ERROR: [config_var] invalid: DefaultTime: $val\n";
1636 return 1;
1637}
1638
1639
# spent 1.52ms (173µs+1.34) within Date::Manip::Base::_config_var_setdate which was called: # once (173µs+1.34ms) by Date::Manip::Base::_config_var at line 1420
sub _config_var_setdate {
164049223µs my($self,$val,$force) = @_;
1641 my $dmt = $$self{'objs'}{'tz'};
1642
164315µs my $dstrx = qr/(?:,(stdonly|dstonly|std|dst))?/i;
# spent 5µs making 1 call to Date::Manip::Base::CORE:qr
164412µs my $zonrx = qr/,(.+)/;
# spent 2µs making 1 call to Date::Manip::Base::CORE:qr
164511µs my $da1rx = qr/(\d\d\d\d)(\d\d)(\d\d)(\d\d):(\d\d):(\d\d)/;
# spent 1µs making 1 call to Date::Manip::Base::CORE:qr
164617µs my $da2rx = qr/(\d\d\d\d)\-(\d\d)\-(\d\d)\-(\d\d):(\d\d):(\d\d)/;
# spent 7µs making 1 call to Date::Manip::Base::CORE:qr
1647 my $time = time;
1648
1649 my($op,$date,$dstflag,$zone,@date,$offset,$abb);
1650
1651 #
1652 # Parse the argument
1653 #
1654
1655236µs if ($val =~ /^now${dstrx}${zonrx}$/oi) {
# spent 28µs making 1 call to Date::Manip::Base::CORE:regcomp # spent 7µs making 1 call to Date::Manip::Base::CORE:match
1656 # now,ZONE
1657 # now,DSTFLAG,ZONE
1658 # Sets now to the system date/time but sets the timezone to be ZONE
1659
1660 $op = 'nowzone';
1661 ($dstflag,$zone) = ($1,$2);
1662
1663 } elsif ($val =~ /^zone${dstrx}${zonrx}$/oi) {
1664 # zone,ZONE
1665 # zone,DSTFLAG,ZONE
1666 # Converts 'now' to the alternate zone
1667
1668 $op = 'zone';
1669 ($dstflag,$zone) = ($1,$2);
1670
1671 } elsif ($val =~ /^${da1rx}${dstrx}${zonrx}$/o ||
1672 $val =~ /^${da2rx}${dstrx}${zonrx}$/o) {
1673 # DATE,ZONE
1674 # DATE,DSTFLAG,ZONE
1675 # Sets the date and zone
1676
1677 $op = 'datezone';
1678 my($y,$m,$d,$h,$mn,$s);
1679 ($y,$m,$d,$h,$mn,$s,$dstflag,$zone) = ($1,$2,$3,$4,$5,$6,$7,$8);
1680 $date = [$y,$m,$d,$h,$mn,$s];
1681
1682 } elsif ($val =~ /^${da1rx}$/o ||
1683 $val =~ /^${da2rx}$/o) {
1684 # DATE
1685 # Sets the date in the system timezone
1686
1687 $op = 'date';
1688 my($y,$m,$d,$h,$mn,$s) = ($1,$2,$3,$4,$5,$6);
1689 $date = [$y,$m,$d,$h,$mn,$s];
1690 ($zone) = $self->_now('systz',1);
1691
1692 } elsif (lc($val) eq 'now') {
1693 # now
1694 # Resets everything
1695
1696 my $systz = $$self{'data'}{'now'}{'systz'};
1697 $self->_init_now();
1698 $$self{'data'}{'now'}{'systz'} = $systz;
1699 return 0;
1700
1701 } else {
1702 warn "ERROR: [config_var] invalid SetDate/ForceDate value: $val\n";
1703 return 1;
1704 }
1705
1706 $dstflag = 'std' if (! $dstflag);
1707
1708 #
1709 # Get the date we're setting 'now' to
1710 #
1711
1712 if ($op eq 'nowzone') {
1713 # Use the system localtime
1714
1715 my($s,$mn,$h,$d,$m,$y) = localtime($time);
1716 $y += 1900;
1717 $m++;
1718 $date = [$y,$m,$d,$h,$mn,$s];
1719
1720 } elsif ($op eq 'zone') {
1721 # Use the system GMT time
1722
1723 my($s,$mn,$h,$d,$m,$y) = gmtime($time);
1724 $y += 1900;
1725 $m++;
1726 $date = [$y,$m,$d,$h,$mn,$s];
1727 }
1728
1729 #
1730 # Find out what zone was passed in. It can be an alias or an offset.
1731 #
1732
1733 if ($zone) {
1734 my ($err,@args);
1735 push(@args,$date) if ($date);
1736 push(@args,$zone);
1737 push(@args,$dstflag);
1738
173911.02ms $zone = $dmt->zone(@args);
# spent 1.02ms making 1 call to Date::Manip::TZ::zone
1740 if (! $zone) {
1741 warn "ERROR: [config_var] invalid zone in SetDate\n";
1742 return 1;
1743 }
1744
1745 } else {
1746 $zone = $$self{'data'}{'now'}{'systz'};
1747 }
1748
1749 #
1750 # Handle the zone
1751 #
1752
1753 my($isdst,@isdst);
1754 if ($dstflag eq 'std') {
1755 @isdst = (0,1);
1756 } elsif ($dstflag eq 'stdonly') {
1757 @isdst = (0);
1758 } elsif ($dstflag eq 'dst') {
1759 @isdst = (1,0);
1760 } else {
1761 @isdst = (1);
1762 }
1763
1764 given ($op) {
1765
1766 when (['nowzone','datezone','date']) {
1767 # Check to make sure that the date can exist in this zone.
1768 my $per;
1769 foreach my $dst (@isdst) {
1770 next if ($per);
1771197µs $per = $dmt->date_period($date,$zone,1,$dst);
# spent 97µs making 1 call to Date::Manip::TZ::date_period
1772 }
1773
1774 if (! $per) {
1775 warn "ERROR: [config_var] invalid date: SetDate\n";
1776 return 1;
1777 }
1778 $isdst = $$per[5];
1779 $abb = $$per[4];
1780 $offset = $$per[3];
1781 }
1782
1783 when ('zone') {
1784 # Convert to that zone
1785 my($err);
1786 ($err,$date,$offset,$isdst,$abb) = $dmt->convert_from_gmt($date,$zone);
1787 if ($err) {
1788 warn "ERROR: [config_var] invalid SetDate date/offset values\n";
1789 return 1;
1790 }
1791 }
1792 }
1793
1794 #
1795 # Set NOW
1796 #
1797
1798 $$self{'data'}{'now'}{'date'} = $date;
179916µs $$self{'data'}{'now'}{'tz'} = $dmt->_zone($zone);
# spent 6µs making 1 call to Date::Manip::TZ::_zone
1800 $$self{'data'}{'now'}{'isdst'} = $isdst;
1801 $$self{'data'}{'now'}{'abb'} = $abb;
1802 $$self{'data'}{'now'}{'offset'} = $offset;
1803
1804 #
1805 # Treate SetDate/ForceDate
1806 #
1807
1808 if ($force) {
1809 $$self{'data'}{'now'}{'force'} = 1;
1810 $$self{'data'}{'now'}{'set'} = 0;
1811 } else {
1812 $$self{'data'}{'now'}{'force'} = 0;
1813 $$self{'data'}{'now'}{'set'} = 1;
1814 $$self{'data'}{'now'}{'setsecs'} = $time;
18151162µs my($err,$setdate) = $dmt->convert_to_gmt($date,$zone);
# spent 162µs making 1 call to Date::Manip::TZ::convert_to_gmt
1816 $$self{'data'}{'now'}{'setdate'} = $setdate;
1817 }
1818
1819 return 0;
1820}
1821
1822###############################################################################
1823# Language functions
1824
1825# This reads in a langauge module and sets regular expressions
1826# and word lists based on it.
1827#
18283147µs287µs
# spent 54µs (21+33) within Date::Manip::Base::BEGIN@1828 which was called: # once (21µs+33µs) by Date::Manip::Obj::BEGIN@15 at line 1828
no strict 'refs';
# spent 54µs making 1 call to Date::Manip::Base::BEGIN@1828 # spent 33µs making 1 call to strict::unimport
1829
# spent 14.8ms (1.17+13.7) within Date::Manip::Base::_language which was called 2 times, avg 7.42ms/call: # 2 times (1.17ms+13.7ms) by Date::Manip::Base::_config_var at line 1358, avg 7.42ms/call
sub _language {
183066386µs my($self,$lang) = @_;
1831 $lang = lc($lang);
1832
1833 if (! exists $Date::Manip::Lang::index::Lang{$lang}) {
1834 warn "ERROR: [language] invalid: $lang\n";
1835 return 1;
1836 }
1837
1838 return 0 if (exists $$self{'data'}{'sections'}{'conf'} &&
1839 $$self{'data'}{'sections'}{'conf'} eq $lang);
1840213µs $self->_init_language(1);
# spent 13µs making 2 calls to Date::Manip::Base::_init_language, avg 6µs/call
1841
1842 my $mod = $Date::Manip::Lang::index::Lang{$lang};
1843 eval "require Date::Manip::Lang::${mod}";
# spent 201µs executing statements in 2 string evals (merged)
1844
18453228µs288µs
# spent 53µs (19+34) within Date::Manip::Base::BEGIN@1845 which was called: # once (19µs+34µs) by Date::Manip::Obj::BEGIN@15 at line 1845
no warnings 'once';
# spent 53µs making 1 call to Date::Manip::Base::BEGIN@1845 # spent 34µs making 1 call to warnings::unimport
1846 $$self{'data'}{'lang'} = ${ "Date::Manip::Lang::${mod}::Language" };
1847
1848 # Common words
1849278µs $self->_rx_wordlist('at');
# spent 78µs making 2 calls to Date::Manip::Base::_rx_wordlist, avg 39µs/call
18502128µs $self->_rx_wordlist('each');
# spent 128µs making 2 calls to Date::Manip::Base::_rx_wordlist, avg 64µs/call
1851284µs $self->_rx_wordlist('last');
# spent 84µs making 2 calls to Date::Manip::Base::_rx_wordlist, avg 42µs/call
1852262µs $self->_rx_wordlist('of');
# spent 62µs making 2 calls to Date::Manip::Base::_rx_wordlist, avg 31µs/call
1853229µs $self->_rx_wordlist('on');
# spent 29µs making 2 calls to Date::Manip::Base::_rx_wordlist, avg 15µs/call
18542302µs $self->_rx_wordlists('when');
# spent 302µs making 2 calls to Date::Manip::Base::_rx_wordlists, avg 151µs/call
1855
1856 # Next/prev
18572175µs $self->_rx_wordlists('nextprev');
# spent 175µs making 2 calls to Date::Manip::Base::_rx_wordlists, avg 87µs/call
1858
1859 # Field names (years, year, yr, ...)
18602831µs $self->_rx_wordlists('fields');
# spent 831µs making 2 calls to Date::Manip::Base::_rx_wordlists, avg 415µs/call
1861
1862 # Numbers (first, 1st)
186322.20ms $self->_rx_wordlists('nth');
# spent 2.20ms making 2 calls to Date::Manip::Base::_rx_wordlists, avg 1.10ms/call
186422.44ms $self->_rx_wordlists('nth','nth_dom',31); # 1-31
# spent 2.44ms making 2 calls to Date::Manip::Base::_rx_wordlists, avg 1.22ms/call
18652415µs $self->_rx_wordlists('nth','nth_wom',5); # 1-5
# spent 415µs making 2 calls to Date::Manip::Base::_rx_wordlists, avg 208µs/call
1866
1867 # Calendar names (Mon, Tue and Jan, Feb)
18682412µs $self->_rx_wordlists('day_abb');
# spent 412µs making 2 calls to Date::Manip::Base::_rx_wordlists, avg 206µs/call
18692464µs $self->_rx_wordlists('day_char');
# spent 464µs making 2 calls to Date::Manip::Base::_rx_wordlists, avg 232µs/call
18702517µs $self->_rx_wordlists('day_name');
# spent 517µs making 2 calls to Date::Manip::Base::_rx_wordlists, avg 258µs/call
18712528µs $self->_rx_wordlists('month_abb');
# spent 528µs making 2 calls to Date::Manip::Base::_rx_wordlists, avg 264µs/call
18722644µs $self->_rx_wordlists('month_name');
# spent 644µs making 2 calls to Date::Manip::Base::_rx_wordlists, avg 322µs/call
1873
1874 # H:M:S separators
1875229µs $self->_rx_simple('sephm');
# spent 29µs making 2 calls to Date::Manip::Base::_rx_simple, avg 15µs/call
1876212µs $self->_rx_simple('sepms');
# spent 12µs making 2 calls to Date::Manip::Base::_rx_simple, avg 6µs/call
1877215µs $self->_rx_simple('sepfr');
# spent 15µs making 2 calls to Date::Manip::Base::_rx_simple, avg 7µs/call
1878
1879 # Time replacement strings
18802338µs $self->_rx_replace('times');
# spent 338µs making 2 calls to Date::Manip::Base::_rx_replace, avg 169µs/call
1881
1882 # Some offset strings
18832327µs $self->_rx_replace('offset_date');
# spent 327µs making 2 calls to Date::Manip::Base::_rx_replace, avg 164µs/call
18842145µs $self->_rx_replace('offset_time');
# spent 145µs making 2 calls to Date::Manip::Base::_rx_replace, avg 73µs/call
1885
1886 # AM/PM strings
18872183µs $self->_rx_wordlists('ampm');
# spent 183µs making 2 calls to Date::Manip::Base::_rx_wordlists, avg 91µs/call
1888
1889 # Business/non-business mode
18902161µs $self->_rx_wordlists('mode');
# spent 161µs making 2 calls to Date::Manip::Base::_rx_wordlists, avg 80µs/call
1891
1892 return 0;
1893}
18943945µs243µs
# spent 27µs (12+16) within Date::Manip::Base::BEGIN@1894 which was called: # once (12µs+16µs) by Date::Manip::Obj::BEGIN@15 at line 1894
use strict 'refs';
# spent 27µs making 1 call to Date::Manip::Base::BEGIN@1894 # spent 16µs making 1 call to strict::import
1895
1896# This takes a string or strings from the language file which is a
1897# regular expression and copies it to the regular expression cache.
1898#
1899# If the language file contains a list of strings, a list of strings
1900# is stored in the regexp cache.
1901#
1902
# spent 56µs within Date::Manip::Base::_rx_simple which was called 6 times, avg 9µs/call: # 2 times (29µs+0s) by Date::Manip::Base::_language at line 1875, avg 15µs/call # 2 times (15µs+0s) by Date::Manip::Base::_language at line 1877, avg 7µs/call # 2 times (12µs+0s) by Date::Manip::Base::_language at line 1876, avg 6µs/call
sub _rx_simple {
19031870µs my($self,$ele) = @_;
1904
1905 if (exists $$self{'data'}{'lang'}{$ele}) {
1906 if (ref($$self{'data'}{'lang'}{$ele})) {
1907 @{ $$self{'data'}{'rx'}{$ele} } = @{ $$self{'data'}{'lang'}{$ele} };
1908 } else {
1909 $$self{'data'}{'rx'}{$ele} = $$self{'data'}{'lang'}{$ele};
1910 }
1911 } else {
1912 $$self{'data'}{'rx'}{$ele} = undef;
1913 }
1914}
1915
1916# This takes a list of words and creates a simple regexp which matches
1917# any of them.
1918#
1919# The first word in the list is the default way to express the word using
1920# a normal ASCII character set.
1921#
1922# The second word in the list is the default way to express the word using
1923# a locale character set. If it isn't defined, it defaults to the first word.
1924#
1925
# spent 382µs (298+83) within Date::Manip::Base::_rx_wordlist which was called 10 times, avg 38µs/call: # 2 times (87µs+40µs) by Date::Manip::Base::_language at line 1850, avg 64µs/call # 2 times (65µs+19µs) by Date::Manip::Base::_language at line 1851, avg 42µs/call # 2 times (69µs+9µs) by Date::Manip::Base::_language at line 1849, avg 39µs/call # 2 times (50µs+12µs) by Date::Manip::Base::_language at line 1852, avg 31µs/call # 2 times (26µs+3µs) by Date::Manip::Base::_language at line 1853, avg 15µs/call
sub _rx_wordlist {
1926122356µs my($self,$ele) = @_;
1927
1928 if (exists $$self{'data'}{'lang'}{$ele}) {
1929 my @tmp = @{ $$self{'data'}{'lang'}{$ele} };
1930
1931 $$self{'data'}{'wordlistA'}{$ele} = $tmp[0];
1932 if (defined $tmp[1] && $tmp[1]) {
1933 $$self{'data'}{'wordlistL'}{$ele} = $tmp[1];
1934 } else {
1935 $$self{'data'}{'wordlistL'}{$ele} = $tmp[0];
1936 }
1937
1938 my @tmp2;
1939 foreach my $tmp (@tmp) {
1940 push(@tmp2,"\Q$tmp\E") if ($tmp);
1941 }
19421083µs @tmp2 = sort _sortByLength(@tmp2);
# spent 83µs making 10 calls to Date::Manip::Base::CORE:sort, avg 8µs/call
1943
1944 $$self{'data'}{'rx'}{$ele} = join('|',@tmp2);
1945
1946 } else {
1947 $$self{'data'}{'rx'}{$ele} = undef;
1948 }
1949}
1950
1951# This takes a hash of the form:
1952# word => string
1953# and creates a regular expression to match word (which must be surrounded
1954# by word boundaries).
1955#
1956
# spent 810µs (477+334) within Date::Manip::Base::_rx_replace which was called 6 times, avg 135µs/call: # 2 times (186µs+152µs) by Date::Manip::Base::_language at line 1880, avg 169µs/call # 2 times (195µs+133µs) by Date::Manip::Base::_language at line 1883, avg 164µs/call # 2 times (96µs+49µs) by Date::Manip::Base::_language at line 1884, avg 73µs/call
sub _rx_replace {
1957102838µs my($self,$ele) = @_;
1958
1959 if (! exists $$self{'data'}{'lang'}{$ele}) {
1960 $$self{'data'}{'rx'}{$ele} = {};
1961 return;
1962 }
1963
1964 my(@key) = keys %{ $$self{'data'}{'lang'}{$ele} };
1965 my $i = 1;
1966 foreach my $key (@key) {
1967 my $val = $$self{'data'}{'lang'}{$ele}{$key};
196832193µs $$self{'data'}{'rx'}{$ele}[$i++] = qr/\b(\Q$key\E)\b/i;
# spent 138µs making 16 calls to Date::Manip::Base::CORE:regcomp, avg 9µs/call # spent 55µs making 16 calls to Date::Manip::Base::CORE:qr, avg 3µs/call
1969 $$self{'data'}{'wordmatch'}{$ele}{lc($key)} = $val;
1970 }
1971
1972649µs @key = sort _sortByLength(@key);
# spent 49µs making 6 calls to Date::Manip::Base::CORE:sort, avg 8µs/call
1973 @key = map { "\Q$_\E" } @key;
1974 my $rx = join('|',@key);
1975
19761292µs $$self{'data'}{'rx'}{$ele}[0] = qr/\b(?:$rx)\b/i;
# spent 70µs making 6 calls to Date::Manip::Base::CORE:regcomp, avg 12µs/call # spent 22µs making 6 calls to Date::Manip::Base::CORE:qr, avg 4µs/call
1977}
1978
1979# This takes a list of values, each of which can be expressed in multiple
1980# ways, and gets a regular expression which matches any of them, a default
1981# way to express each value, and a hash which matches a matched string to
1982# a value (the value is 1..N where N is the number of values).
1983#
1984
# spent 9.28ms (6.79+2.48) within Date::Manip::Base::_rx_wordlists which was called 26 times, avg 357µs/call: # 2 times (1.71ms+733µs) by Date::Manip::Base::_language at line 1864, avg 1.22ms/call # 2 times (1.50ms+697µs) by Date::Manip::Base::_language at line 1863, avg 1.10ms/call # 2 times (553µs+278µs) by Date::Manip::Base::_language at line 1860, avg 415µs/call # 2 times (522µs+121µs) by Date::Manip::Base::_language at line 1872, avg 322µs/call # 2 times (433µs+95µs) by Date::Manip::Base::_language at line 1871, avg 264µs/call # 2 times (442µs+74µs) by Date::Manip::Base::_language at line 1870, avg 258µs/call # 2 times (380µs+84µs) by Date::Manip::Base::_language at line 1869, avg 232µs/call # 2 times (311µs+104µs) by Date::Manip::Base::_language at line 1865, avg 208µs/call # 2 times (298µs+114µs) by Date::Manip::Base::_language at line 1868, avg 206µs/call # 2 times (234µs+68µs) by Date::Manip::Base::_language at line 1854, avg 151µs/call # 2 times (138µs+44µs) by Date::Manip::Base::_language at line 1887, avg 91µs/call # 2 times (134µs+41µs) by Date::Manip::Base::_language at line 1857, avg 87µs/call # 2 times (131µs+30µs) by Date::Manip::Base::_language at line 1890, avg 80µs/call
sub _rx_wordlists {
198540927.45ms my($self,$ele,$subset,$max) = @_;
1986 $subset = $ele if (! $subset);
1987
1988 if (exists $$self{'data'}{'lang'}{$ele}) {
1989 my @vallist = @{ $$self{'data'}{'lang'}{$ele} };
1990 $max = $#vallist+1 if (! $max || $max > $#vallist+1);
1991 my (@all);
1992
1993 for (my $i=1; $i<=$max; $i++) {
1994 my @tmp = @{ $$self{'data'}{'lang'}{$ele}[$i-1] };
1995
1996 $$self{'data'}{'wordlistA'}{$subset}[$i-1] = $tmp[0];
1997 if (defined $tmp[1] && $tmp[1]) {
1998 $$self{'data'}{'wordlistL'}{$subset}[$i-1] = $tmp[1];
1999 } else {
2000 $$self{'data'}{'wordlistL'}{$subset}[$i-1] = $tmp[0];
2001 }
2002
2003 my @str;
2004 foreach my $str (@tmp) {
2005 next if (! $str);
2006 $$self{'data'}{'wordmatch'}{$subset}{lc($str)} = $i;
2007 push(@str,"\Q$str\E");
2008 }
2009 push(@all,@str);
2010
20112541.33ms @str = sort _sortByLength(@str);
# spent 1.33ms making 254 calls to Date::Manip::Base::CORE:sort, avg 5µs/call
2012 $$self{'data'}{'rx'}{$subset}[$i] = join('|',@str);
2013 }
2014
2015261.15ms @all = sort _sortByLength(@all);
# spent 1.15ms making 26 calls to Date::Manip::Base::CORE:sort, avg 44µs/call
2016 $$self{'data'}{'rx'}{$subset}[0] = join('|',@all);
2017
2018 } else {
2019 $$self{'data'}{'rx'}{$subset} = undef;
2020 }
2021}
2022
2023# This sorts from longest to shortest element
2024#
2025358µs245µs
# spent 28µs (12+17) within Date::Manip::Base::BEGIN@2025 which was called: # once (12µs+17µs) by Date::Manip::Obj::BEGIN@15 at line 2025
no strict 'vars';
# spent 28µs making 1 call to Date::Manip::Base::BEGIN@2025 # spent 17µs making 1 call to strict::unimport
2026sub _sortByLength {
202718901.98ms return (length $b <=> length $a);
2028}
202933.21ms265µs
# spent 54µs (42+11) within Date::Manip::Base::BEGIN@2029 which was called: # once (42µs+11µs) by Date::Manip::Obj::BEGIN@15 at line 2029
use strict 'vars';
# spent 54µs making 1 call to Date::Manip::Base::BEGIN@2029 # spent 12µs making 1 call to strict::import
2030
2031###############################################################################
2032# Year functions
2033#
2034# $self->_method(METHOD) use METHOD as the method for YY->YYYY
2035# conversions
2036#
2037# YEAR = _fix_year(YR) converts a 2-digit to 4-digit year
2038
2039sub _method {
2040 my($self,$method) = @_;
2041 $self->_config('yytoyyyy',$method);
2042}
2043
2044sub _fix_year {
2045 my($self,$y) = @_;
2046 my $method = $self->_config('yytoyyyy');
2047
2048 return $y if (length($y)==4);
2049 return undef if (length($y)!=2);
2050
2051 my $curr_y;
2052 if (exists $$self{'objs'}{'tz'}) {
2053 ($curr_y) = $self->_now('y',1);
2054 } else {
2055 $curr_y = ( localtime(time) )[5];
2056 $curr_y += 1900;
2057 }
2058
2059 if ($method eq 'c') {
2060 return substr($curr_y,0,2) . $y;
2061
2062 } elsif ($method =~ /^c(\d\d)$/) {
2063 return "$1$y";
2064
2065 } elsif ($method =~ /^c(\d\d)(\d\d)$/) {
2066 return "$1$y" + ($y<$2 ? 100 : 0);
2067
2068 } else {
2069 my $y1 = $curr_y - $method;
2070 my $y2 = $y1 + 99;
2071 $y1 =~ /^(\d\d)/;
2072 $y = "$1$y";
2073 if ($y<$y1) {
2074 $y += 100;
2075 }
2076 if ($y>$y2) {
2077 $y -= 100;
2078 }
2079 return $y;
2080 }
2081}
2082
2083###############################################################################
2084# $self->_mod_add($N,$add,\$val,\$rem);
2085# This calculates $val=$val+$add and forces $val to be in a certain
2086# range. This is useful for adding numbers for which only a certain
2087# range is allowed (for example, minutes can be between 0 and 59 or
2088# months can be between 1 and 12). The absolute value of $N determines
2089# the range and the sign of $N determines whether the range is 0 to N-1
2090# (if N>0) or 1 to N (N<0). $rem is adjusted to force $val into the
2091# appropriate range.
2092# Example:
2093# To add 2 hours together (with the excess returned in days) use:
2094# $self->_mod_add(-24,$h1,\$h,\$day);
2095# To add 2 minutes together (with the excess returned in hours):
2096# $self->_mod_add(60,$mn1,\$mn,\$hr);
2097sub _mod_add {
2098 my($self,$N,$add,$val,$rem)=@_;
2099 return if ($N==0);
2100 $$val+=$add;
2101 if ($N<0) {
2102 # 1 to N
2103 $N = -$N;
2104 if ($$val>$N) {
2105 $$rem+= int(($$val-1)/$N);
2106 $$val = ($$val-1)%$N +1;
2107 } elsif ($$val<1) {
2108 $$rem-= int(-$$val/$N)+1;
2109 $$val = $N-(-$$val % $N);
2110 }
2111
2112 } else {
2113 # 0 to N-1
2114 if ($$val>($N-1)) {
2115 $$rem+= int($$val/$N);
2116 $$val = $$val%$N;
2117 } elsif ($$val<0) {
2118 $$rem-= int(-($$val+1)/$N)+1;
2119 $$val = ($N-1)-(-($$val+1)%$N);
2120 }
2121 }
2122}
2123
2124# $flag = $self->_is_int($string [,$low, $high]);
2125# Returns 1 if $string is a valid integer, 0 otherwise. If $low is
2126# entered, $string must be >= $low. If $high is entered, $string must
2127# be <= $high. It is valid to check only one of the bounds.
2128
# spent 303µs (232+70) within Date::Manip::Base::_is_int which was called 32 times, avg 9µs/call: # 24 times (186µs+44µs) by Date::Manip::Base::_normalize_hms at line 2363, avg 10µs/call # 2 times (19µs+13µs) by Date::Manip::Base::_config_var_recurnumfudgedays at line 1516, avg 16µs/call # 2 times (9µs+6µs) by Date::Manip::Base::_config_var_workweekbeg at line 1538, avg 7µs/call # 2 times (10µs+4µs) by Date::Manip::Base::_config_var_firstday at line 1620, avg 7µs/call # 2 times (9µs+4µs) by Date::Manip::Base::_config_var_workweekend at line 1555, avg 6µs/call
sub _is_int {
212996359µs my($self,$N,$low,$high)=@_;
21303270µs return 0 if (! defined $N or
# spent 70µs making 32 calls to Date::Manip::Base::CORE:match, avg 2µs/call
2131 $N !~ /^\s*[-+]?\d+\s*$/ or
2132 defined $low && $N<$low or
2133 defined $high && $N>$high);
2134 return 1;
2135}
2136
2137###############################################################################
2138# Split/Join functions
2139
2140
# spent 319µs (79+241) within Date::Manip::Base::split which was called 4 times, avg 80µs/call: # 4 times (79µs+241µs) by Date::Manip::Base::_config_var_workdaybegend at line 1588, avg 80µs/call
sub split {
214136104µs my($self,$op,$string) = @_;
2142
2143 given ($op) {
2144
2145 when ('date') {
2146 if ($string =~ /^(\d\d\d\d)(\d\d)(\d\d)(\d\d):(\d\d):(\d\d)$/ ||
2147 $string =~ /^(\d\d\d\d)\-(\d\d)\-(\d\d)\-(\d\d):(\d\d):(\d\d)$/ ||
2148 $string =~ /^(\d\d\d\d)(\d\d)(\d\d)(\d\d)(\d\d)(\d\d)$/) {
2149 my($y,$m,$d,$h,$mn,$s) = ($1+0,$2+0,$3+0,$4+0,$5+0,$6+0);
2150 return [$y,$m,$d,$h,$mn,$s];
2151 } else {
2152 return undef;
2153 }
2154 }
2155
2156 when ('offset') {
2157 if ($string =~ /^([-+]?)(\d\d)(\d\d)(\d\d)$/ ||
2158 $string =~ /^([-+]?)(\d\d)(\d\d)()$/ ||
2159 $string =~ /^([-+]?)(\d\d?):(\d\d):(\d\d)$/ ||
2160 $string =~ /^([-+]?)(\d\d?):(\d\d)()$/ ||
2161 $string =~ /^([-+]?)(\d\d?)()()$/) {
2162 my($err,$h,$mn,$s) = $self->_normalize_offset('split',$1,$2,$3,$4);
2163 return undef if ($err);
2164 return [$h,$mn,$s];
2165 } else {
2166 return undef;
2167 }
2168 }
2169
2170 when ('hms') {
21711225µs if ($string =~ /^(\d\d)(\d\d)(\d\d)$/ ||
# spent 25µs making 12 calls to Date::Manip::Base::CORE:match, avg 2µs/call
2172 $string =~ /^(\d\d)(\d\d)()$/ ||
2173 $string =~ /^(\d\d?):(\d\d):(\d\d)$/ ||
2174 $string =~ /^(\d\d?):(\d\d)()$/ ||
2175 $string =~ /^(\d\d?)()()$/) {
21764216µs my($err,$h,$mn,$s) = $self->_normalize_hms('split',$1,$2,$3);
# spent 216µs making 4 calls to Date::Manip::Base::_normalize_hms, avg 54µs/call
2177 return undef if ($err);
2178 return [$h,$mn,$s];
2179 } else {
2180 return undef;
2181 }
2182 }
2183
2184 when ('time') {
2185 if ($string =~ /^[-+]?\d+(:[-+]?\d+){0,2}$/) {
2186 my($err,$dh,$dmn,$ds) = $self->_normalize_time('split',split(/:/,$string));
2187 return undef if ($err);
2188 return [$dh,$dmn,$ds];
2189 } else {
2190 return undef;
2191 }
2192 }
2193
2194 when ('delta') {
2195 if ($string =~ /^[-+]?\d*(:[-+]?\d*){0,6}$/) {
2196 $string =~ s/::/:0:/g;
2197 $string =~ s/^:/0:/;
2198 $string =~ s/:$/:0/;
2199 my($err,@delta) = $self->_normalize_delta('split',split(/:/,$string));
2200 return undef if ($err);
2201 return [@delta];
2202 } else {
2203 return undef;
2204 }
2205 }
2206
2207 when ('business') {
2208 if ($string =~ /^[-+]?\d*(:[-+]?\d*){0,6}$/) {
2209 $string =~ s/::/:0:/g;
2210 $string =~ s/^:/0:/;
2211 $string =~ s/:$/:0/;
2212 my($err,@delta) = $self->_normalize_business('split',split(/:/,$string));
2213 return undef if ($err);
2214 return [@delta];
2215 } else {
2216 return undef;
2217 }
2218 }
2219 }
2220}
2221
2222
# spent 23µs within Date::Manip::Base::_join_date which was called 2 times, avg 11µs/call: # 2 times (23µs+0s) by Date::Manip::TZ::date_period at line 1061 of Date/Manip/TZ.pm, avg 11µs/call
sub _join_date {
22231826µs my($self,$data) = @_;
2224 my($y,$m,$d,$h,$mn,$s) = @$data;
2225 while (length($y) < 4) {
2226 $y = "0$y";
2227 }
2228 $m = "0$m" if (length($m)==1);
2229 $d = "0$d" if (length($d)==1);
2230 $h = "0$h" if (length($h)==1);
2231 $mn = "0$mn" if (length($mn)==1);
2232 $s = "0$s" if (length($s)==1);
2233 return "$y$m$d$h:$mn:$s";
2234}
2235
2236
# spent 287µs (58+229) within Date::Manip::Base::join which was called 4 times, avg 72µs/call: # 4 times (58µs+229µs) by Date::Manip::Base::_config_var_workdaybegend at line 1594, avg 72µs/call
sub join{
22373656µs my($self,$op,$data) = @_;
2238 my @data = @$data;
2239
2240 given ($op) {
2241
2242 when ('date') {
2243 my($err,$y,$m,$d,$h,$mn,$s) = $self->_normalize_date(@data);
2244 return undef if ($err);
2245 my $form = $self->_config('printable');
2246 if ($form == 1) {
2247 return "$y$m$d$h$mn$s";
2248 } elsif ($form == 2) {
2249 return "$y-$m-$d-$h:$mn:$s";
2250 } else {
2251 return "$y$m$d$h:$mn:$s";
2252 }
2253 }
2254
2255 when ('offset') {
2256 my($err,$h,$mn,$s) = $self->_normalize_offset('join','',@data);
2257 return undef if ($err);
2258 return "$h:$mn:$s";
2259 }
2260
2261 when ('hms') {
22624229µs my($err,$h,$mn,$s) = $self->_normalize_hms('join',@data);
# spent 229µs making 4 calls to Date::Manip::Base::_normalize_hms, avg 57µs/call
2263 return undef if ($err);
2264 return "$h:$mn:$s";
2265 }
2266
2267 when ('time') {
2268 my($err,$dh,$dmn,$ds) = $self->_normalize_time('join',@data);
2269 return undef if ($err);
2270 return "$dh:$dmn:$ds";
2271 }
2272
2273 when ('delta') {
2274 my($err,@delta) = $self->_normalize_delta('join',@data);
2275 return undef if ($err);
2276 return join(':',@delta);
2277 }
2278
2279 when ('business') {
2280 my($err,@delta) = $self->_normalize_business('join',@data);
2281 return undef if ($err);
2282 return join(':',@delta);
2283 }
2284 }
2285}
2286
2287sub _normalize_date {
2288 my($self,@fields) = @_;
2289 return (1) if ($#fields != 5);
2290
2291 my($y,$m,$d,$h,$mn,$s) = @fields;
2292
2293 while (length($y) < 4) {
2294 $y = "0$y";
2295 }
2296 $m = "0$m" if (length($m)==1);
2297 $d = "0$d" if (length($d)==1);
2298 $h = "0$h" if (length($h)==1);
2299 $mn = "0$mn" if (length($mn)==1);
2300 $s = "0$s" if (length($s)==1);
2301
2302 return (0,$y,$m,$d,$h,$mn,$s);
2303}
2304
2305sub _normalize_offset {
2306 my($self,$op,$sign,@fields) = @_;
2307 while ($#fields < 2) {
2308 push(@fields,0);
2309 }
2310 return (1) if ($#fields != 2);
2311
2312 my($h,$mn,$s) = @fields;
2313 $h *= 1;
2314 $mn = 0 if (! $mn);
2315 $mn *= 1;
2316 $s = 0 if (! $s);
2317 $s *= 1;
2318
2319 return (1) if (! $self->_is_int($h,-23,23) ||
2320 ! $self->_is_int($mn,-59,59) ||
2321 ! $self->_is_int($s,-59,59));
2322
2323 if ($op eq 'join') {
2324 if ($h >= 0 && $mn >= 0 && $s >= 0) {
2325 $sign = '+';
2326 } elsif ($h <= 0 && $mn <= 0 && $s <= 0) {
2327 $sign = '-';
2328 $h *= -1;
2329 $mn *= -1;
2330 $s *= -1;
2331 } else {
2332 return (1);
2333 }
2334
2335 $h = "0$h" if ($h < 10);
2336 $mn = "0$mn" if ($mn < 10);
2337 $s = "0$s" if ($s < 10);
2338 $h = "$sign$h";
2339
2340 } elsif ($sign eq '-') {
2341 $h *= -1;
2342 $mn *= -1;
2343 $s *= -1;
2344 }
2345
2346 return (0,$h,$mn,$s);
2347}
2348
2349
# spent 444µs (214+230) within Date::Manip::Base::_normalize_hms which was called 8 times, avg 56µs/call: # 4 times (108µs+121µs) by Date::Manip::Base::join at line 2262, avg 57µs/call # 4 times (106µs+109µs) by Date::Manip::Base::split at line 2176, avg 54µs/call
sub _normalize_hms {
2350124189µs my($self,$op,@fields) = @_;
2351 while ($#fields < 2) {
2352 push(@fields,0);
2353 }
2354 return (1) if ($#fields != 2);
2355
2356 my($h,$mn,$s) = @fields;
2357 $h *= 1;
2358 $mn = 0 if (! $mn);
2359 $mn *= 1;
2360 $s = 0 if (! $s);
2361 $s *= 1;
2362
236324230µs return (1) if (! $self->_is_int($h,0,24) ||
# spent 230µs making 24 calls to Date::Manip::Base::_is_int, avg 10µs/call
2364 ! $self->_is_int($mn,0,59) ||
2365 ! $self->_is_int($s,0,59));
2366
2367 if ($op eq 'join') {
2368 $h = "0$h" if ($h < 10);
2369 $mn = "0$mn" if ($mn < 10);
2370 $s = "0$s" if ($s < 10);
2371 }
2372
2373 return (0,$h,$mn,$s) if ($h==24 && ! $mn && ! $s);
2374 return (1) if ($h==24);
2375 return (0,$h,$mn,$s);
2376}
2377
2378sub _normalize_time {
2379 my($self,$op,@fields) = @_;
2380 while ($#fields < 2) {
2381 unshift(@fields,0);
2382 }
2383 return (1) if ($#fields != 2);
2384
2385 # If we're splitting, the sign needs to be carried.
2386
2387 if ($op eq 'split') {
2388 my ($sign) = '+';
2389 foreach my $f (@fields) {
2390 if ($f =~ /^([-+])/) {
2391 $sign = $1;
2392 } else {
2393 $f = "$sign$f";
2394 }
2395 }
2396 }
2397
2398 my($h,$mn,$s) = @fields;
2399
2400 # Normalize
2401
2402 my $sign = '+';
2403
2404 $s += $h*3600 + $mn*60; # convert h/m to s
2405 if ($op eq 'join' && $s < 0) {
2406 $sign = '-';
2407 $s = abs($s);
2408 }
2409
2410 $mn = int($s/60); # convert s to m
2411 $s -= $mn*60;
2412
2413 $h = int($mn/60); # convert m to h
2414 $mn -= $h*60;
2415
2416 $h = "$sign$h" if ($op eq 'join' && $sign eq '-');
2417
2418 return (0,$h,$mn,$s);
2419}
2420
2421sub _normalize_delta {
2422 my($self,$op,@fields) = @_;
2423 foreach my $f (@fields) {
2424 $f=0 if (! defined($f));
2425 }
2426 while ($#fields < 6) {
2427 unshift(@fields,0);
2428 }
2429 return (1) if ($#fields != 6);
2430
2431 # If we're splitting, the sign needs to be carried.
2432
2433 if ($op eq 'split') {
2434 my ($sign) = '+';
2435 foreach my $f (@fields) {
2436 if ($f =~ /^([-+])/) {
2437 $sign = $1;
2438 } else {
2439 $f = "$sign$f";
2440 }
2441 $f *= 1;
2442 }
2443
2444 } elsif ($op eq 'norm') {
2445 foreach my $f (@fields) {
2446 $f *= 1;
2447 }
2448 }
2449
2450 my($y,$m,$w,$d,$h,$mn,$s) = @fields;
2451
2452 ($y,$m) = $self->_normalize_ym($op,$y,$m);
2453 ($w,$d,$h,$mn,$s) = $self->_normalize_wdhms($op,$w,$d,$h,$mn,$s);
2454
2455 return (0,$y,$m,$w,$d,$h,$mn,$s);
2456}
2457
2458sub _normalize_business {
2459 my($self,$op,@fields) = @_;
2460 foreach my $f (@fields) {
2461 $f=0 if (! defined($f));
2462 }
2463 while ($#fields < 6) {
2464 unshift(@fields,0);
2465 }
2466 return (1) if ($#fields != 6);
2467
2468 # If we're splitting, the sign needs to be carried.
2469
2470 if ($op eq 'split') {
2471 my ($sign) = '+';
2472 foreach my $f (@fields) {
2473 if ($f =~ /^([-+])/) {
2474 $sign = $1;
2475 } else {
2476 $f = "$sign$f";
2477 }
2478 $f *= 1;
2479 }
2480
2481 } elsif ($op eq 'norm') {
2482 foreach my $f (@fields) {
2483 $f *= 1;
2484 }
2485 }
2486
2487 my($y,$m,$w,$d,$h,$mn,$s) = @fields;
2488
2489 ($y,$m) = $self->_normalize_ym($op,$y,$m);
2490 $w = $self->_normalize_w($op,$w);
2491 ($d,$h,$mn,$s) = $self->_normalize_dhms($op,$d,$h,$mn,$s);
2492
2493 return (0,$y,$m,$w,$d,$h,$mn,$s);
2494}
2495
2496sub _normalize_ym {
2497 my($self,$op,$y,$m) = @_;
2498
2499 my $sign = '+';
2500
2501 $m += $y*12;
2502 if ($op eq 'join' && $m < 0) {
2503 $sign = '-';
2504 $m = abs($m);
2505 }
2506
2507 $y = int($m/12);
2508 $m -= $y*12;
2509
2510 $y = "$sign$y" if ($op eq 'join');
2511 return ($y,$m);
2512}
2513
2514sub _normalize_wdhms {
2515 my($self,$op,$w,$d,$h,$mn,$s) = @_;
2516
2517 my($len) = 86400; # 24*3600
2518 my $sign = '+';
2519
2520 {
2521 # Unfortunately, $s overflows for dates more than ~70 years
2522 # apart. Do the minimum amount of work here.
25233225µs249µs
# spent 41µs (32+9) within Date::Manip::Base::BEGIN@2523 which was called: # once (32µs+9µs) by Date::Manip::Obj::BEGIN@15 at line 2523
no integer;
# spent 41µs making 1 call to Date::Manip::Base::BEGIN@2523 # spent 8µs making 1 call to integer::unimport
2524
2525 $s += ($d+7*$w)*$len + $h*3600 + $mn*60; # convert w/d/h/m to s
2526 if ($op eq 'join' && $s < 0) {
2527 $sign = '-';
2528 $s = abs($s);
2529 }
2530
2531 $d = int($s/$len); # convert s to d
2532 $s -= $d*$len;
2533 }
2534
2535 $mn = int($s/60); # convert s to m
2536 $s -= $mn*60;
2537
2538 $h = int($mn/60); # convert m to h
2539 $mn -= $h*60;
2540
2541 $w = int($d/7); # convert d to w
2542 $d -= $w*7;
2543
2544 # Attach the sign
2545
2546 $w = "$sign$w" if ($op eq 'join');
2547
2548 return ($w,$d,$h,$mn,$s);
2549}
2550
2551sub _normalize_w {
2552 my($self,$op,$w) = @_;
2553
2554 $w = "+$w" if ($op eq 'join' && $w >= 0);
2555
2556 return $w;
2557}
2558
2559sub _normalize_dhms {
2560 my($self,$op,$d,$h,$mn,$s) = @_;
2561
2562 my($sign) = '+';
2563 my($len) = $$self{'data'}{'calc'}{'bdlength'};
2564
2565 {
2566 # Unfortunately, $s overflows for dates more than ~70 years
2567 # apart. Do the minimum amount of work here.
25683843µs219µs
# spent 16µs (13+3) within Date::Manip::Base::BEGIN@2568 which was called: # once (13µs+3µs) by Date::Manip::Obj::BEGIN@15 at line 2568
no integer;
# spent 16µs making 1 call to Date::Manip::Base::BEGIN@2568 # spent 3µs making 1 call to integer::unimport
2569
2570 $s += $d*$len + $h*3600 + $mn*60; # convert d/h/m to s
2571 if ($op eq 'join' && $s < 0) {
2572 $sign = '-';
2573 $s = abs($s);
2574 }
2575
2576 $d = int($s/$len); # convert s to d
2577 $s -= $d*$len;
2578 }
2579
2580 $mn = int($s/60); # convert s to m
2581 $s -= $mn*60;
2582
2583 $h = int($mn/60); # convert m to h
2584 $mn -= $h*60;
2585
2586 # Attach the sign
2587
2588 $d = "$sign$d" if ($op eq 'join');
2589
2590 return ($d,$h,$mn,$s);
2591}
2592
2593# $self->_delta_convert(FORMAT,DELTA)
2594# This converts delta into the given format. Returns '' if invalid.
2595#
2596sub _delta_convert {
2597 my($self,$format,$delta)=@_;
2598 my $fields = $self->split($format,$delta);
2599 return undef if (! defined $fields);
2600 return $self->join($format,$fields);
2601}
2602
2603###############################################################################
2604# Timezone critical dates
2605
2606# NOTE: Although I would prefer to stick this routine in the
2607# Date::Manip::TZ module where it would be more appropriate, it must
2608# appear here as it will be used to generate the data that will be
2609# used by the Date::Manip::TZ module.
2610#
2611# This calculates a critical date based on timezone information. The
2612# critical date is the date (usually in the current time) at which
2613# the current timezone period ENDS.
2614#
2615# Input is:
2616# $year,$mon,$flag,$num,$dow
2617# This is information from the appropriate Rule line from the
2618# zoneinfo files. These are used to determine the date (Y/M/D)
2619# when the timezone period will end.
2620# $isdst
2621# Whether or not the next timezone period is a Daylight Saving
2622# Time period.
2623# $time,$timetype
2624# The time of day when the change occurs. The timetype can be
2625# 'w' (wallclock time in the current period), 's' (standard
2626# time which will match wallclock time in a non-DST period, or
2627# be off an hour in a DST period), and 'u' (universal time).
2628#
2629# Output is:
2630# $endUT, $endLT, $begUT, $begLT
2631# endUT is the actual last second of the current timezone
2632# period. endLT is the same time expressed in local time.
2633# begUT is the start (in UT) of the next time period. Note that
2634# the begUT date is the one which actually corresponds to the
2635# date/time specified in the input. begLT is the time in the new
2636# local time. The endUT/endLT are the time one second earlier.
2637#
2638sub _critical_date {
2639 my($self,$year,$mon,$flag,$num,$dow,
2640 $isdst,$time,$timetype,$stdoff,$dstoff) = @_;
2641
2642 #
2643 # Get the predicted Y/M/D
2644 #
2645
2646 my($y,$m,$d) = ($year+0,$mon+0,1);
2647
2648 if ($flag eq 'dom') {
2649 $d = $num;
2650
2651 } elsif ($flag eq 'last') {
2652 my $ymd = $self->nth_day_of_week($year,-1,$dow,$mon);
2653 $d = $$ymd[2];
2654
2655 } elsif ($flag eq 'ge') {
2656 my $ymd = $self->nth_day_of_week($year,1,$dow,$mon);
2657 $d = $$ymd[2];
2658 while ($d < $num) {
2659 $d += 7;
2660 }
2661
2662 } elsif ($flag eq 'le') {
2663 my $ymd = $self->nth_day_of_week($year,-1,$dow,$mon);
2664 $d = $$ymd[2];
2665 while ($d > $num) {
2666 $d -= 7;
2667 }
2668 }
2669
2670 #
2671 # Get the predicted time and the date (not yet taking into
2672 # account time type).
2673 #
2674
2675 my($h,$mn,$s) = @{ $self->split('hms',$time) };
2676 my $date = [ $y,$m,$d,$h,$mn,$s ];
2677
2678 #
2679 # Calculate all the relevant dates.
2680 #
2681
2682 my($endUT,$endLT,$begUT,$begLT,$offset);
2683 $stdoff = $self->split('offset',$stdoff);
2684 $dstoff = $self->split('offset',$dstoff);
2685
2686 if ($timetype eq 'w') {
2687 $begUT = $self->calc_date_time($date,($isdst ? $stdoff : $dstoff), 1);
2688 } elsif ($timetype eq 'u') {
2689 $begUT = $date;
2690 } else {
2691 $begUT = $self->calc_date_time($date,$stdoff, 1);
2692 }
2693
2694 $endUT = $self->calc_date_time($begUT,[0,0,-1]);
2695 $endLT = $self->calc_date_time($endUT,($isdst ? $stdoff : $dstoff));
2696 $begLT = $self->calc_date_time($begUT,($isdst ? $dstoff : $stdoff));
2697
2698 return ($endUT,$endLT,$begUT,$begLT);
2699}
2700
2701###############################################################################
2702#### **** DEPRECATED FUNCTIONS ****
2703
2704# $File=_ExpandTilde($file);
2705# This checks to see if a '~' appears as the first character in a path.
2706# If it does, the "~" expansion is interpreted (if possible) and the full
2707# path is returned. If a "~" expansion is used but cannot be
2708# interpreted, an empty string is returned.
2709#
2710# This is Windows/Mac friendly.
2711# This is efficient.
2712sub _ExpandTilde {
2713 my($self,$file) = @_;
2714 my($user,$home);
2715
2716 # ~aaa/bbb= ~ aaa /bbb
2717 if ($file =~ s|^~([^/]*)||) {
2718 $user=$1;
2719 # Single user operating systems (Mac, MSWindows) don't have the getpwnam
2720 # and getpwuid routines defined. Try to catch various different ways
2721 # of knowing we are on one of these systems:
2722 my $os = $self->_os();
2723 return '' if ($os eq 'Windows' or
2724 $os eq 'Other');
2725 $user='' if (! defined $user);
2726
2727 if ($user) {
2728 $home= (getpwnam($user))[7];
2729 } else {
2730 $home= (getpwuid($<))[7];
2731 }
2732 $home = VMS::Filespec::unixpath($home) if ($os eq 'VMS');
2733 return '' if (! $home);
2734 $file="$home/$file";
2735 }
2736 $file;
2737}
2738
2739# $File=_SearchPath($file,$path,$sep);
2740# Searches through directories in $path for a file named $file. The
2741# full path is returned if one is found, or an empty string otherwise.
2742# $sep is the path separator.
2743#
2744sub _SearchPath {
2745 my($self,$file,$path,$sep) = @_;
2746 my @dir = split(/\Q$sep\E/,$path);
2747
2748 foreach my $d (@dir) {
2749 my $f = "$d/$file";
2750 $f =~ s|//|/|g;
2751 $f = $self->_ExpandTilde($f);
2752 return $f if (-r $f);
2753 }
2754 return '';
2755}
2756
2757112µs1;
2758# Local Variables:
2759# mode: cperl
2760# indent-tabs-mode: nil
2761# cperl-indent-level: 3
2762# cperl-continued-statement-offset: 2
2763# cperl-continued-brace-offset: 0
2764# cperl-brace-offset: 0
2765# cperl-brace-imaginary-offset: 0
2766# cperl-label-offset: -2
2767# End:
 
# spent 174µs within Date::Manip::Base::CORE:match which was called 85 times, avg 2µs/call: # 32 times (70µs+0s) by Date::Manip::Base::_is_int at line 2130, avg 2µs/call # 32 times (34µs+0s) by Date::Manip::Base::_os at line 986, avg 1µs/call # 12 times (25µs+0s) by Date::Manip::Base::split at line 2171, avg 2µs/call # 6 times (9µs+0s) by Date::Manip::Base::_config_var at line 1364, avg 2µs/call # 2 times (28µs+0s) by Date::Manip::Base::_config_var_recurrange at line 1527, avg 14µs/call # once (7µs+0s) by Date::Manip::Base::_config_var_setdate at line 1655
sub Date::Manip::Base::CORE:match; # opcode
# spent 91µs within Date::Manip::Base::CORE:qr which was called 26 times, avg 4µs/call: # 16 times (55µs+0s) by Date::Manip::Base::_rx_replace at line 1968, avg 3µs/call # 6 times (22µs+0s) by Date::Manip::Base::_rx_replace at line 1976, avg 4µs/call # once (7µs+0s) by Date::Manip::Base::_config_var_setdate at line 1646 # once (5µs+0s) by Date::Manip::Base::_config_var_setdate at line 1643 # once (2µs+0s) by Date::Manip::Base::_config_var_setdate at line 1644 # once (1µs+0s) by Date::Manip::Base::_config_var_setdate at line 1645
sub Date::Manip::Base::CORE:qr; # opcode
# spent 236µs within Date::Manip::Base::CORE:regcomp which was called 23 times, avg 10µs/call: # 16 times (138µs+0s) by Date::Manip::Base::_rx_replace at line 1968, avg 9µs/call # 6 times (70µs+0s) by Date::Manip::Base::_rx_replace at line 1976, avg 12µs/call # once (28µs+0s) by Date::Manip::Base::_config_var_setdate at line 1655
sub Date::Manip::Base::CORE:regcomp; # opcode
# spent 2.62ms within Date::Manip::Base::CORE:sort which was called 296 times, avg 9µs/call: # 254 times (1.33ms+0s) by Date::Manip::Base::_rx_wordlists at line 2011, avg 5µs/call # 26 times (1.15ms+0s) by Date::Manip::Base::_rx_wordlists at line 2015, avg 44µs/call # 10 times (83µs+0s) by Date::Manip::Base::_rx_wordlist at line 1942, avg 8µs/call # 6 times (49µs+0s) by Date::Manip::Base::_rx_replace at line 1972, avg 8µs/call
sub Date::Manip::Base::CORE:sort; # opcode
Report produced by the NYTProf 4.04 Perl profiler, developed by Tim Bunce and Adam Kaplan.