line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package Date::EzDate2; |
2
|
1
|
|
|
1
|
|
1753
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
23
|
|
3
|
1
|
|
|
1
|
|
3
|
use Carp 'croak'; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
63
|
|
4
|
|
|
|
|
|
|
|
5
|
|
|
|
|
|
|
# debugging tools |
6
|
|
|
|
|
|
|
# use Debug::ShowStuff ':all'; |
7
|
|
|
|
|
|
|
# use Debug::ShowStuff::ShowVar; |
8
|
|
|
|
|
|
|
|
9
|
|
|
|
|
|
|
# version |
10
|
|
|
|
|
|
|
our $VERSION = '0.01'; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
14
|
|
|
|
|
|
|
# pod |
15
|
|
|
|
|
|
|
# |
16
|
|
|
|
|
|
|
|
17
|
|
|
|
|
|
|
=head1 NAME |
18
|
|
|
|
|
|
|
|
19
|
|
|
|
|
|
|
Date::EzDate2 - Date and time manipulation made easy |
20
|
|
|
|
|
|
|
|
21
|
|
|
|
|
|
|
=head1 EzDate2 vs EzDate |
22
|
|
|
|
|
|
|
|
23
|
|
|
|
|
|
|
EzDate2 is the next generation of the module Date::EzDate. EzDate2 provides |
24
|
|
|
|
|
|
|
the same easy interface for dealing with date and time, but uses DateTime |
25
|
|
|
|
|
|
|
to provide a wider and more accurate set of services. |
26
|
|
|
|
|
|
|
|
27
|
|
|
|
|
|
|
EzDate2 is *NOT* a drop-in replacement for EzDate. That's why it's not just |
28
|
|
|
|
|
|
|
an updated version of EzDate. |
29
|
|
|
|
|
|
|
|
30
|
|
|
|
|
|
|
This early release is just to test EzDate2's distribution on CPAN. It's not yet |
31
|
|
|
|
|
|
|
ready for prime time. |
32
|
|
|
|
|
|
|
|
33
|
|
|
|
|
|
|
=head1 SYNOPSIS |
34
|
|
|
|
|
|
|
|
35
|
|
|
|
|
|
|
An EzDate2 object represents a single point in time and exposes all properties |
36
|
|
|
|
|
|
|
of that point. It also makes it easy to change those properties to produce |
37
|
|
|
|
|
|
|
a different point in time. EzDate2 has many features, here are a few: |
38
|
|
|
|
|
|
|
|
39
|
|
|
|
|
|
|
use Date::EzDate2; |
40
|
|
|
|
|
|
|
my $mydate = Date::EzDate2->new(); |
41
|
|
|
|
|
|
|
|
42
|
|
|
|
|
|
|
# output some date information |
43
|
|
|
|
|
|
|
print $mydate, "\n"; # e.g. output: Fri Jul 22, 2016 16:53:33 |
44
|
|
|
|
|
|
|
|
45
|
|
|
|
|
|
|
=cut |
46
|
|
|
|
|
|
|
|
47
|
|
|
|
|
|
|
# |
48
|
|
|
|
|
|
|
# pod |
49
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
50
|
|
|
|
|
|
|
|
51
|
|
|
|
|
|
|
|
52
|
|
|
|
|
|
|
|
53
|
|
|
|
|
|
|
# warn levels |
54
|
1
|
|
|
1
|
|
3
|
use constant WARN_NONE => 0; |
|
1
|
|
|
|
|
3
|
|
|
1
|
|
|
|
|
65
|
|
55
|
1
|
|
|
1
|
|
3
|
use constant WARN_STDERR => 1; |
|
1
|
|
|
|
|
8
|
|
|
1
|
|
|
|
|
36
|
|
56
|
1
|
|
|
1
|
|
2
|
use constant WARN_CROAK => 2; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
91
|
|
57
|
|
|
|
|
|
|
our $default_warning = WARN_STDERR; |
58
|
|
|
|
|
|
|
|
59
|
|
|
|
|
|
|
|
60
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
61
|
|
|
|
|
|
|
# object overloading |
62
|
|
|
|
|
|
|
# |
63
|
|
|
|
|
|
|
use overload |
64
|
6
|
|
|
6
|
|
60
|
'""' => sub{$_[0]->{'default'}}, # stringification |
65
|
1
|
|
|
|
|
9
|
'<=>' => \&compare, # comparison |
66
|
|
|
|
|
|
|
'+' => \&addition, # addition |
67
|
|
|
|
|
|
|
'-' => \&subtraction, # subtraction |
68
|
1
|
|
|
1
|
|
966
|
fallback => 1; # operations not defined here |
|
1
|
|
|
|
|
925
|
|
69
|
|
|
|
|
|
|
# |
70
|
|
|
|
|
|
|
# object overloading |
71
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
72
|
|
|
|
|
|
|
|
73
|
|
|
|
|
|
|
|
74
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
75
|
|
|
|
|
|
|
# new |
76
|
|
|
|
|
|
|
# |
77
|
|
|
|
|
|
|
sub new { |
78
|
40
|
|
|
40
|
0
|
9022
|
my ($class, $time, %opts) = @_; |
79
|
40
|
|
|
|
|
51
|
my ($rv, %tiehash); |
80
|
|
|
|
|
|
|
|
81
|
|
|
|
|
|
|
# TESTING |
82
|
|
|
|
|
|
|
# println subname(); ##i |
83
|
|
|
|
|
|
|
|
84
|
|
|
|
|
|
|
# create tied hash |
85
|
40
|
50
|
|
|
|
226
|
tie(%tiehash, $class . '::Tie', $time, %opts) or return undef; |
86
|
|
|
|
|
|
|
|
87
|
|
|
|
|
|
|
# create blessed reference to tied hash |
88
|
40
|
|
|
|
|
109
|
$rv = bless(\%tiehash, $class); |
89
|
|
|
|
|
|
|
|
90
|
|
|
|
|
|
|
# return |
91
|
40
|
|
|
|
|
92
|
return $rv; |
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
# |
94
|
|
|
|
|
|
|
# new |
95
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
96
|
|
|
|
|
|
|
|
97
|
|
|
|
|
|
|
|
98
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
99
|
|
|
|
|
|
|
# clone |
100
|
|
|
|
|
|
|
# |
101
|
|
|
|
|
|
|
sub clone { |
102
|
16
|
|
|
16
|
0
|
111
|
my ($ezdate) = @_; |
103
|
|
|
|
|
|
|
|
104
|
|
|
|
|
|
|
# TESTING |
105
|
|
|
|
|
|
|
# println subname(), ' - ', __PACKAGE__; ##i |
106
|
|
|
|
|
|
|
|
107
|
|
|
|
|
|
|
# call tied object's new() |
108
|
16
|
|
|
|
|
42
|
return ref($ezdate)->new($ezdate); |
109
|
|
|
|
|
|
|
} |
110
|
|
|
|
|
|
|
# |
111
|
|
|
|
|
|
|
# clone |
112
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
113
|
|
|
|
|
|
|
|
114
|
|
|
|
|
|
|
|
115
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
116
|
|
|
|
|
|
|
# next_month |
117
|
|
|
|
|
|
|
# |
118
|
|
|
|
|
|
|
sub next_month { |
119
|
3
|
|
|
3
|
0
|
24
|
my ($ezdate, $count) = @_; |
120
|
|
|
|
|
|
|
|
121
|
|
|
|
|
|
|
# TESTING |
122
|
|
|
|
|
|
|
# println subname(); ##i |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
# call tied object's next_month() |
125
|
3
|
|
|
|
|
7
|
return tied(%$ezdate)->next_month($count); |
126
|
|
|
|
|
|
|
} |
127
|
|
|
|
|
|
|
# |
128
|
|
|
|
|
|
|
# next_month |
129
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
130
|
|
|
|
|
|
|
|
131
|
|
|
|
|
|
|
|
132
|
|
|
|
|
|
|
|
133
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
134
|
|
|
|
|
|
|
# settings and utility subs |
135
|
|
|
|
|
|
|
# |
136
|
0
|
|
|
0
|
0
|
0
|
sub zero_hour_ampm {return $_[0]->tie_ob->{'zero_hour_ampm'} = $_[1]} |
137
|
|
|
|
|
|
|
|
138
|
1
|
|
|
1
|
0
|
8
|
sub set_format {return $_[0]->tie_ob->set_format(@_[1..$#_])} |
139
|
|
|
|
|
|
|
|
140
|
|
|
|
|
|
|
sub get_format { |
141
|
0
|
|
|
0
|
0
|
0
|
my ($self, $key) = @_; |
142
|
0
|
|
|
|
|
0
|
my $ob = $self->tie_ob; |
143
|
0
|
|
|
|
|
0
|
$key =~ s|\s||gs; |
144
|
0
|
|
|
|
|
0
|
$key = lc($key); |
145
|
0
|
|
|
|
|
0
|
return join('', @{$ob->{'formats'}->{$key}}); |
|
0
|
|
|
|
|
0
|
|
146
|
|
|
|
|
|
|
} |
147
|
|
|
|
|
|
|
|
148
|
0
|
|
|
0
|
0
|
0
|
sub del_format {return delete $_[0]->{$_[1]}} |
149
|
18
|
|
|
18
|
0
|
22
|
sub tie_ob{return tied(%{$_[0]})} |
|
18
|
|
|
|
|
61
|
|
150
|
|
|
|
|
|
|
|
151
|
|
|
|
|
|
|
# warnings level |
152
|
|
|
|
|
|
|
sub set_warnings { |
153
|
1
|
|
|
1
|
0
|
6
|
my ($ezdate, $level) = @_; |
154
|
|
|
|
|
|
|
|
155
|
|
|
|
|
|
|
# TESTING |
156
|
|
|
|
|
|
|
# println subname(); ##i |
157
|
|
|
|
|
|
|
|
158
|
|
|
|
|
|
|
# level must be defined |
159
|
1
|
50
|
|
|
|
4
|
if (! defined $level) |
160
|
0
|
|
|
|
|
0
|
{ croak 'level-not-defined: warning level is not defined' } |
161
|
|
|
|
|
|
|
|
162
|
|
|
|
|
|
|
# normalize |
163
|
1
|
|
|
|
|
2
|
$level = lc($level); |
164
|
1
|
|
|
|
|
2
|
$level =~ s|\s||gs; |
165
|
|
|
|
|
|
|
|
166
|
|
|
|
|
|
|
# plain english |
167
|
1
|
50
|
|
|
|
5
|
if ($level eq 'none') |
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
168
|
0
|
|
|
|
|
0
|
{ $level = WARN_NONE } |
169
|
|
|
|
|
|
|
elsif ($level eq 'stderr') |
170
|
0
|
|
|
|
|
0
|
{ $level = WARN_STDERR } |
171
|
|
|
|
|
|
|
elsif ($level eq 'croak') |
172
|
1
|
|
|
|
|
3
|
{ $level = WARN_CROAK } |
173
|
|
|
|
|
|
|
elsif ($level eq 'default') |
174
|
0
|
|
|
|
|
0
|
{ $level = $default_warning } |
175
|
|
|
|
|
|
|
|
176
|
|
|
|
|
|
|
# set tied object |
177
|
1
|
|
|
|
|
3
|
return $ezdate->tie_ob->{'warnings'} = $level; |
178
|
|
|
|
|
|
|
} |
179
|
|
|
|
|
|
|
|
180
|
|
|
|
|
|
|
# |
181
|
|
|
|
|
|
|
# settings and utility subs |
182
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
183
|
|
|
|
|
|
|
|
184
|
|
|
|
|
|
|
|
185
|
|
|
|
|
|
|
############################################################################### |
186
|
|
|
|
|
|
|
# Date::EzDate2::Tie |
187
|
|
|
|
|
|
|
# |
188
|
|
|
|
|
|
|
package Date::EzDate2::Tie; |
189
|
1
|
|
|
1
|
|
435
|
use strict; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
22
|
|
190
|
1
|
|
|
1
|
|
857
|
use DateTime; |
|
1
|
|
|
|
|
82766
|
|
|
1
|
|
|
|
|
34
|
|
191
|
1
|
|
|
1
|
|
9
|
use DateTime::TimeZone; |
|
1
|
|
|
|
|
0
|
|
|
1
|
|
|
|
|
17
|
|
192
|
1
|
|
|
1
|
|
5
|
use Carp qw{carp croak}; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
86
|
|
193
|
1
|
|
|
1
|
|
453
|
use Clone; |
|
1
|
|
|
|
|
2212
|
|
|
1
|
|
|
|
|
45
|
|
194
|
1
|
|
|
1
|
|
4
|
use base 'Tie::StdHash'; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
529
|
|
195
|
|
|
|
|
|
|
|
196
|
|
|
|
|
|
|
# debugging tools |
197
|
|
|
|
|
|
|
# use Debug::ShowStuff ':all'; |
198
|
|
|
|
|
|
|
|
199
|
|
|
|
|
|
|
|
200
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
201
|
|
|
|
|
|
|
# globals |
202
|
|
|
|
|
|
|
# |
203
|
|
|
|
|
|
|
our ( |
204
|
|
|
|
|
|
|
@ltimefields, @OrdWords, $OrdWordsRx, %PCodes, %WeekDayNums, |
205
|
|
|
|
|
|
|
%OrdWordsNums, @OrdNums, %MonthNums, $pcode, |
206
|
|
|
|
|
|
|
); |
207
|
|
|
|
|
|
|
|
208
|
|
|
|
|
|
|
# localtime() fields |
209
|
|
|
|
|
|
|
# @ltimefields = qw[sec min hour dayofmonth monthnum year weekdaynum yearday dst]; |
210
|
|
|
|
|
|
|
@ltimefields = qw[sec min hour dayofmonth monthnum year]; |
211
|
|
|
|
|
|
|
|
212
|
|
|
|
|
|
|
# words for the days of the month |
213
|
|
|
|
|
|
|
@OrdWords = qw[ |
214
|
|
|
|
|
|
|
Zeroth First Second Third Fourth Fifth Sixth Seventh Eighth Ninth Tenth |
215
|
|
|
|
|
|
|
Eleventh Twelfth Thirteenth Fourteenth Fifteenth Sixteenth Seventeenth |
216
|
|
|
|
|
|
|
Eighteenth Ninteenth Twentieth Twentyfirst Twentysecond Twentythird |
217
|
|
|
|
|
|
|
Twentyfourth Twentyfifth Twentysixth Twentyseventh Twentyeighth Twentyninth |
218
|
|
|
|
|
|
|
Thirtieth Thirtyfirst |
219
|
|
|
|
|
|
|
]; |
220
|
|
|
|
|
|
|
|
221
|
|
|
|
|
|
|
# regular expression versions of OrdWords |
222
|
|
|
|
|
|
|
$OrdWordsRx = '\b(' . join('|', @OrdWords[1..$#OrdWords]) . ')\b'; |
223
|
|
|
|
|
|
|
|
224
|
|
|
|
|
|
|
# build hash or ord words |
225
|
|
|
|
|
|
|
foreach my $i (1..$#OrdWords) |
226
|
|
|
|
|
|
|
{ $OrdWordsNums{lc($OrdWords[$i])} = $i } |
227
|
|
|
|
|
|
|
|
228
|
|
|
|
|
|
|
# number ordinals |
229
|
|
|
|
|
|
|
@OrdNums = qw[ |
230
|
|
|
|
|
|
|
0th 1st 2nd 3rd 4th 5th 6th 7th 8th 9th 10th 11th 12th 13th 14th 15th 16th |
231
|
|
|
|
|
|
|
17th 18th 19th 20th 21st 22nd 23rd 24th 25th 26th 27th 28th 29th 30th 31st |
232
|
|
|
|
|
|
|
]; |
233
|
|
|
|
|
|
|
|
234
|
|
|
|
|
|
|
# month numbers |
235
|
|
|
|
|
|
|
@MonthNums{qw[jan feb mar apr may jun jul aug sep oct nov dec]} = (1..12); |
236
|
|
|
|
|
|
|
|
237
|
|
|
|
|
|
|
# weekday numbers |
238
|
|
|
|
|
|
|
$WeekDayNums{'mon'} = 1; |
239
|
|
|
|
|
|
|
$WeekDayNums{'tue'} = 2; |
240
|
|
|
|
|
|
|
$WeekDayNums{'wed'} = 3; |
241
|
|
|
|
|
|
|
$WeekDayNums{'thu'} = 4; |
242
|
|
|
|
|
|
|
$WeekDayNums{'fri'} = 5; |
243
|
|
|
|
|
|
|
$WeekDayNums{'sat'} = 6; |
244
|
|
|
|
|
|
|
$WeekDayNums{'sun'} = 7; |
245
|
|
|
|
|
|
|
|
246
|
|
|
|
|
|
|
# @WeekDayShort = qw[Sun Mon Tue Wed Thu Fri Sat]; |
247
|
|
|
|
|
|
|
# @WeekDayLong = qw[Sunday Monday Tuesday Wednesday Thursday Friday Saturday]; |
248
|
|
|
|
|
|
|
# @MonthShort = qw[Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec]; |
249
|
|
|
|
|
|
|
# @MonthLong = qw[January February March April May June July August September October November December]; |
250
|
|
|
|
|
|
|
# @MonthDays = qw[31 x 31 30 31 30 31 31 30 31 30 31]; |
251
|
|
|
|
|
|
|
|
252
|
|
|
|
|
|
|
# percent code regex |
253
|
|
|
|
|
|
|
$pcode = '^\%[\w\%]$'; |
254
|
|
|
|
|
|
|
|
255
|
|
|
|
|
|
|
# warn levels |
256
|
1
|
|
|
1
|
|
5
|
use constant WARN_NONE => Date::EzDate2::WARN_NONE; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
72
|
|
257
|
1
|
|
|
1
|
|
9
|
use constant WARN_STDERR => Date::EzDate2::WARN_STDERR; |
|
1
|
|
|
|
|
2
|
|
|
1
|
|
|
|
|
38
|
|
258
|
1
|
|
|
1
|
|
4
|
use constant WARN_CROAK => Date::EzDate2::WARN_CROAK; |
|
1
|
|
|
|
|
1
|
|
|
1
|
|
|
|
|
4984
|
|
259
|
|
|
|
|
|
|
|
260
|
|
|
|
|
|
|
%PCodes = qw[ |
261
|
|
|
|
|
|
|
yearlong year |
262
|
|
|
|
|
|
|
yearshort yeartwodigit |
263
|
|
|
|
|
|
|
dayofyear yearday |
264
|
|
|
|
|
|
|
dayofyear3d yearday3d |
265
|
|
|
|
|
|
|
dayofweeknum weekdaynum |
266
|
|
|
|
|
|
|
dayofweeknum2d weekdaynum2d |
267
|
|
|
|
|
|
|
%Y year |
268
|
|
|
|
|
|
|
%y yeartwodigit |
269
|
|
|
|
|
|
|
%a weekdayshort |
270
|
|
|
|
|
|
|
%A weekdaylong |
271
|
|
|
|
|
|
|
%d dayofmonth |
272
|
|
|
|
|
|
|
%D {monthnum2d}/{dayofmonth2d}/{year2d} |
273
|
|
|
|
|
|
|
%H hour2d |
274
|
|
|
|
|
|
|
%h monthshort |
275
|
|
|
|
|
|
|
%b ampmhournozero |
276
|
|
|
|
|
|
|
%B hournozero |
277
|
|
|
|
|
|
|
%e monthnum |
278
|
|
|
|
|
|
|
%m monthnum2d |
279
|
|
|
|
|
|
|
%j dayofyear3d |
280
|
|
|
|
|
|
|
%f dayofmonthnozero |
281
|
|
|
|
|
|
|
%k ampmhour |
282
|
|
|
|
|
|
|
%M min2d |
283
|
|
|
|
|
|
|
%P ampmuc |
284
|
|
|
|
|
|
|
%p ampmlc |
285
|
|
|
|
|
|
|
%s epochsec |
286
|
|
|
|
|
|
|
%S sec2d |
287
|
|
|
|
|
|
|
%w weekdaynum |
288
|
|
|
|
|
|
|
%y yeartwodigit |
289
|
|
|
|
|
|
|
%T %H:%M:%S |
290
|
|
|
|
|
|
|
%n newline |
291
|
|
|
|
|
|
|
%t tab |
292
|
|
|
|
|
|
|
%% percent |
293
|
|
|
|
|
|
|
]; |
294
|
|
|
|
|
|
|
|
295
|
|
|
|
|
|
|
$PCodes{'%c'} = '{weekdayshort} %h %d {hour2d}:{min2d}:{sec2d} %Y'; |
296
|
|
|
|
|
|
|
$PCodes{'%r'} = '%k:%M:%S %P'; |
297
|
|
|
|
|
|
|
|
298
|
|
|
|
|
|
|
# |
299
|
|
|
|
|
|
|
# globals |
300
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
301
|
|
|
|
|
|
|
|
302
|
|
|
|
|
|
|
|
303
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
304
|
|
|
|
|
|
|
# TIEHASH |
305
|
|
|
|
|
|
|
# |
306
|
|
|
|
|
|
|
sub TIEHASH { |
307
|
40
|
|
|
40
|
|
50
|
my ($class, $time, %opts) = @_; |
308
|
40
|
|
|
|
|
65
|
my $eztied = bless ({}, $class); |
309
|
|
|
|
|
|
|
|
310
|
|
|
|
|
|
|
# TESTING |
311
|
|
|
|
|
|
|
# println subname(); ##i |
312
|
|
|
|
|
|
|
|
313
|
|
|
|
|
|
|
# set some non-date properties |
314
|
|
|
|
|
|
|
# $eztied->{'zero_hour_ampm'} = defined($opts{'zero_hour_ampm'}) ? $opts{'zero_hour_ampm'} : 1; |
315
|
40
|
|
|
|
|
93
|
$eztied->{'formats'} = {}; |
316
|
40
|
|
|
|
|
84
|
$eztied->{'settings'} = {'dst_kludge' => 1}; |
317
|
|
|
|
|
|
|
|
318
|
|
|
|
|
|
|
# default builtin formats |
319
|
40
|
|
|
|
|
86
|
$eztied->set_format('fullday', '{month short} {day of month no zero}, {year}'); |
320
|
40
|
|
|
|
|
65
|
$eztied->set_format('fulldate', '{fullday}'); |
321
|
40
|
|
|
|
|
62
|
$eztied->set_format('dayandtime', '{month short} {day of month}, {year} {ampmhour no zero}:{minute}{ampm}'); |
322
|
40
|
|
|
|
|
67
|
$eztied->set_format('default', '{full}'); |
323
|
|
|
|
|
|
|
|
324
|
|
|
|
|
|
|
# if clone |
325
|
40
|
100
|
|
|
|
182
|
if (UNIVERSAL::isa $time, 'Date::EzDate2'){ |
326
|
16
|
|
|
|
|
33
|
$eztied->clone($time); |
327
|
|
|
|
|
|
|
} |
328
|
|
|
|
|
|
|
|
329
|
|
|
|
|
|
|
# else |
330
|
|
|
|
|
|
|
else { |
331
|
|
|
|
|
|
|
# set DateTime object to current time |
332
|
24
|
|
|
|
|
101
|
$eztied->{'dt'} = DateTime->now( |
333
|
|
|
|
|
|
|
time_zone => DateTime::TimeZone->new( name => 'local' )->name(), |
334
|
|
|
|
|
|
|
); |
335
|
|
|
|
|
|
|
|
336
|
|
|
|
|
|
|
# if time is a scalar and has content, call timefromstring() |
337
|
24
|
50
|
66
|
|
|
19140
|
if ( defined($time) && (! ref $time) && ($time =~ m|\S|s) ) { |
|
|
|
66
|
|
|
|
|
338
|
23
|
|
|
|
|
70
|
$eztied->timefromstring($time); |
339
|
|
|
|
|
|
|
} |
340
|
|
|
|
|
|
|
} |
341
|
|
|
|
|
|
|
|
342
|
|
|
|
|
|
|
# return |
343
|
40
|
|
|
|
|
140
|
return $eztied; |
344
|
|
|
|
|
|
|
} |
345
|
|
|
|
|
|
|
# |
346
|
|
|
|
|
|
|
# TIEHASH |
347
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
348
|
|
|
|
|
|
|
|
349
|
|
|
|
|
|
|
|
350
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
351
|
|
|
|
|
|
|
# clone |
352
|
|
|
|
|
|
|
# |
353
|
|
|
|
|
|
|
sub clone { |
354
|
16
|
|
|
16
|
|
22
|
my ($new, $old) = @_; |
355
|
|
|
|
|
|
|
|
356
|
|
|
|
|
|
|
# TESTING |
357
|
|
|
|
|
|
|
# println subname(), ' - ', __PACKAGE__; ##i |
358
|
|
|
|
|
|
|
|
359
|
|
|
|
|
|
|
# ensure we're using the tied hash |
360
|
16
|
50
|
|
|
|
48
|
if ( UNIVERSAL::isa $old, 'Date::EzDate2' ) |
361
|
16
|
|
|
|
|
44
|
{ $old = $old->tie_ob() } |
362
|
|
|
|
|
|
|
|
363
|
|
|
|
|
|
|
# formats and settings |
364
|
16
|
|
|
|
|
453
|
$new->{'formats'} = Clone::clone($old->{'formats'}); |
365
|
16
|
|
|
|
|
116
|
$new->{'settings'} = Clone::clone($old->{'settings'}); |
366
|
|
|
|
|
|
|
|
367
|
|
|
|
|
|
|
# datetime object |
368
|
16
|
|
|
|
|
63
|
$new->{'dt'} = $old->{'dt'}->clone(); |
369
|
|
|
|
|
|
|
|
370
|
|
|
|
|
|
|
# return |
371
|
16
|
|
|
|
|
153
|
return $new; |
372
|
|
|
|
|
|
|
} |
373
|
|
|
|
|
|
|
# |
374
|
|
|
|
|
|
|
# clone |
375
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
376
|
|
|
|
|
|
|
|
377
|
|
|
|
|
|
|
|
378
|
|
|
|
|
|
|
|
379
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
380
|
|
|
|
|
|
|
# STORE |
381
|
|
|
|
|
|
|
# |
382
|
|
|
|
|
|
|
our $left_brace_rx = quotemeta('{'); |
383
|
|
|
|
|
|
|
|
384
|
|
|
|
|
|
|
sub STORE { |
385
|
98
|
|
|
98
|
|
658
|
my ($eztied, $key, $val) = @_; |
386
|
98
|
|
|
|
|
93
|
my (%set, $orgkey, $orgval, $dt); |
387
|
|
|
|
|
|
|
|
388
|
|
|
|
|
|
|
# TESTING |
389
|
|
|
|
|
|
|
# println subname(); ##i |
390
|
|
|
|
|
|
|
|
391
|
|
|
|
|
|
|
# hold on to original values |
392
|
98
|
|
|
|
|
104
|
$orgkey = $key; |
393
|
98
|
|
|
|
|
84
|
$orgval = $val; |
394
|
|
|
|
|
|
|
|
395
|
|
|
|
|
|
|
# error checking |
396
|
98
|
50
|
|
|
|
200
|
if (! defined $val) { |
397
|
0
|
|
|
|
|
0
|
return $eztied->warn( |
398
|
|
|
|
|
|
|
'value-not-defined-in-store: ' . |
399
|
|
|
|
|
|
|
'Must send a defined value when setting a ' . |
400
|
|
|
|
|
|
|
'property of an EzDate object' |
401
|
|
|
|
|
|
|
); |
402
|
|
|
|
|
|
|
} |
403
|
|
|
|
|
|
|
|
404
|
|
|
|
|
|
|
# if value contains {, assume they're assigning a format |
405
|
98
|
50
|
|
|
|
322
|
$val =~ m|$left_brace_rx| and return $eztied->set_format($key, $val); |
406
|
|
|
|
|
|
|
|
407
|
|
|
|
|
|
|
# normalize key |
408
|
98
|
|
|
|
|
149
|
normalize_key($key); |
409
|
98
|
|
|
|
|
164
|
$key = $eztied->get_alias($key, 'strip_no_zero'=>1); |
410
|
|
|
|
|
|
|
|
411
|
|
|
|
|
|
|
# TESTING |
412
|
|
|
|
|
|
|
# showvar $key; |
413
|
|
|
|
|
|
|
|
414
|
|
|
|
|
|
|
# normalize value |
415
|
98
|
|
|
|
|
107
|
$val = lc($val); |
416
|
98
|
|
|
|
|
173
|
$val =~ s|^\s+||gs; |
417
|
98
|
|
|
|
|
113
|
$val =~ s|\s+$||gs; |
418
|
98
|
|
|
|
|
98
|
$val =~ s|\s+| |gs; |
419
|
|
|
|
|
|
|
|
420
|
|
|
|
|
|
|
# TESTING |
421
|
|
|
|
|
|
|
# println $key, ': ', $val; |
422
|
|
|
|
|
|
|
|
423
|
|
|
|
|
|
|
# get DateTime object |
424
|
98
|
|
|
|
|
103
|
$dt = $eztied->{'dt'}; |
425
|
|
|
|
|
|
|
|
426
|
|
|
|
|
|
|
# day of month |
427
|
98
|
100
|
100
|
|
|
1131
|
if ($key eq 'dayofmonth') { |
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
66
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
100
|
100
|
|
|
|
|
|
|
50
|
100
|
|
|
|
|
428
|
17
|
|
|
|
|
29
|
$set{'day'} = $val; |
429
|
|
|
|
|
|
|
} |
430
|
|
|
|
|
|
|
|
431
|
|
|
|
|
|
|
# year |
432
|
|
|
|
|
|
|
elsif ($key eq 'year') { |
433
|
17
|
|
|
|
|
30
|
$set{'year'} = $val; |
434
|
|
|
|
|
|
|
} |
435
|
|
|
|
|
|
|
|
436
|
|
|
|
|
|
|
# month |
437
|
|
|
|
|
|
|
elsif ( ($key eq 'month') || ($key eq 'monthnum') || ($key eq 'monthlong') || ($key eq 'monthshort') ) { |
438
|
|
|
|
|
|
|
# letters |
439
|
21
|
100
|
|
|
|
58
|
unless ( $val =~ m|^\d+$|si ) { |
440
|
|
|
|
|
|
|
# get just first three letters |
441
|
18
|
|
|
|
|
23
|
$val =~ s|\s||gs; |
442
|
18
|
|
|
|
|
31
|
$val = substr($val, 0, 3); |
443
|
|
|
|
|
|
|
|
444
|
|
|
|
|
|
|
# if a month number exists, use it, else throw error |
445
|
|
|
|
|
|
|
# KLUDGE: assuming English names for now, will work with |
446
|
|
|
|
|
|
|
# DateTime's locale functions later. |
447
|
18
|
50
|
|
|
|
46
|
if (my $num = $MonthNums{$val}) { |
448
|
18
|
|
|
|
|
22
|
$val = $num; |
449
|
|
|
|
|
|
|
} |
450
|
|
|
|
|
|
|
else { |
451
|
0
|
|
|
|
|
0
|
return $eztied->warn( |
452
|
|
|
|
|
|
|
"invalid-month-name: do not know this month name: $orgval" |
453
|
|
|
|
|
|
|
) |
454
|
|
|
|
|
|
|
} |
455
|
|
|
|
|
|
|
} |
456
|
|
|
|
|
|
|
|
457
|
|
|
|
|
|
|
# set month |
458
|
21
|
|
|
|
|
46
|
$set{'month'} = $val; |
459
|
|
|
|
|
|
|
} |
460
|
|
|
|
|
|
|
|
461
|
|
|
|
|
|
|
# weekday |
462
|
|
|
|
|
|
|
elsif ( ($key eq 'weekday') || ($key eq 'weekdaynum') || ($key eq 'weekdayshort') || ($key eq 'weekdaylong') ) { |
463
|
|
|
|
|
|
|
# if not integer, get integer value |
464
|
6
|
100
|
|
|
|
17
|
unless ($val =~ m|^\d+$|s) { |
465
|
|
|
|
|
|
|
# get just first three letters |
466
|
5
|
|
|
|
|
10
|
$val = lc($val); |
467
|
5
|
|
|
|
|
8
|
$val =~ s|\s||gs; |
468
|
5
|
|
|
|
|
11
|
$val = substr($val, 0, 3); |
469
|
|
|
|
|
|
|
|
470
|
|
|
|
|
|
|
# attempt to get value |
471
|
5
|
50
|
|
|
|
17
|
unless ($val = $WeekDayNums{$val}) { |
472
|
0
|
|
|
|
|
0
|
return $eztied->warn( |
473
|
|
|
|
|
|
|
"invalid-weekday-name: do not know this weekday name: $orgval" |
474
|
|
|
|
|
|
|
) |
475
|
|
|
|
|
|
|
} |
476
|
|
|
|
|
|
|
} |
477
|
|
|
|
|
|
|
|
478
|
|
|
|
|
|
|
# set day |
479
|
6
|
100
|
|
|
|
17
|
unless ( $val == $dt->day_of_week ) { |
480
|
5
|
|
|
|
|
26
|
$set{'day'} = $dt->day + $val - $dt->day_of_week; |
481
|
|
|
|
|
|
|
} |
482
|
|
|
|
|
|
|
} |
483
|
|
|
|
|
|
|
|
484
|
|
|
|
|
|
|
# yearday |
485
|
|
|
|
|
|
|
elsif ( ($key eq 'yearday') || ($key eq 'yearday3d') ) { |
486
|
3
|
|
|
|
|
3
|
my ($current); |
487
|
|
|
|
|
|
|
|
488
|
|
|
|
|
|
|
# check for integer and range |
489
|
3
|
50
|
|
|
|
11
|
$eztied->integer_check($key, $val) |
490
|
|
|
|
|
|
|
or return 0; |
491
|
|
|
|
|
|
|
|
492
|
|
|
|
|
|
|
# get current value |
493
|
3
|
|
|
|
|
9
|
$current = $dt->day_of_year(); |
494
|
|
|
|
|
|
|
|
495
|
|
|
|
|
|
|
# if they're not equal, set to new day of year |
496
|
3
|
50
|
|
|
|
16
|
unless ($current == $val) { |
497
|
|
|
|
|
|
|
# add days |
498
|
3
|
|
|
|
|
11
|
$dt->add( |
499
|
|
|
|
|
|
|
days => $val - $current, |
500
|
|
|
|
|
|
|
); |
501
|
|
|
|
|
|
|
|
502
|
|
|
|
|
|
|
# return |
503
|
3
|
|
|
|
|
1217
|
return 1; |
504
|
|
|
|
|
|
|
} |
505
|
|
|
|
|
|
|
} |
506
|
|
|
|
|
|
|
|
507
|
|
|
|
|
|
|
# hour |
508
|
|
|
|
|
|
|
elsif ( ($key eq 'hour') || ($key eq 'hour2d') ) { |
509
|
|
|
|
|
|
|
# check for integer and range |
510
|
3
|
50
|
|
|
|
7
|
$eztied->integer_check($key, $val) |
511
|
|
|
|
|
|
|
or return 0; |
512
|
|
|
|
|
|
|
|
513
|
|
|
|
|
|
|
# assign value |
514
|
3
|
|
|
|
|
10
|
$set{'hour'} = $val; |
515
|
|
|
|
|
|
|
} |
516
|
|
|
|
|
|
|
|
517
|
|
|
|
|
|
|
# minute |
518
|
|
|
|
|
|
|
elsif ( ($key eq 'min') || ($key eq 'min2d') ) { |
519
|
|
|
|
|
|
|
# check for integer |
520
|
3
|
50
|
|
|
|
5
|
$eztied->integer_check($key, $val) |
521
|
|
|
|
|
|
|
or return 0; |
522
|
|
|
|
|
|
|
|
523
|
|
|
|
|
|
|
# assign value |
524
|
3
|
|
|
|
|
6
|
$set{'minute'} = $val; |
525
|
|
|
|
|
|
|
} |
526
|
|
|
|
|
|
|
|
527
|
|
|
|
|
|
|
# second |
528
|
|
|
|
|
|
|
elsif ( ($key eq 'sec') || ($key eq 'sec2d') ) { |
529
|
|
|
|
|
|
|
# check for integer and range |
530
|
3
|
50
|
|
|
|
6
|
$eztied->integer_check($key, $val) |
531
|
|
|
|
|
|
|
or return 0; |
532
|
|
|
|
|
|
|
|
533
|
|
|
|
|
|
|
# assign value |
534
|
3
|
|
|
|
|
6
|
$set{'second'} = $val; |
535
|
|
|
|
|
|
|
} |
536
|
|
|
|
|
|
|
|
537
|
|
|
|
|
|
|
# ampm |
538
|
|
|
|
|
|
|
elsif ( ($key eq 'ampm') || ($key eq 'ampmlc') || ($key eq 'ampmuc') ) { |
539
|
20
|
|
|
|
|
18
|
my ($current); |
540
|
|
|
|
|
|
|
|
541
|
|
|
|
|
|
|
# add 'm' to just or or p |
542
|
20
|
100
|
|
|
|
48
|
if (length($val) == 1) |
543
|
1
|
|
|
|
|
3
|
{$val .= 'm'} |
544
|
|
|
|
|
|
|
|
545
|
|
|
|
|
|
|
# normalize |
546
|
20
|
|
|
|
|
28
|
$val =~ s|\s||gs; |
547
|
|
|
|
|
|
|
|
548
|
|
|
|
|
|
|
# error checking |
549
|
20
|
50
|
66
|
|
|
67
|
unless ( ($val eq 'am') || ($val eq 'pm') ) |
550
|
0
|
|
|
|
|
0
|
{ return $eztied->warn('invalid-ampm: ampm may only be set to am or pm') } |
551
|
|
|
|
|
|
|
|
552
|
|
|
|
|
|
|
# get dt object |
553
|
20
|
|
|
|
|
51
|
$current = $dt->hour; |
554
|
|
|
|
|
|
|
|
555
|
|
|
|
|
|
|
# if no change, we're done |
556
|
20
|
100
|
|
|
|
90
|
if ($current < 12) { |
557
|
16
|
100
|
|
|
|
37
|
if ($val eq 'am') |
558
|
1
|
|
|
|
|
2
|
{ return 1} |
559
|
|
|
|
|
|
|
} |
560
|
|
|
|
|
|
|
else { |
561
|
4
|
50
|
|
|
|
12
|
if ($val eq 'pm') |
562
|
0
|
|
|
|
|
0
|
{ return 1} |
563
|
|
|
|
|
|
|
} |
564
|
|
|
|
|
|
|
|
565
|
|
|
|
|
|
|
# set change |
566
|
19
|
100
|
|
|
|
29
|
if ($val eq 'am') |
567
|
4
|
|
|
|
|
10
|
{ $set{'hour'} = $current - 12 } |
568
|
|
|
|
|
|
|
else |
569
|
15
|
|
|
|
|
31
|
{ $set{'hour'} = $current + 12 } |
570
|
|
|
|
|
|
|
} |
571
|
|
|
|
|
|
|
|
572
|
|
|
|
|
|
|
# ampmhour |
573
|
|
|
|
|
|
|
elsif ($key eq 'ampmhour') { |
574
|
|
|
|
|
|
|
# check for integer |
575
|
2
|
50
|
|
|
|
6
|
$eztied->integer_check($key, $val) |
576
|
|
|
|
|
|
|
or return 0; |
577
|
|
|
|
|
|
|
|
578
|
|
|
|
|
|
|
# add twelve if necessary |
579
|
2
|
50
|
|
|
|
5
|
if ($dt->hour >= 12) |
580
|
2
|
|
|
|
|
21
|
{ $val += 12 } |
581
|
|
|
|
|
|
|
|
582
|
|
|
|
|
|
|
# set |
583
|
2
|
|
|
|
|
4
|
$set{'hour'} = $val; |
584
|
|
|
|
|
|
|
} |
585
|
|
|
|
|
|
|
|
586
|
|
|
|
|
|
|
# miltime |
587
|
|
|
|
|
|
|
elsif ($key eq 'miltime') { |
588
|
|
|
|
|
|
|
# must ve exactly four digits |
589
|
2
|
50
|
|
|
|
8
|
unless ($val =~ m|^\d{4}$|s) |
590
|
0
|
|
|
|
|
0
|
{ return $eztied->warn('invalid-miltime: miltime must consist of exactly four digits') } |
591
|
|
|
|
|
|
|
|
592
|
|
|
|
|
|
|
# set |
593
|
2
|
|
|
|
|
6
|
$set{'hour'} = substr($val, 0, 2); |
594
|
2
|
|
|
|
|
4
|
$set{'minute'} = substr($val, 2, 2); |
595
|
|
|
|
|
|
|
} |
596
|
|
|
|
|
|
|
|
597
|
|
|
|
|
|
|
# dmy |
598
|
|
|
|
|
|
|
elsif ($key eq 'dmy') { |
599
|
1
|
|
|
|
|
2
|
my (@tokens, $day, $month, $year); |
600
|
|
|
|
|
|
|
|
601
|
|
|
|
|
|
|
# split |
602
|
1
|
|
|
|
|
1
|
$val = lc($val); |
603
|
1
|
|
|
|
|
7
|
@tokens = split(m/(\d+)|([a-z]+)/si, $val); |
604
|
1
|
|
|
|
|
3
|
@tokens = grep {defined $_} @tokens; |
|
8
|
|
|
|
|
11
|
|
605
|
1
|
|
|
|
|
2
|
@tokens = grep {m|\S|s} @tokens; |
|
6
|
|
|
|
|
8
|
|
606
|
|
|
|
|
|
|
|
607
|
|
|
|
|
|
|
# get values |
608
|
1
|
|
|
|
|
3
|
($day, $month, $year) = @tokens; |
609
|
|
|
|
|
|
|
|
610
|
|
|
|
|
|
|
# check day |
611
|
1
|
50
|
|
|
|
4
|
$eztied->integer_check("$key - day", $day) |
612
|
|
|
|
|
|
|
or return 0; |
613
|
|
|
|
|
|
|
|
614
|
|
|
|
|
|
|
# normalize month |
615
|
1
|
|
|
|
|
3
|
$month = substr($month, 0, 3); |
616
|
|
|
|
|
|
|
|
617
|
|
|
|
|
|
|
# if a month number exists, use it, else throw error |
618
|
|
|
|
|
|
|
# KLUDGE: assuming English names for now, will work with |
619
|
|
|
|
|
|
|
# DateTime's locale functions later. |
620
|
1
|
50
|
|
|
|
4
|
if (my $num = $MonthNums{$month}) { |
621
|
1
|
|
|
|
|
2
|
$month = $num; |
622
|
|
|
|
|
|
|
} |
623
|
|
|
|
|
|
|
else { |
624
|
0
|
|
|
|
|
0
|
return $eztied->warn( |
625
|
|
|
|
|
|
|
"invalid-month-name: do not know this month name: $orgval" |
626
|
|
|
|
|
|
|
) |
627
|
|
|
|
|
|
|
} |
628
|
|
|
|
|
|
|
|
629
|
|
|
|
|
|
|
# check year |
630
|
1
|
50
|
|
|
|
3
|
$eztied->integer_check("$key - year", $year) |
631
|
|
|
|
|
|
|
or return 0; |
632
|
|
|
|
|
|
|
|
633
|
|
|
|
|
|
|
# set |
634
|
1
|
|
|
|
|
2
|
$set{'day'} = $day; |
635
|
1
|
|
|
|
|
2
|
$set{'month'} = $month; |
636
|
1
|
|
|
|
|
2
|
$set{'year'} = $year; |
637
|
|
|
|
|
|
|
} |
638
|
|
|
|
|
|
|
|
639
|
|
|
|
|
|
|
# elsif ($key eq 'minofday') { |
640
|
|
|
|
|
|
|
# $eztied->setfromtime ( |
641
|
|
|
|
|
|
|
# DST_ADJUST_NO, |
642
|
|
|
|
|
|
|
# $eztied->{'epochsec'} - ($eztied->{'hour'} * t_60_60) - ($eztied->{'min'} * 60) + ($val * 60) |
643
|
|
|
|
|
|
|
# ) |
644
|
|
|
|
|
|
|
# } |
645
|
|
|
|
|
|
|
# |
646
|
|
|
|
|
|
|
# elsif ($key eq 'hour') { |
647
|
|
|
|
|
|
|
# $val = timelocal( |
648
|
|
|
|
|
|
|
# $eztied->{'sec'}, |
649
|
|
|
|
|
|
|
# $eztied->{'min'}, |
650
|
|
|
|
|
|
|
# $val, |
651
|
|
|
|
|
|
|
# $eztied->{'dayofmonth'}, |
652
|
|
|
|
|
|
|
# $eztied->{'monthnum'}, |
653
|
|
|
|
|
|
|
# $eztied->{'year'}, |
654
|
|
|
|
|
|
|
# ); |
655
|
|
|
|
|
|
|
# |
656
|
|
|
|
|
|
|
# $eztied->setfromtime(DST_ADJUST_NO, $val); |
657
|
|
|
|
|
|
|
# } |
658
|
|
|
|
|
|
|
# |
659
|
|
|
|
|
|
|
# # hour and minute |
660
|
|
|
|
|
|
|
# elsif ( ($key eq 'clocktime') || ($key =~ m|^mil(itary)?time$|) ) { |
661
|
|
|
|
|
|
|
# my ($changed, $hour, $min, $sec) = $eztied->gettime($val); |
662
|
|
|
|
|
|
|
# |
663
|
|
|
|
|
|
|
# unless (defined $hour) |
664
|
|
|
|
|
|
|
# {$hour = $eztied->{'hour'}} |
665
|
|
|
|
|
|
|
# unless (defined $min) |
666
|
|
|
|
|
|
|
# {$min = $eztied->{'min'}} |
667
|
|
|
|
|
|
|
# unless (defined $sec) |
668
|
|
|
|
|
|
|
# {$sec = $eztied->{'sec'}} |
669
|
|
|
|
|
|
|
# |
670
|
|
|
|
|
|
|
# $eztied->setfromtime |
671
|
|
|
|
|
|
|
# ( |
672
|
|
|
|
|
|
|
# 0, |
673
|
|
|
|
|
|
|
# $eztied->{'epochsec'} |
674
|
|
|
|
|
|
|
# |
675
|
|
|
|
|
|
|
# - ($eztied->{'sec'}) |
676
|
|
|
|
|
|
|
# - ($eztied->{'min'} * 60) |
677
|
|
|
|
|
|
|
# - ($eztied->{'hour'} * t_60_60) |
678
|
|
|
|
|
|
|
# |
679
|
|
|
|
|
|
|
# + ($sec) |
680
|
|
|
|
|
|
|
# + ($min * 60) |
681
|
|
|
|
|
|
|
# + ($hour * t_60_60) |
682
|
|
|
|
|
|
|
# ); |
683
|
|
|
|
|
|
|
# } |
684
|
|
|
|
|
|
|
# |
685
|
|
|
|
|
|
|
# elsif ($key eq 'dst') |
686
|
|
|
|
|
|
|
# {return $eztied->warn('dst property is read-only')} |
687
|
|
|
|
|
|
|
# |
688
|
|
|
|
|
|
|
# elsif ($key eq 'epochsec') |
689
|
|
|
|
|
|
|
# {$eztied->setfromtime(DST_ADJUST_NO, $val)} |
690
|
|
|
|
|
|
|
# |
691
|
|
|
|
|
|
|
# elsif ($key eq 'epochmin') |
692
|
|
|
|
|
|
|
# {$eztied->setfromtime(DST_ADJUST_NO, $eztied->{'epochsec'} - ($eztied->getepochmin * 60) + ($val * 60) )} |
693
|
|
|
|
|
|
|
# |
694
|
|
|
|
|
|
|
# elsif ($key eq 'epochhour') |
695
|
|
|
|
|
|
|
# {$eztied->setfromtime(DST_ADJUST_NO, $eztied->{'epochsec'} - ($eztied->getepochhour * t_60_60) + ($val * t_60_60) )} |
696
|
|
|
|
|
|
|
# |
697
|
|
|
|
|
|
|
# elsif ($key eq 'epochday') { |
698
|
|
|
|
|
|
|
# my ($oldhour, $oldepochsec, $oldmin); |
699
|
|
|
|
|
|
|
# |
700
|
|
|
|
|
|
|
# $eztied->setfromtime( |
701
|
|
|
|
|
|
|
# DST_ADJUST_YES, |
702
|
|
|
|
|
|
|
# $eztied->{'epochsec'} - ($eztied->getepochday * t_60_60_24) + (int($val) * t_60_60_24) |
703
|
|
|
|
|
|
|
# ); |
704
|
|
|
|
|
|
|
# } |
705
|
|
|
|
|
|
|
# |
706
|
|
|
|
|
|
|
# # ordinals |
707
|
|
|
|
|
|
|
# elsif ($key =~ m/dayofmonthord(word|num)?/) { |
708
|
|
|
|
|
|
|
# # if numeric |
709
|
|
|
|
|
|
|
# if ($val =~ s|^(\d+)\s*\w*$|$1|s) |
710
|
|
|
|
|
|
|
# {$eztied->STORE('dayofmonth', $val)} |
711
|
|
|
|
|
|
|
# |
712
|
|
|
|
|
|
|
# # else word |
713
|
|
|
|
|
|
|
# else { |
714
|
|
|
|
|
|
|
# my $nval = $val; |
715
|
|
|
|
|
|
|
# $nval =~ tr/A-Z/a-z/; |
716
|
|
|
|
|
|
|
# $nval =~ s|\W||gs; |
717
|
|
|
|
|
|
|
# |
718
|
|
|
|
|
|
|
# # if no such ordinal exists |
719
|
|
|
|
|
|
|
# unless ($nval = $OrdWordsNums{$nval}) |
720
|
|
|
|
|
|
|
# { return $eztied->warn("Invalid ordinal: $val") } |
721
|
|
|
|
|
|
|
# |
722
|
|
|
|
|
|
|
# $eztied->STORE('dayofmonth', $nval); |
723
|
|
|
|
|
|
|
# } |
724
|
|
|
|
|
|
|
# } |
725
|
|
|
|
|
|
|
# |
726
|
|
|
|
|
|
|
# elsif ($key eq 'year') { |
727
|
|
|
|
|
|
|
# my ($maxday, $targetday); |
728
|
|
|
|
|
|
|
# |
729
|
|
|
|
|
|
|
# # if same year, nothing to do |
730
|
|
|
|
|
|
|
# if ($eztied->{'year'} == $val) |
731
|
|
|
|
|
|
|
# {return} |
732
|
|
|
|
|
|
|
# |
733
|
|
|
|
|
|
|
# # make sure day of month isn't greater than maximum day of target month |
734
|
|
|
|
|
|
|
# $maxday = daysinmonth($eztied->{'monthnum'}, $val); |
735
|
|
|
|
|
|
|
# |
736
|
|
|
|
|
|
|
# if ($eztied->{'dayofmonth'} > $maxday) { |
737
|
|
|
|
|
|
|
# $eztied->warn( |
738
|
|
|
|
|
|
|
# "Changing the year sets day of month ($eztied->{'dayofmonth'}) to higher than days in month ($maxday); ", |
739
|
|
|
|
|
|
|
# "setting the day down to $maxday" |
740
|
|
|
|
|
|
|
# ); |
741
|
|
|
|
|
|
|
# $targetday = $maxday; |
742
|
|
|
|
|
|
|
# } |
743
|
|
|
|
|
|
|
# else |
744
|
|
|
|
|
|
|
# {$targetday = $eztied->{'dayofmonth'}} |
745
|
|
|
|
|
|
|
# |
746
|
|
|
|
|
|
|
# $val = timelocal($eztied->{'sec'}, $eztied->{'min'}, $eztied->{'hour'}, $targetday, $eztied->{'monthnum'}, $val); |
747
|
|
|
|
|
|
|
# $eztied->setfromtime(DST_ADJUST_YES, $val); |
748
|
|
|
|
|
|
|
# } |
749
|
|
|
|
|
|
|
# |
750
|
|
|
|
|
|
|
# elsif ($key =~ m/^year(two|2)digit/) { |
751
|
|
|
|
|
|
|
# $val =~ s|^.*(..)$|$1|; |
752
|
|
|
|
|
|
|
# $eztied->STORE('year', substr($eztied->{'year'}, 0, 2) . zeropad_2($val)); |
753
|
|
|
|
|
|
|
# } |
754
|
|
|
|
|
|
|
# |
755
|
|
|
|
|
|
|
# elsif ($key =~ m/^monthnumbase(one|1)/) |
756
|
|
|
|
|
|
|
# {$eztied->STORE('monthnum', $val - 1)} |
757
|
|
|
|
|
|
|
# |
758
|
|
|
|
|
|
|
# |
759
|
|
|
|
|
|
|
# #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
760
|
|
|
|
|
|
|
# # monthnum |
761
|
|
|
|
|
|
|
# # |
762
|
|
|
|
|
|
|
# elsif ($key eq 'monthnum') { |
763
|
|
|
|
|
|
|
# my ($target, $epoch_second); |
764
|
|
|
|
|
|
|
# my $month = $eztied->{'monthnum'}; |
765
|
|
|
|
|
|
|
# my $year = $eztied->{'year'}; |
766
|
|
|
|
|
|
|
# my $orgday = $eztied->{'dayofmonth'}; |
767
|
|
|
|
|
|
|
# my $dayofmonth = $eztied->{'dayofmonth'}; |
768
|
|
|
|
|
|
|
# my $jumps = $val - $month; |
769
|
|
|
|
|
|
|
# |
770
|
|
|
|
|
|
|
# # if nothing to do |
771
|
|
|
|
|
|
|
# $jumps or return; |
772
|
|
|
|
|
|
|
# |
773
|
|
|
|
|
|
|
# $target = $jumps; |
774
|
|
|
|
|
|
|
# $target = abs($target); |
775
|
|
|
|
|
|
|
# |
776
|
|
|
|
|
|
|
# # jumping forward |
777
|
|
|
|
|
|
|
# if ($jumps > 0) { |
778
|
|
|
|
|
|
|
# foreach (1..$target) { |
779
|
|
|
|
|
|
|
# # if end of year |
780
|
|
|
|
|
|
|
# if ($month == 11) { |
781
|
|
|
|
|
|
|
# $month = 0; |
782
|
|
|
|
|
|
|
# $year++; |
783
|
|
|
|
|
|
|
# } |
784
|
|
|
|
|
|
|
# else |
785
|
|
|
|
|
|
|
# {$month++} |
786
|
|
|
|
|
|
|
# } |
787
|
|
|
|
|
|
|
# } |
788
|
|
|
|
|
|
|
# |
789
|
|
|
|
|
|
|
# # jumping backward |
790
|
|
|
|
|
|
|
# else { |
791
|
|
|
|
|
|
|
# foreach (1..$target) { |
792
|
|
|
|
|
|
|
# # if beginning of year |
793
|
|
|
|
|
|
|
# if ($month == 0) { |
794
|
|
|
|
|
|
|
# $month = 11; |
795
|
|
|
|
|
|
|
# $year--; |
796
|
|
|
|
|
|
|
# } |
797
|
|
|
|
|
|
|
# else |
798
|
|
|
|
|
|
|
# {$month--} |
799
|
|
|
|
|
|
|
# } |
800
|
|
|
|
|
|
|
# } |
801
|
|
|
|
|
|
|
# |
802
|
|
|
|
|
|
|
# |
803
|
|
|
|
|
|
|
# # adjust day for shorter month (if necessary) |
804
|
|
|
|
|
|
|
# if ($dayofmonth > 28) { |
805
|
|
|
|
|
|
|
# my $dim = daysinmonth($month, $year); |
806
|
|
|
|
|
|
|
# |
807
|
|
|
|
|
|
|
# if ($dim < $dayofmonth) |
808
|
|
|
|
|
|
|
# { $dayofmonth = $dim } |
809
|
|
|
|
|
|
|
# } |
810
|
|
|
|
|
|
|
# |
811
|
|
|
|
|
|
|
# # get epoch second from timelocal |
812
|
|
|
|
|
|
|
# $epoch_second = timelocal($eztied->{'sec'}, $eztied->{'min'}, $eztied->{'hour'}, $dayofmonth, $month, $year); |
813
|
|
|
|
|
|
|
# $eztied->setfromtime(DST_ADJUST_NO, $epoch_second); |
814
|
|
|
|
|
|
|
# } |
815
|
|
|
|
|
|
|
# # |
816
|
|
|
|
|
|
|
# # monthnum |
817
|
|
|
|
|
|
|
# #- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
818
|
|
|
|
|
|
|
# |
819
|
|
|
|
|
|
|
# |
820
|
|
|
|
|
|
|
# elsif ( ($key eq 'monthshort') || ($key eq 'monthlong') ) |
821
|
|
|
|
|
|
|
# {$eztied->STORE('monthnum', $MonthNums{lc(substr($val, 0, 3))})} |
822
|
|
|
|
|
|
|
# |
823
|
|
|
|
|
|
|
# elsif ( |
824
|
|
|
|
|
|
|
# ($key eq 'weekdayshort') || |
825
|
|
|
|
|
|
|
# ($key eq 'weekdaylong') || |
826
|
|
|
|
|
|
|
# ($key eq 'dayofweekshort') || |
827
|
|
|
|
|
|
|
# ($key eq 'dayofweeklong') |
828
|
|
|
|
|
|
|
# ) { |
829
|
|
|
|
|
|
|
# $eztied->STORE( |
830
|
|
|
|
|
|
|
# 'weekdaynum', |
831
|
|
|
|
|
|
|
# $WeekDayNums{lc(substr($val, 0, 3))}) |
832
|
|
|
|
|
|
|
# } |
833
|
|
|
|
|
|
|
# |
834
|
|
|
|
|
|
|
# else |
835
|
|
|
|
|
|
|
# { return $eztied->warn("Do not understand key: $orgkey") } |
836
|
|
|
|
|
|
|
|
837
|
|
|
|
|
|
|
# else don't know key |
838
|
|
|
|
|
|
|
else { |
839
|
|
|
|
|
|
|
# TESTING |
840
|
|
|
|
|
|
|
# die "unknown-name-for-store: do not know this property name: $orgkey"; |
841
|
|
|
|
|
|
|
|
842
|
|
|
|
|
|
|
# return with warning |
843
|
0
|
|
|
|
|
0
|
return $eztied->warn( |
844
|
|
|
|
|
|
|
"unknown-name-for-store: do not know this property name: $orgkey" |
845
|
|
|
|
|
|
|
) |
846
|
|
|
|
|
|
|
} |
847
|
|
|
|
|
|
|
|
848
|
|
|
|
|
|
|
# set new date and time |
849
|
94
|
|
|
|
|
186
|
$eztied->new_date_time(\%set); |
850
|
|
|
|
|
|
|
|
851
|
|
|
|
|
|
|
# return value |
852
|
94
|
|
|
|
|
399
|
return $val; |
853
|
|
|
|
|
|
|
} |
854
|
|
|
|
|
|
|
# |
855
|
|
|
|
|
|
|
# STORE |
856
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
857
|
|
|
|
|
|
|
|
858
|
|
|
|
|
|
|
|
859
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
860
|
|
|
|
|
|
|
# integer_check |
861
|
|
|
|
|
|
|
# |
862
|
|
|
|
|
|
|
sub integer_check { |
863
|
16
|
|
|
16
|
|
22
|
my ($eztied, $key, $val) = @_; |
864
|
|
|
|
|
|
|
|
865
|
|
|
|
|
|
|
# TESTING |
866
|
|
|
|
|
|
|
# println subname(); ##i |
867
|
|
|
|
|
|
|
|
868
|
|
|
|
|
|
|
# must be all digit and greater than zero |
869
|
16
|
50
|
33
|
|
|
122
|
unless ( defined($val) && ($val =~ m|^\d+$|s) && ($val > 0) ) { |
|
|
|
33
|
|
|
|
|
870
|
|
|
|
|
|
|
# warn |
871
|
0
|
0
|
|
|
|
0
|
$eztied->warn( |
872
|
|
|
|
|
|
|
"not-integer-for-$key: " . |
873
|
|
|
|
|
|
|
"the value for $key must be a positive integer but is " . |
874
|
|
|
|
|
|
|
(defined($val) ? "\"$val\"" : 'undef') . ' ' . |
875
|
|
|
|
|
|
|
"instead" |
876
|
|
|
|
|
|
|
); |
877
|
|
|
|
|
|
|
|
878
|
|
|
|
|
|
|
# return false |
879
|
0
|
|
|
|
|
0
|
return 0; |
880
|
|
|
|
|
|
|
} |
881
|
|
|
|
|
|
|
|
882
|
|
|
|
|
|
|
# return true |
883
|
16
|
|
|
|
|
48
|
return 1; |
884
|
|
|
|
|
|
|
} |
885
|
|
|
|
|
|
|
# |
886
|
|
|
|
|
|
|
# integer_check |
887
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
888
|
|
|
|
|
|
|
|
889
|
|
|
|
|
|
|
|
890
|
|
|
|
|
|
|
|
891
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
892
|
|
|
|
|
|
|
# timefromstring |
893
|
|
|
|
|
|
|
# |
894
|
|
|
|
|
|
|
|
895
|
|
|
|
|
|
|
# today, now, yesterday, tomorrow |
896
|
|
|
|
|
|
|
our %relative = ( |
897
|
|
|
|
|
|
|
today => 1, |
898
|
|
|
|
|
|
|
now => 1, |
899
|
|
|
|
|
|
|
yesterday => 1, |
900
|
|
|
|
|
|
|
tomorrow => 1, |
901
|
|
|
|
|
|
|
); |
902
|
|
|
|
|
|
|
|
903
|
|
|
|
|
|
|
# map time units to duractions |
904
|
|
|
|
|
|
|
#my %duration_map = ( |
905
|
|
|
|
|
|
|
# year => 'years', |
906
|
|
|
|
|
|
|
# month => 'months', |
907
|
|
|
|
|
|
|
# day => 'days', |
908
|
|
|
|
|
|
|
# hour => 'hours', |
909
|
|
|
|
|
|
|
# minute => 'minutes', |
910
|
|
|
|
|
|
|
# second => 'seconds', |
911
|
|
|
|
|
|
|
#); |
912
|
|
|
|
|
|
|
|
913
|
|
|
|
|
|
|
sub timefromstring { |
914
|
23
|
|
|
23
|
|
42
|
my ($eztied, $val, %opts) = @_; |
915
|
|
|
|
|
|
|
|
916
|
|
|
|
|
|
|
# TESTING |
917
|
|
|
|
|
|
|
# println subname(); ##i |
918
|
|
|
|
|
|
|
|
919
|
|
|
|
|
|
|
# error checking |
920
|
23
|
50
|
|
|
|
49
|
if (! defined $val) |
921
|
0
|
|
|
|
|
0
|
{ return $eztied->warn('time-string-not-defined: did not get a defined time string') } |
922
|
|
|
|
|
|
|
|
923
|
|
|
|
|
|
|
# alias hour am/pm to hour:00 am/pm |
924
|
|
|
|
|
|
|
# $eztied->{'zero_hour_ampm'} and $val =~ s/(^|[^:\d])(\d+)\s*([ap]m)/$1$2:00:00 $3/gis; |
925
|
|
|
|
|
|
|
# $eztied->{'zero_hour_ampm'} and $val =~ s/(^|[^:\d])(\d+)\s*([ap]m?\b)/$1$2:00:00 $3/gis; |
926
|
|
|
|
|
|
|
|
927
|
|
|
|
|
|
|
# normalize |
928
|
|
|
|
|
|
|
# $val = lc($val); |
929
|
23
|
|
|
|
|
55
|
$val =~ s|^\s+||s; |
930
|
23
|
|
|
|
|
70
|
$val =~ s|\s+$||s; |
931
|
23
|
|
|
|
|
57
|
$val =~ s|\s+| |s; |
932
|
|
|
|
|
|
|
|
933
|
|
|
|
|
|
|
# if just an integer |
934
|
23
|
50
|
|
|
|
126
|
if ($val =~ m/^\d+$/i) { |
|
|
50
|
|
|
|
|
|
935
|
0
|
|
|
|
|
0
|
my ($year, $month, $day, $hour, $min, $sec, $doy, $dow, $dst) = Gmtime($val); |
936
|
|
|
|
|
|
|
|
937
|
|
|
|
|
|
|
# set from gmtime |
938
|
0
|
|
|
|
|
0
|
$eztied->{'year'} = $year; |
939
|
0
|
|
|
|
|
0
|
$eztied->{'monthnum'} = $month; |
940
|
0
|
|
|
|
|
0
|
$eztied->{'dayofmonth'} = $day; |
941
|
0
|
|
|
|
|
0
|
$eztied->{'hour'} = $hour; |
942
|
0
|
|
|
|
|
0
|
$eztied->{'min'} = $min; |
943
|
0
|
|
|
|
|
0
|
$eztied->{'sec'} = $sec; |
944
|
|
|
|
|
|
|
} |
945
|
|
|
|
|
|
|
|
946
|
|
|
|
|
|
|
# elsif today, now, yesterday, tomorrow |
947
|
|
|
|
|
|
|
elsif ($relative{lc $val}) { |
948
|
|
|
|
|
|
|
# lowercase |
949
|
0
|
|
|
|
|
0
|
$val = lc($val); |
950
|
|
|
|
|
|
|
|
951
|
|
|
|
|
|
|
# today |
952
|
0
|
0
|
0
|
|
|
0
|
if ( ($val eq 'today') || ($val eq 'now') ) { |
953
|
0
|
|
|
|
|
0
|
$eztied->setfromtime(); |
954
|
|
|
|
|
|
|
} |
955
|
|
|
|
|
|
|
|
956
|
|
|
|
|
|
|
# tomorrow |
957
|
0
|
0
|
|
|
|
0
|
if ($val eq 'tomorrow') { |
958
|
0
|
|
|
|
|
0
|
$eztied->setfromtime(); |
959
|
|
|
|
|
|
|
|
960
|
|
|
|
|
|
|
@$eztied{qw{year monthnum dayofmonth}} = |
961
|
0
|
|
|
|
|
0
|
Add_Delta_Days(@$eztied{qw{year monthnum dayofmonth}}, 1); |
962
|
|
|
|
|
|
|
} |
963
|
|
|
|
|
|
|
|
964
|
|
|
|
|
|
|
# yesterday |
965
|
0
|
0
|
|
|
|
0
|
if ($val eq 'yesterday') { |
966
|
0
|
|
|
|
|
0
|
$eztied->setfromtime(); |
967
|
|
|
|
|
|
|
|
968
|
|
|
|
|
|
|
@$eztied{qw{year monthnum dayofmonth}} = |
969
|
0
|
|
|
|
|
0
|
Add_Delta_Days(@$eztied{qw{year monthnum dayofmonth}}, -1); |
970
|
|
|
|
|
|
|
} |
971
|
|
|
|
|
|
|
} |
972
|
|
|
|
|
|
|
|
973
|
|
|
|
|
|
|
# else a date string |
974
|
|
|
|
|
|
|
else { |
975
|
23
|
|
|
|
|
25
|
my (%set); |
976
|
|
|
|
|
|
|
|
977
|
|
|
|
|
|
|
# TESTING |
978
|
|
|
|
|
|
|
# println 'date string'; ##i |
979
|
|
|
|
|
|
|
# showvar $val; |
980
|
|
|
|
|
|
|
|
981
|
|
|
|
|
|
|
# special case: ##:##.##### |
982
|
|
|
|
|
|
|
# In some time formats, the hour, min, second is |
983
|
|
|
|
|
|
|
# followed by fractional seconds. We don't handle those |
984
|
|
|
|
|
|
|
# fractions, so we'll just remove them. |
985
|
23
|
|
|
|
|
84
|
$val =~ s/(\d+\:\d+)\.[\d\-]+/$1/g; |
986
|
|
|
|
|
|
|
|
987
|
|
|
|
|
|
|
# Another special case: A.M. to AM and P.M. to PM |
988
|
23
|
|
|
|
|
53
|
$val =~ s/a\.m\b/am/gis; |
989
|
23
|
|
|
|
|
26
|
$val =~ s/p\.m\b/pm/gis; |
990
|
|
|
|
|
|
|
|
991
|
|
|
|
|
|
|
# remove time zone if it exists |
992
|
23
|
50
|
|
|
|
60
|
if ( $val =~ s|[a-z_]+\s*/\s*[a-z_]+$||si ) { |
993
|
0
|
|
|
|
|
0
|
$set{'time_zone'} = $&; |
994
|
0
|
|
|
|
|
0
|
$val =~ s|\s+$||s; |
995
|
|
|
|
|
|
|
} |
996
|
|
|
|
|
|
|
|
997
|
|
|
|
|
|
|
# normalize |
998
|
23
|
|
|
|
|
29
|
$val = lc($val); |
999
|
23
|
|
|
|
|
107
|
$val =~ s/[^\w:]/ /g; |
1000
|
23
|
|
|
|
|
110
|
$val =~ s/\s*:\s*/:/g; |
1001
|
|
|
|
|
|
|
|
1002
|
|
|
|
|
|
|
# change ordinals to numbers |
1003
|
23
|
|
|
|
|
234
|
$val =~ s|$OrdWordsRx|$OrdWordsNums{$1}|gis; |
1004
|
23
|
|
|
|
|
82
|
$val =~ s/(\d)(th|rd|st|nd)\b/$1/gis; |
1005
|
|
|
|
|
|
|
|
1006
|
|
|
|
|
|
|
# noon to 12:00:00 |
1007
|
|
|
|
|
|
|
# midnight to 00:00:00 |
1008
|
23
|
|
|
|
|
55
|
$val =~ s/\bnoon\b/ 12:00:00 /gis; |
1009
|
23
|
|
|
|
|
44
|
$val =~ s/\bmidnight\b/ 00:00:00 /gis; |
1010
|
|
|
|
|
|
|
|
1011
|
|
|
|
|
|
|
# normalize some more |
1012
|
23
|
|
|
|
|
58
|
$val =~ s/(\d)([a-z])/$1 $2/g; |
1013
|
23
|
|
|
|
|
50
|
$val =~ s/([a-z])(\d)/$1 $2/g; |
1014
|
23
|
|
|
|
|
81
|
$val =~ s/\s+/ /g; |
1015
|
23
|
|
|
|
|
44
|
$val =~ s/^\s*//; |
1016
|
23
|
|
|
|
|
103
|
$val =~ s/\s*$//; |
1017
|
23
|
|
|
|
|
66
|
$val =~ s/([a-z]{3})[a-z]+/$1/gs; |
1018
|
|
|
|
|
|
|
|
1019
|
|
|
|
|
|
|
# remove weekday |
1020
|
|
|
|
|
|
|
# TOD0: use localized names of weekdays |
1021
|
23
|
|
|
|
|
162
|
$val =~ s/((sun)|(mon)|(tue)|(wed)|(thu)|(fri)|(sat))\s*//; |
1022
|
23
|
|
|
|
|
92
|
$val =~ s/\s*$//; |
1023
|
|
|
|
|
|
|
|
1024
|
|
|
|
|
|
|
# attempt to get time |
1025
|
23
|
50
|
|
|
|
77
|
unless ($opts{'dateonly'}) { |
1026
|
23
|
|
|
|
|
64
|
($val, @set{qw{hour minute second}}) = $eztied->gettime($val, 'skipjustdigits'=>1); |
1027
|
|
|
|
|
|
|
} |
1028
|
|
|
|
|
|
|
|
1029
|
|
|
|
|
|
|
# attempt to get date |
1030
|
23
|
50
|
|
|
|
53
|
unless ($opts{'timeonly'}) { |
1031
|
23
|
50
|
|
|
|
37
|
if (length $val) { |
1032
|
23
|
|
|
|
|
52
|
($val, @set{qw{day month year}}) = getdate($val); |
1033
|
|
|
|
|
|
|
} |
1034
|
|
|
|
|
|
|
} |
1035
|
|
|
|
|
|
|
|
1036
|
|
|
|
|
|
|
# attempt to get time again |
1037
|
23
|
50
|
|
|
|
50
|
unless ($opts{'dateonly'}) { |
1038
|
23
|
100
|
66
|
|
|
102
|
if (length($val) && (! defined($set{'hour'})) ) { |
1039
|
22
|
|
|
|
|
23
|
my ($hour_new, $min_new, $sec_new); |
1040
|
|
|
|
|
|
|
|
1041
|
|
|
|
|
|
|
# parse again |
1042
|
22
|
|
|
|
|
50
|
($val, $hour_new, $min_new, $sec_new) = $eztied->gettime($val, 'skipjustdigits'=>1, 'croakonfail'=>1); |
1043
|
|
|
|
|
|
|
|
1044
|
|
|
|
|
|
|
# set from new valued if they are defined |
1045
|
22
|
50
|
|
|
|
63
|
defined($hour_new) and $set{'hour'} = $hour_new; |
1046
|
22
|
50
|
|
|
|
45
|
defined($min_new) and $set{'minute'} = $min_new; |
1047
|
22
|
50
|
|
|
|
52
|
defined($sec_new) and $set{'second'} = $sec_new; |
1048
|
|
|
|
|
|
|
} |
1049
|
|
|
|
|
|
|
} |
1050
|
|
|
|
|
|
|
|
1051
|
|
|
|
|
|
|
# is somehow we don't still have a defined string, return |
1052
|
23
|
50
|
|
|
|
50
|
if (! defined $val) |
1053
|
0
|
|
|
|
|
0
|
{ return 0 } |
1054
|
|
|
|
|
|
|
|
1055
|
|
|
|
|
|
|
# trim |
1056
|
23
|
|
|
|
|
47
|
$val =~ s/^\s*//; |
1057
|
|
|
|
|
|
|
|
1058
|
|
|
|
|
|
|
# create new datetime object |
1059
|
23
|
50
|
|
|
|
45
|
if (%set) { |
1060
|
23
|
|
|
|
|
52
|
$eztied->new_date_time(\%set); |
1061
|
|
|
|
|
|
|
} |
1062
|
|
|
|
|
|
|
} |
1063
|
|
|
|
|
|
|
|
1064
|
|
|
|
|
|
|
# return |
1065
|
23
|
|
|
|
|
55
|
return 1; |
1066
|
|
|
|
|
|
|
} |
1067
|
|
|
|
|
|
|
# |
1068
|
|
|
|
|
|
|
# timefromstring |
1069
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1070
|
|
|
|
|
|
|
|
1071
|
|
|
|
|
|
|
|
1072
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1073
|
|
|
|
|
|
|
# new_date_time |
1074
|
|
|
|
|
|
|
# |
1075
|
|
|
|
|
|
|
sub new_date_time { |
1076
|
117
|
|
|
117
|
|
106
|
my ($eztied, $set) = @_; |
1077
|
117
|
|
|
|
|
81
|
my ($old, $new, %offset); |
1078
|
|
|
|
|
|
|
|
1079
|
|
|
|
|
|
|
# TESTING |
1080
|
|
|
|
|
|
|
# println subname(); ##i |
1081
|
|
|
|
|
|
|
|
1082
|
|
|
|
|
|
|
# old datetime object |
1083
|
117
|
|
|
|
|
101
|
$old = $eztied->{'dt'}; |
1084
|
|
|
|
|
|
|
|
1085
|
|
|
|
|
|
|
# create new datetime object with just year |
1086
|
|
|
|
|
|
|
$new = DateTime->new( |
1087
|
|
|
|
|
|
|
year => coal($set->{'year'}, $old->year), |
1088
|
117
|
|
33
|
|
|
341
|
time_zone => $set->{'time_zone'} || $old->time_zone, |
1089
|
|
|
|
|
|
|
); |
1090
|
|
|
|
|
|
|
|
1091
|
|
|
|
|
|
|
# delete year |
1092
|
117
|
|
|
|
|
12571
|
delete $set->{'year'}; |
1093
|
|
|
|
|
|
|
|
1094
|
|
|
|
|
|
|
# build duration |
1095
|
117
|
|
|
|
|
266
|
foreach my $key (keys %$set) { |
1096
|
194
|
100
|
|
|
|
275
|
if (defined $set->{$key}) { |
1097
|
191
|
|
|
|
|
361
|
$offset{$key . 's'} = $set->{$key}; |
1098
|
|
|
|
|
|
|
} |
1099
|
|
|
|
|
|
|
} |
1100
|
|
|
|
|
|
|
|
1101
|
|
|
|
|
|
|
# decrement months and days |
1102
|
117
|
|
|
|
|
132
|
foreach my $key (qw{months days}) { |
1103
|
234
|
100
|
|
|
|
374
|
if (defined $offset{$key}) |
1104
|
91
|
|
|
|
|
132
|
{ $offset{$key}-- } |
1105
|
|
|
|
|
|
|
} |
1106
|
|
|
|
|
|
|
|
1107
|
|
|
|
|
|
|
# add offset to new datetime object |
1108
|
|
|
|
|
|
|
$new->add( |
1109
|
|
|
|
|
|
|
months => coal($offset{'months'}, $old->month - 1 ), |
1110
|
|
|
|
|
|
|
days => coal($offset{'days'}, $old->day - 1 ), |
1111
|
|
|
|
|
|
|
hours => coal($offset{'hours'}, $old->hour ), |
1112
|
|
|
|
|
|
|
minutes => coal($offset{'minutes'}, $old->minute ), |
1113
|
117
|
|
|
|
|
297
|
seconds => coal($offset{'seconds'}, $old->second ), |
1114
|
|
|
|
|
|
|
); |
1115
|
|
|
|
|
|
|
|
1116
|
|
|
|
|
|
|
# set new dattime object |
1117
|
117
|
|
|
|
|
42823
|
$eztied->{'dt'} = $new; |
1118
|
|
|
|
|
|
|
} |
1119
|
|
|
|
|
|
|
# |
1120
|
|
|
|
|
|
|
# new_date_time |
1121
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1122
|
|
|
|
|
|
|
|
1123
|
|
|
|
|
|
|
|
1124
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1125
|
|
|
|
|
|
|
# coal |
1126
|
|
|
|
|
|
|
# short for coalesce |
1127
|
|
|
|
|
|
|
# |
1128
|
|
|
|
|
|
|
sub coal { |
1129
|
702
|
|
|
702
|
|
2175
|
my ($new, $old) = @_; |
1130
|
702
|
100
|
|
|
|
1976
|
return defined($new) ? $new : $old; |
1131
|
|
|
|
|
|
|
} |
1132
|
|
|
|
|
|
|
# |
1133
|
|
|
|
|
|
|
# coal |
1134
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1135
|
|
|
|
|
|
|
|
1136
|
|
|
|
|
|
|
|
1137
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1138
|
|
|
|
|
|
|
# getdate |
1139
|
|
|
|
|
|
|
# attempt to get date |
1140
|
|
|
|
|
|
|
# supported date formats |
1141
|
|
|
|
|
|
|
# 14 Jan 2001 |
1142
|
|
|
|
|
|
|
# 14 JAN 01 |
1143
|
|
|
|
|
|
|
# 14JAN2001 |
1144
|
|
|
|
|
|
|
# Jan 14, 2001 |
1145
|
|
|
|
|
|
|
# Jan 14, 01 |
1146
|
|
|
|
|
|
|
# 01-14-01 |
1147
|
|
|
|
|
|
|
# 1-14-01 |
1148
|
|
|
|
|
|
|
# 1-7-01 |
1149
|
|
|
|
|
|
|
# 01-14-2001 |
1150
|
|
|
|
|
|
|
# |
1151
|
|
|
|
|
|
|
sub getdate { |
1152
|
23
|
|
|
23
|
|
27
|
my ($val) = @_; |
1153
|
23
|
|
|
|
|
28
|
my ($day, $month, $year); |
1154
|
|
|
|
|
|
|
|
1155
|
|
|
|
|
|
|
# TESTING |
1156
|
|
|
|
|
|
|
# println subname(); ##i |
1157
|
|
|
|
|
|
|
|
1158
|
|
|
|
|
|
|
# Tue Jun 12 13:03:28 2012 |
1159
|
23
|
50
|
|
|
|
199
|
if ($val =~ s/^([a-z]+) (\d+) (\S+) (\d+)$/$3/) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
|
|
0
|
|
|
|
|
|
1160
|
0
|
|
|
|
|
0
|
$year = $4; |
1161
|
0
|
|
|
|
|
0
|
$month = $MonthNums{$1}; |
1162
|
0
|
|
|
|
|
0
|
$day = $2; |
1163
|
|
|
|
|
|
|
} |
1164
|
|
|
|
|
|
|
|
1165
|
|
|
|
|
|
|
# 14 Jan 2001 |
1166
|
|
|
|
|
|
|
# 14 JAN 01 |
1167
|
|
|
|
|
|
|
# 14JAN2001 # will be normalized to have spaces |
1168
|
|
|
|
|
|
|
elsif ($val =~ m/^\d+ [a-z]+ \d{4}$/) { |
1169
|
1
|
|
|
|
|
5
|
my @tokens = split(' ', $val); |
1170
|
1
|
|
|
|
|
2
|
$day = $tokens[0]; |
1171
|
1
|
|
|
|
|
2
|
$month = $MonthNums{$tokens[1]}; |
1172
|
1
|
|
|
|
|
2
|
$year = $tokens[2]; |
1173
|
1
|
|
|
|
|
2
|
$val = ''; |
1174
|
|
|
|
|
|
|
} |
1175
|
|
|
|
|
|
|
|
1176
|
|
|
|
|
|
|
# Jan 14, 2001 |
1177
|
|
|
|
|
|
|
# Jan 14, 01 |
1178
|
|
|
|
|
|
|
elsif ($val =~ s/^([a-z]+) (\d+) (\d+)//) { |
1179
|
22
|
|
|
|
|
48
|
$month = $MonthNums{$1}; |
1180
|
22
|
|
|
|
|
37
|
$day = $2; |
1181
|
22
|
|
|
|
|
31
|
$year = $3; |
1182
|
|
|
|
|
|
|
} |
1183
|
|
|
|
|
|
|
|
1184
|
|
|
|
|
|
|
# Jan 2001 |
1185
|
|
|
|
|
|
|
# Jan 01 |
1186
|
|
|
|
|
|
|
elsif ($val =~ s/^([a-z]+) (\d+)//) { |
1187
|
0
|
|
|
|
|
0
|
$month = $MonthNums{$1}; |
1188
|
0
|
|
|
|
|
0
|
$year = $2; |
1189
|
|
|
|
|
|
|
} |
1190
|
|
|
|
|
|
|
|
1191
|
|
|
|
|
|
|
# 2001-01-14 |
1192
|
|
|
|
|
|
|
elsif ($val =~ s/^(\d{4}) (\d+) (\d+)//) { |
1193
|
0
|
|
|
|
|
0
|
$year = $1; |
1194
|
0
|
|
|
|
|
0
|
$month = $2 - 1; |
1195
|
0
|
|
|
|
|
0
|
$day = $3; |
1196
|
|
|
|
|
|
|
} |
1197
|
|
|
|
|
|
|
|
1198
|
|
|
|
|
|
|
# 01-14-01 |
1199
|
|
|
|
|
|
|
# 1-14-01 |
1200
|
|
|
|
|
|
|
# 1-7-01 |
1201
|
|
|
|
|
|
|
# 01-14-2001 |
1202
|
|
|
|
|
|
|
elsif ($val =~ s/^(\d+) (\d+) (\d+)//) { |
1203
|
0
|
|
|
|
|
0
|
$month = $1 - 1; |
1204
|
0
|
|
|
|
|
0
|
$day = $2; |
1205
|
0
|
|
|
|
|
0
|
$year = $3; |
1206
|
|
|
|
|
|
|
} |
1207
|
|
|
|
|
|
|
|
1208
|
|
|
|
|
|
|
# return |
1209
|
23
|
|
|
|
|
102
|
return ($val, $day, $month, $year); |
1210
|
|
|
|
|
|
|
} |
1211
|
|
|
|
|
|
|
# |
1212
|
|
|
|
|
|
|
# getdate |
1213
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1214
|
|
|
|
|
|
|
|
1215
|
|
|
|
|
|
|
|
1216
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1217
|
|
|
|
|
|
|
# gettime |
1218
|
|
|
|
|
|
|
# supported time formats: |
1219
|
|
|
|
|
|
|
# 5pm |
1220
|
|
|
|
|
|
|
# 5:34 pm |
1221
|
|
|
|
|
|
|
# 17:34 |
1222
|
|
|
|
|
|
|
# 17:34:13 |
1223
|
|
|
|
|
|
|
# 5:34:13 |
1224
|
|
|
|
|
|
|
# 5:34:13 pm |
1225
|
|
|
|
|
|
|
# 2330 (military time) |
1226
|
|
|
|
|
|
|
# |
1227
|
|
|
|
|
|
|
sub gettime { |
1228
|
45
|
|
|
45
|
|
111
|
my ($eztied, $str, %opts)= @_; |
1229
|
45
|
|
|
|
|
37
|
my ($hour, $min, $sec); |
1230
|
|
|
|
|
|
|
|
1231
|
|
|
|
|
|
|
# TESTING |
1232
|
|
|
|
|
|
|
# println subname(); ##i |
1233
|
|
|
|
|
|
|
|
1234
|
|
|
|
|
|
|
# string must be defined |
1235
|
45
|
50
|
|
|
|
74
|
unless (defined $str) { |
1236
|
0
|
|
|
|
|
0
|
croak 'strin-not-defined: $str is not defined'; |
1237
|
|
|
|
|
|
|
} |
1238
|
|
|
|
|
|
|
|
1239
|
|
|
|
|
|
|
# clean up a little |
1240
|
45
|
|
|
|
|
88
|
$str =~ s/^\s+//; |
1241
|
45
|
|
|
|
|
80
|
$str =~ s/\s+$//; |
1242
|
45
|
|
|
|
|
39
|
$str =~ s/^://; |
1243
|
45
|
|
|
|
|
36
|
$str =~ s/:$//; |
1244
|
45
|
|
|
|
|
97
|
$str =~ s/(\d)(am|pm)/$1 $2/; |
1245
|
|
|
|
|
|
|
|
1246
|
|
|
|
|
|
|
# 5:34:13 pm |
1247
|
|
|
|
|
|
|
# 5:34:13 p |
1248
|
45
|
100
|
33
|
|
|
338
|
if ($str =~ s/^(\d+):(\d+):(\d+) (a|p)(m|\b)\s*//) { |
|
|
100
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
|
|
50
|
|
|
|
|
|
1249
|
19
|
|
|
|
|
38
|
$hour = ampmhour($1, $4); |
1250
|
19
|
|
|
|
|
24
|
$min = $2; |
1251
|
19
|
|
|
|
|
18
|
$sec = $3; |
1252
|
|
|
|
|
|
|
} |
1253
|
|
|
|
|
|
|
|
1254
|
|
|
|
|
|
|
# 17:34:13 |
1255
|
|
|
|
|
|
|
elsif ($str =~ s/^(\d+):(\d+):(\d+)\s*//) { |
1256
|
3
|
|
|
|
|
7
|
$hour = $1; |
1257
|
3
|
|
|
|
|
7
|
$min = $2; |
1258
|
3
|
|
|
|
|
4
|
$sec = $3; |
1259
|
|
|
|
|
|
|
} |
1260
|
|
|
|
|
|
|
|
1261
|
|
|
|
|
|
|
# 5:34 pm |
1262
|
|
|
|
|
|
|
elsif ($str =~ s/^(\d+):(\d+) (a|p)m?\s*//) { |
1263
|
0
|
|
|
|
|
0
|
$hour = ampmhour($1, $3); |
1264
|
0
|
|
|
|
|
0
|
$min = $2; |
1265
|
|
|
|
|
|
|
} |
1266
|
|
|
|
|
|
|
|
1267
|
|
|
|
|
|
|
# 17:34 |
1268
|
|
|
|
|
|
|
elsif ($str =~ s/^(\d+):(\d+)\s*//) { |
1269
|
0
|
|
|
|
|
0
|
$hour = $1; |
1270
|
0
|
|
|
|
|
0
|
$min = $2; |
1271
|
|
|
|
|
|
|
} |
1272
|
|
|
|
|
|
|
|
1273
|
|
|
|
|
|
|
# 5 pm |
1274
|
|
|
|
|
|
|
elsif ($str =~ s/^(\d+) (a|p)m?\b\s*//) { |
1275
|
0
|
|
|
|
|
0
|
$hour = ampmhour($1, $2); |
1276
|
0
|
|
|
|
|
0
|
$min = 0; |
1277
|
0
|
|
|
|
|
0
|
$sec = 0; |
1278
|
|
|
|
|
|
|
} |
1279
|
|
|
|
|
|
|
|
1280
|
|
|
|
|
|
|
# elsif just digits |
1281
|
|
|
|
|
|
|
elsif ( (! $opts{'skipjustdigits'}) && ($str =~ m/^\d+$/) ) { |
1282
|
0
|
|
|
|
|
0
|
$str = zeropad_open($str, 4); |
1283
|
0
|
|
|
|
|
0
|
$hour = substr($str, 0, 2); |
1284
|
0
|
|
|
|
|
0
|
$min = substr($str, 2, 2); |
1285
|
|
|
|
|
|
|
} |
1286
|
|
|
|
|
|
|
|
1287
|
|
|
|
|
|
|
# else don't recognize format |
1288
|
|
|
|
|
|
|
elsif ($opts{'croakonfail'}) { |
1289
|
0
|
|
|
|
|
0
|
return $eztied->warn("unrecognized-format: don't recognize time format: $str"); |
1290
|
|
|
|
|
|
|
} |
1291
|
|
|
|
|
|
|
|
1292
|
|
|
|
|
|
|
# return |
1293
|
45
|
|
|
|
|
181
|
return ($str, $hour, $min, $sec); |
1294
|
|
|
|
|
|
|
} |
1295
|
|
|
|
|
|
|
# |
1296
|
|
|
|
|
|
|
# gettime |
1297
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1298
|
|
|
|
|
|
|
|
1299
|
|
|
|
|
|
|
|
1300
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1301
|
|
|
|
|
|
|
# ampmhour |
1302
|
|
|
|
|
|
|
# |
1303
|
|
|
|
|
|
|
sub ampmhour { |
1304
|
19
|
|
|
19
|
|
38
|
my ($hour, $ampm) = @_; |
1305
|
|
|
|
|
|
|
|
1306
|
|
|
|
|
|
|
# if 12 |
1307
|
19
|
100
|
|
|
|
75
|
if ($hour == 12) { |
|
|
100
|
|
|
|
|
|
1308
|
|
|
|
|
|
|
# if am, set to 0 |
1309
|
3
|
50
|
|
|
|
9
|
if ($ampm =~ m/^a/) |
1310
|
0
|
|
|
|
|
0
|
{$hour = 0} |
1311
|
|
|
|
|
|
|
} |
1312
|
|
|
|
|
|
|
|
1313
|
|
|
|
|
|
|
# else if pm, add 12 |
1314
|
|
|
|
|
|
|
elsif ($ampm =~ m/^p/) { |
1315
|
5
|
|
|
|
|
7
|
$hour += 12; |
1316
|
|
|
|
|
|
|
} |
1317
|
|
|
|
|
|
|
|
1318
|
|
|
|
|
|
|
# return |
1319
|
19
|
|
|
|
|
33
|
return $hour; |
1320
|
|
|
|
|
|
|
} |
1321
|
|
|
|
|
|
|
# |
1322
|
|
|
|
|
|
|
# ampmhour |
1323
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1324
|
|
|
|
|
|
|
|
1325
|
|
|
|
|
|
|
|
1326
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1327
|
|
|
|
|
|
|
# set_format |
1328
|
|
|
|
|
|
|
# |
1329
|
|
|
|
|
|
|
sub set_format { |
1330
|
161
|
|
|
161
|
|
157
|
my ($eztied, $name, $format) = @_; |
1331
|
|
|
|
|
|
|
|
1332
|
|
|
|
|
|
|
# normalize name |
1333
|
161
|
|
|
|
|
194
|
$name =~ s|\s||g; |
1334
|
161
|
|
|
|
|
1441
|
$name =~ lc($name); |
1335
|
|
|
|
|
|
|
|
1336
|
161
|
|
|
|
|
234
|
$eztied->{'formats'}->{$name} = format_split($format); |
1337
|
|
|
|
|
|
|
} |
1338
|
|
|
|
|
|
|
|
1339
|
|
|
|
|
|
|
sub format_split { |
1340
|
|
|
|
|
|
|
# split |
1341
|
223
|
|
|
223
|
|
1708
|
my @rv = split(m/(\{[^\{\}]*\}|\%.)/, $_[0]); |
1342
|
|
|
|
|
|
|
|
1343
|
|
|
|
|
|
|
# normalize |
1344
|
223
|
|
|
|
|
300
|
foreach my $el (@rv) { |
1345
|
1417
|
100
|
|
|
|
2319
|
if ($el =~ m|^\{.*\}$|s) |
1346
|
558
|
|
|
|
|
572
|
{ normalize_key($el) } |
1347
|
|
|
|
|
|
|
} |
1348
|
|
|
|
|
|
|
|
1349
|
|
|
|
|
|
|
# remove empties |
1350
|
223
|
|
|
|
|
228
|
@rv = grep {length $_} @rv; |
|
1417
|
|
|
|
|
1517
|
|
1351
|
|
|
|
|
|
|
|
1352
|
|
|
|
|
|
|
# return |
1353
|
223
|
|
|
|
|
527
|
return \@rv; |
1354
|
|
|
|
|
|
|
} |
1355
|
|
|
|
|
|
|
# |
1356
|
|
|
|
|
|
|
# set_format |
1357
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1358
|
|
|
|
|
|
|
|
1359
|
|
|
|
|
|
|
|
1360
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1361
|
|
|
|
|
|
|
# setfromtime |
1362
|
|
|
|
|
|
|
# |
1363
|
|
|
|
|
|
|
sub setfromtime { |
1364
|
0
|
|
|
0
|
|
0
|
my ($eztied, $time) = @_; |
1365
|
|
|
|
|
|
|
|
1366
|
|
|
|
|
|
|
# TESTING |
1367
|
|
|
|
|
|
|
# println subname(); ##i |
1368
|
|
|
|
|
|
|
|
1369
|
|
|
|
|
|
|
# set time fields |
1370
|
0
|
|
|
|
|
0
|
@$eztied{@ltimefields} = localtime(); |
1371
|
|
|
|
|
|
|
|
1372
|
|
|
|
|
|
|
# add 1900 to year |
1373
|
0
|
|
|
|
|
0
|
$eztied->{'year'} += 1900; |
1374
|
|
|
|
|
|
|
|
1375
|
|
|
|
|
|
|
# increment monthnum, which was base zero, to base one |
1376
|
0
|
|
|
|
|
0
|
$eztied->{'monthnum'}++; |
1377
|
|
|
|
|
|
|
} |
1378
|
|
|
|
|
|
|
# |
1379
|
|
|
|
|
|
|
# setfromtime |
1380
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1381
|
|
|
|
|
|
|
|
1382
|
|
|
|
|
|
|
|
1383
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1384
|
|
|
|
|
|
|
# normalize_key |
1385
|
|
|
|
|
|
|
# |
1386
|
|
|
|
|
|
|
sub normalize_key { |
1387
|
1581
|
|
|
1581
|
|
1972
|
$_[0] =~ s|\s||gs; |
1388
|
1581
|
100
|
|
|
|
2825
|
$_[0] =~ tr/A-Z/a-z/ unless $_[0] =~ m|^\%\w$|; |
1389
|
1581
|
|
|
|
|
1337
|
$_[0] =~ s|ordinal|ord|sg; |
1390
|
|
|
|
|
|
|
|
1391
|
1581
|
|
|
|
|
1188
|
$_[0] =~ s|hours|hour|sg; |
1392
|
|
|
|
|
|
|
|
1393
|
1581
|
|
|
|
|
1161
|
$_[0] =~ s|minute|min|sg; |
1394
|
1581
|
|
|
|
|
1088
|
$_[0] =~ s|mins|min|sg; |
1395
|
|
|
|
|
|
|
|
1396
|
1581
|
|
|
|
|
1046
|
$_[0] =~ s|second|sec|sg; |
1397
|
1581
|
|
|
|
|
1106
|
$_[0] =~ s|secs|sec|sg; |
1398
|
|
|
|
|
|
|
|
1399
|
1581
|
|
|
|
|
1155
|
$_[0] =~ s/two/2/gs; |
1400
|
1581
|
|
|
|
|
1225
|
$_[0] =~ s/three/3/gs; |
1401
|
1581
|
|
|
|
|
1232
|
$_[0] =~ s/digits?/d/gs; |
1402
|
|
|
|
|
|
|
|
1403
|
1581
|
|
|
|
|
996
|
$_[0] =~ s/timezone/tz/gs; |
1404
|
|
|
|
|
|
|
|
1405
|
1581
|
|
|
|
|
1525
|
$_[0] =~ s|number|num|sg; |
1406
|
|
|
|
|
|
|
} |
1407
|
|
|
|
|
|
|
# |
1408
|
|
|
|
|
|
|
# normalize_key |
1409
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1410
|
|
|
|
|
|
|
|
1411
|
|
|
|
|
|
|
|
1412
|
|
|
|
|
|
|
|
1413
|
|
|
|
|
|
|
|
1414
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1415
|
|
|
|
|
|
|
# zeropad_open, zeropad_2 |
1416
|
|
|
|
|
|
|
# |
1417
|
|
|
|
|
|
|
sub zeropad_open { |
1418
|
30
|
|
|
30
|
|
87
|
my ($rv, $length) = @_; |
1419
|
30
|
|
50
|
|
|
42
|
$length ||= 2; |
1420
|
|
|
|
|
|
|
# return ('0' x ($length - length($rv))) . $rv; |
1421
|
30
|
|
|
|
|
134
|
return sprintf "%0${length}d", $rv; |
1422
|
|
|
|
|
|
|
} |
1423
|
|
|
|
|
|
|
|
1424
|
|
|
|
|
|
|
sub zeropad_2 { |
1425
|
456
|
|
|
456
|
|
1447
|
my ($val) = @_; |
1426
|
|
|
|
|
|
|
|
1427
|
|
|
|
|
|
|
# $val must be defined |
1428
|
456
|
50
|
|
|
|
614
|
if (! defined $val) { |
1429
|
0
|
|
|
|
|
0
|
croak 'zeropad_2~val-not-defined: the value sent to zeropad_2 is not defined'; |
1430
|
|
|
|
|
|
|
} |
1431
|
|
|
|
|
|
|
|
1432
|
|
|
|
|
|
|
# return |
1433
|
456
|
|
|
|
|
1760
|
return sprintf "%02d", $_[0]; |
1434
|
|
|
|
|
|
|
} |
1435
|
|
|
|
|
|
|
# |
1436
|
|
|
|
|
|
|
# zeropad_open, zeropad_2 |
1437
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1438
|
|
|
|
|
|
|
|
1439
|
|
|
|
|
|
|
|
1440
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1441
|
|
|
|
|
|
|
# month_short |
1442
|
|
|
|
|
|
|
# |
1443
|
|
|
|
|
|
|
#sub month_short { |
1444
|
|
|
|
|
|
|
# my ($eztied) = @_; |
1445
|
|
|
|
|
|
|
# my ($rv); |
1446
|
|
|
|
|
|
|
# |
1447
|
|
|
|
|
|
|
# # get name of month, return just the first three letters |
1448
|
|
|
|
|
|
|
# $rv = Month_to_Text($eztied->{'monthnum'}); |
1449
|
|
|
|
|
|
|
# $rv = substr($rv, 0, 3); |
1450
|
|
|
|
|
|
|
# |
1451
|
|
|
|
|
|
|
# # return |
1452
|
|
|
|
|
|
|
# return $rv; |
1453
|
|
|
|
|
|
|
#} |
1454
|
|
|
|
|
|
|
# |
1455
|
|
|
|
|
|
|
# month_short |
1456
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1457
|
|
|
|
|
|
|
|
1458
|
|
|
|
|
|
|
|
1459
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1460
|
|
|
|
|
|
|
# FETCH |
1461
|
|
|
|
|
|
|
# |
1462
|
|
|
|
|
|
|
sub FETCH { |
1463
|
1268
|
|
|
1268
|
|
14011
|
my ($eztied, $key, %opts) = @_; |
1464
|
1268
|
|
|
|
|
845
|
my ($orgkey, $dt); |
1465
|
|
|
|
|
|
|
|
1466
|
|
|
|
|
|
|
# TESTING |
1467
|
|
|
|
|
|
|
# println subname(); ##i |
1468
|
|
|
|
|
|
|
|
1469
|
|
|
|
|
|
|
# hold on to original key |
1470
|
1268
|
|
|
|
|
919
|
$orgkey = $key; |
1471
|
|
|
|
|
|
|
|
1472
|
|
|
|
|
|
|
# get key from aliases if necessary |
1473
|
1268
|
|
|
|
|
1394
|
$key = $eztied->get_alias($key); |
1474
|
|
|
|
|
|
|
|
1475
|
|
|
|
|
|
|
|
1476
|
|
|
|
|
|
|
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
1477
|
|
|
|
|
|
|
# nested properties |
1478
|
|
|
|
|
|
|
# |
1479
|
1268
|
100
|
100
|
|
|
4630
|
if ( (! ref $key) && ($key =~ m|[\{\%]|) && ($key !~ m|$pcode|o) ) |
|
|
|
66
|
|
|
|
|
1480
|
62
|
|
|
|
|
97
|
{ $key = format_split($key) } |
1481
|
|
|
|
|
|
|
|
1482
|
1268
|
100
|
|
|
|
1493
|
if (ref $key) { |
1483
|
69
|
|
|
|
|
144
|
my @rv = @$key; |
1484
|
|
|
|
|
|
|
|
1485
|
69
|
|
|
|
|
76
|
foreach my $el (@rv) { |
1486
|
|
|
|
|
|
|
# if this is one of the format elements |
1487
|
|
|
|
|
|
|
# then fetch the value of the given key |
1488
|
480
|
100
|
100
|
|
|
2267
|
if ( |
1489
|
|
|
|
|
|
|
($el =~ s|\{([^\}]+)\}|$1|) || # if it is enclosed in {} |
1490
|
|
|
|
|
|
|
($el =~ m|$pcode|o) # if it is a %x code |
1491
|
|
|
|
|
|
|
) { |
1492
|
274
|
|
|
|
|
320
|
$el =~ s|['"\s]||g; |
1493
|
274
|
|
|
|
|
383
|
$el = $eztied->FETCH($el, normalized=>1); |
1494
|
|
|
|
|
|
|
} |
1495
|
|
|
|
|
|
|
} |
1496
|
|
|
|
|
|
|
|
1497
|
|
|
|
|
|
|
# ensure defined values in @rv |
1498
|
69
|
|
|
|
|
235
|
foreach my $val (@rv) { |
1499
|
480
|
50
|
|
|
|
588
|
if (! defined $val) |
1500
|
0
|
|
|
|
|
0
|
{ $val = '' } |
1501
|
|
|
|
|
|
|
} |
1502
|
|
|
|
|
|
|
|
1503
|
|
|
|
|
|
|
# return |
1504
|
69
|
|
|
|
|
349
|
return join('', @rv); |
1505
|
|
|
|
|
|
|
} |
1506
|
|
|
|
|
|
|
# |
1507
|
|
|
|
|
|
|
# nested properties |
1508
|
|
|
|
|
|
|
#- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - |
1509
|
|
|
|
|
|
|
|
1510
|
|
|
|
|
|
|
|
1511
|
|
|
|
|
|
|
# clean up key |
1512
|
1199
|
100
|
|
|
|
1967
|
$opts{'normalized'} or normalize_key($key); |
1513
|
|
|
|
|
|
|
|
1514
|
|
|
|
|
|
|
# datetime object |
1515
|
1199
|
|
|
|
|
1038
|
$dt = $eztied->{'dt'}; |
1516
|
|
|
|
|
|
|
|
1517
|
|
|
|
|
|
|
# datetime object |
1518
|
1199
|
50
|
33
|
|
|
3171
|
if ( ($key eq 'dt') || $key eq 'datetime' ) { |
1519
|
0
|
|
|
|
|
0
|
return $dt; |
1520
|
|
|
|
|
|
|
} |
1521
|
|
|
|
|
|
|
|
1522
|
|
|
|
|
|
|
# already or mostly calculated |
1523
|
|
|
|
|
|
|
#if (exists $eztied->{$key}) { |
1524
|
|
|
|
|
|
|
# # ensure two digits for several properties |
1525
|
|
|
|
|
|
|
# if ( $key =~ m/^(dayofmonth|monthnum|hour|min|sec)$/ ) |
1526
|
|
|
|
|
|
|
# { return zeropad_2($eztied->{$key}) } |
1527
|
|
|
|
|
|
|
# |
1528
|
|
|
|
|
|
|
# # all other properties, return key as-is |
1529
|
|
|
|
|
|
|
# return $eztied->{$key}; |
1530
|
|
|
|
|
|
|
#} |
1531
|
|
|
|
|
|
|
|
1532
|
|
|
|
|
|
|
# character codes |
1533
|
1199
|
100
|
|
|
|
1381
|
$key eq 'newline' and return "\n"; |
1534
|
1184
|
100
|
|
|
|
1270
|
$key eq 'tab' and return "\t"; |
1535
|
1169
|
50
|
|
|
|
1188
|
$key eq 'leftbrace' and return '{'; |
1536
|
1169
|
50
|
|
|
|
1273
|
$key eq 'lb' and return '{'; |
1537
|
1169
|
50
|
|
|
|
1298
|
$key eq 'rightbrace' and return '}'; |
1538
|
1169
|
50
|
|
|
|
1282
|
$key eq 'rb' and return '}'; |
1539
|
1169
|
100
|
|
|
|
1383
|
$key eq 'percent' and return '%'; |
1540
|
|
|
|
|
|
|
|
1541
|
|
|
|
|
|
|
# nozero's |
1542
|
1154
|
100
|
|
|
|
1754
|
if ($key =~ s/no(zero|0)//) |
1543
|
75
|
|
|
|
|
104
|
{ return $eztied->FETCH($key) + 0 } |
1544
|
|
|
|
|
|
|
|
1545
|
|
|
|
|
|
|
# day of month |
1546
|
1079
|
100
|
|
|
|
1303
|
if ($key eq 'dayofmonth') |
1547
|
66
|
|
|
|
|
140
|
{ return $dt->day } |
1548
|
|
|
|
|
|
|
|
1549
|
|
|
|
|
|
|
# day of month, two digits |
1550
|
1013
|
100
|
|
|
|
1116
|
if ($key eq 'dayofmonth2d') |
1551
|
30
|
|
|
|
|
87
|
{ return zeropad_2($dt->day) } |
1552
|
|
|
|
|
|
|
|
1553
|
|
|
|
|
|
|
# day of month ord |
1554
|
983
|
50
|
|
|
|
1193
|
if ($key =~ m|^dayofmonthord(word)?$|) |
1555
|
0
|
|
|
|
|
0
|
{ return $OrdWords[$eztied->{'dayofmonth'}] } |
1556
|
983
|
50
|
|
|
|
1076
|
if ($key eq 'dayofmonthordnum') |
1557
|
0
|
|
|
|
|
0
|
{ return $OrdNums[$eztied->{'dayofmonth'}] } |
1558
|
|
|
|
|
|
|
|
1559
|
|
|
|
|
|
|
# weekdaynum |
1560
|
983
|
100
|
|
|
|
1056
|
if ($key eq 'weekdaynum') |
1561
|
30
|
|
|
|
|
82
|
{ return $dt->day_of_week() } |
1562
|
|
|
|
|
|
|
|
1563
|
|
|
|
|
|
|
# weekdaynum2d |
1564
|
953
|
50
|
|
|
|
1067
|
if ($key eq 'weekdaynum2d') |
1565
|
0
|
|
|
|
|
0
|
{ return zeropad_2($dt->day_of_week()) } |
1566
|
|
|
|
|
|
|
|
1567
|
|
|
|
|
|
|
# weekday |
1568
|
953
|
100
|
|
|
|
1289
|
if ($key =~ m/^(weekdayshort|dayofweekshort|dayofweek)$/) |
1569
|
45
|
|
|
|
|
115
|
{ return $dt->day_abbr() } |
1570
|
908
|
100
|
|
|
|
1016
|
if ($key =~ m/^(weekdaylong|dayofweeklong)$/) |
1571
|
31
|
|
|
|
|
81
|
{ return $dt->day_name() } |
1572
|
|
|
|
|
|
|
|
1573
|
|
|
|
|
|
|
# month |
1574
|
877
|
100
|
|
|
|
943
|
if ($key eq 'monthshort') |
1575
|
47
|
|
|
|
|
99
|
{ return $dt->month_abbr() } |
1576
|
830
|
100
|
66
|
|
|
2045
|
if ( ($key eq 'month') || ($key eq 'monthlong') ) |
1577
|
16
|
|
|
|
|
63
|
{ return $dt->month_name() } |
1578
|
|
|
|
|
|
|
|
1579
|
|
|
|
|
|
|
# month number |
1580
|
814
|
100
|
|
|
|
916
|
if ($key eq 'monthnum') |
1581
|
31
|
|
|
|
|
81
|
{ return $dt->month } |
1582
|
783
|
100
|
|
|
|
867
|
if ($key eq 'monthnum2d') |
1583
|
45
|
|
|
|
|
87
|
{ return zeropad_2($dt->month) } |
1584
|
|
|
|
|
|
|
|
1585
|
|
|
|
|
|
|
# day of year |
1586
|
738
|
100
|
|
|
|
880
|
if ($key eq 'yearday') |
1587
|
16
|
|
|
|
|
52
|
{ return $dt->day_of_year() } |
1588
|
722
|
100
|
|
|
|
828
|
if ($key eq 'yearday3d') |
1589
|
30
|
|
|
|
|
57
|
{ return zeropad_open($dt->day_of_year(), 3) } |
1590
|
|
|
|
|
|
|
|
1591
|
|
|
|
|
|
|
# year |
1592
|
692
|
100
|
|
|
|
756
|
if ($key eq 'year') |
1593
|
48
|
|
|
|
|
103
|
{ return $dt->year } |
1594
|
644
|
100
|
|
|
|
704
|
if ($key eq 'year2d') |
1595
|
45
|
|
|
|
|
90
|
{ return substr($dt->year, -2) } |
1596
|
|
|
|
|
|
|
|
1597
|
|
|
|
|
|
|
# epoch |
1598
|
599
|
50
|
33
|
|
|
1437
|
if ( ($key eq 'epoch') || ($key eq 'epochsec') ) |
1599
|
0
|
|
|
|
|
0
|
{ return Date_to_Time(@$eztied{qw{year monthnum dayofmonth hour min sec}}) } |
1600
|
|
|
|
|
|
|
|
1601
|
|
|
|
|
|
|
# leapyear |
1602
|
599
|
100
|
|
|
|
769
|
if ($key =~ m/^(is)?leapyear/) |
1603
|
30
|
|
|
|
|
81
|
{ return $dt->is_leap_year() } |
1604
|
|
|
|
|
|
|
|
1605
|
|
|
|
|
|
|
# days in month |
1606
|
569
|
100
|
|
|
|
648
|
if ($key eq 'daysinmonth') { |
1607
|
30
|
|
|
|
|
56
|
return DateTime->last_day_of_month( |
1608
|
|
|
|
|
|
|
year => $dt->year, |
1609
|
|
|
|
|
|
|
month => $dt->month, |
1610
|
|
|
|
|
|
|
time_zone => $dt->time_zone_long_name() |
1611
|
|
|
|
|
|
|
)->day; |
1612
|
|
|
|
|
|
|
} |
1613
|
|
|
|
|
|
|
|
1614
|
|
|
|
|
|
|
# DMY: eg 15JAN2001 |
1615
|
539
|
100
|
|
|
|
638
|
if ($key eq 'dmy') { |
1616
|
|
|
|
|
|
|
return |
1617
|
1
|
|
|
|
|
2
|
zeropad_2($dt->day) . |
1618
|
|
|
|
|
|
|
uc($dt->month_abbr()) . |
1619
|
|
|
|
|
|
|
$dt->year; |
1620
|
|
|
|
|
|
|
} |
1621
|
|
|
|
|
|
|
|
1622
|
|
|
|
|
|
|
# full |
1623
|
538
|
100
|
|
|
|
589
|
if ($key eq 'full') { |
1624
|
11
|
|
|
|
|
6
|
my ($weekday); |
1625
|
|
|
|
|
|
|
|
1626
|
|
|
|
|
|
|
# return |
1627
|
|
|
|
|
|
|
return |
1628
|
11
|
|
|
|
|
29
|
$dt->day_abbr() . ' ' . |
1629
|
|
|
|
|
|
|
$dt->month_abbr() . ' ' . |
1630
|
|
|
|
|
|
|
$dt->day() . ', ' . |
1631
|
|
|
|
|
|
|
$dt->year() . ' ' . |
1632
|
|
|
|
|
|
|
zeropad_2($dt->hour) . ':' . |
1633
|
|
|
|
|
|
|
zeropad_2($dt->minute) . ':' . |
1634
|
|
|
|
|
|
|
zeropad_2($dt->second); |
1635
|
|
|
|
|
|
|
} |
1636
|
|
|
|
|
|
|
|
1637
|
|
|
|
|
|
|
# military time, aka "miltime" |
1638
|
527
|
100
|
|
|
|
724
|
if ($key =~ m|^mil(itary)?time$|) |
1639
|
30
|
|
|
|
|
66
|
{ return zeropad_2($dt->hour) . zeropad_2($dt->minute) } |
1640
|
|
|
|
|
|
|
|
1641
|
|
|
|
|
|
|
# iso8601 |
1642
|
497
|
50
|
|
|
|
615
|
if ($key eq 'iso8601') { |
1643
|
|
|
|
|
|
|
return |
1644
|
|
|
|
|
|
|
$eztied->{'year'} . '-' . |
1645
|
|
|
|
|
|
|
zeropad_2($eztied->{'monthnum'}) . '-' . |
1646
|
|
|
|
|
|
|
zeropad_2($eztied->{'dayofmonth'}) . ' ' . |
1647
|
|
|
|
|
|
|
|
1648
|
|
|
|
|
|
|
zeropad_2($eztied->{'hour'}) . ':' . |
1649
|
|
|
|
|
|
|
zeropad_2($eztied->{'min'}) . ':' . |
1650
|
0
|
|
|
|
|
0
|
zeropad_2($eztied->{'sec'}); |
1651
|
|
|
|
|
|
|
} |
1652
|
|
|
|
|
|
|
|
1653
|
|
|
|
|
|
|
# hour |
1654
|
497
|
100
|
|
|
|
555
|
if ($key eq 'hour') |
1655
|
15
|
|
|
|
|
37
|
{ return $dt->hour } |
1656
|
|
|
|
|
|
|
|
1657
|
|
|
|
|
|
|
# hour two digits |
1658
|
482
|
100
|
|
|
|
567
|
if ($key eq 'hour2d') |
1659
|
60
|
|
|
|
|
134
|
{ return zeropad_2($dt->hour) } |
1660
|
|
|
|
|
|
|
|
1661
|
|
|
|
|
|
|
# minute |
1662
|
422
|
100
|
|
|
|
492
|
if ($key eq 'min') |
1663
|
45
|
|
|
|
|
88
|
{ return $dt->minute } |
1664
|
|
|
|
|
|
|
|
1665
|
|
|
|
|
|
|
# minute two digits |
1666
|
377
|
100
|
|
|
|
444
|
if ($key eq 'min2d') |
1667
|
75
|
|
|
|
|
144
|
{ return zeropad_2($dt->minute) } |
1668
|
|
|
|
|
|
|
|
1669
|
|
|
|
|
|
|
# second |
1670
|
302
|
100
|
|
|
|
371
|
if ($key eq 'sec') |
1671
|
60
|
|
|
|
|
114
|
{ return $dt->second } |
1672
|
|
|
|
|
|
|
|
1673
|
|
|
|
|
|
|
# second two digits |
1674
|
242
|
100
|
|
|
|
308
|
if ($key eq 'sec2d') |
1675
|
75
|
|
|
|
|
164
|
{ return zeropad_2($dt->second) } |
1676
|
|
|
|
|
|
|
|
1677
|
|
|
|
|
|
|
# variable |
1678
|
167
|
|
|
|
|
109
|
my ($ampm); |
1679
|
|
|
|
|
|
|
|
1680
|
|
|
|
|
|
|
# calculate ampm, which is needed in most results from here down |
1681
|
167
|
100
|
|
|
|
339
|
$ampm = ($dt->hour >= 12) ? 'pm' : 'am'; |
1682
|
|
|
|
|
|
|
|
1683
|
|
|
|
|
|
|
# am/pm |
1684
|
167
|
100
|
100
|
|
|
962
|
if ( ($key eq 'ampm') || ($key eq 'ampmlc') ) |
1685
|
45
|
|
|
|
|
106
|
{ return $ampm } |
1686
|
|
|
|
|
|
|
|
1687
|
|
|
|
|
|
|
# AM/PM uppercase |
1688
|
122
|
100
|
|
|
|
174
|
if ($key eq 'ampmuc') |
1689
|
45
|
|
|
|
|
124
|
{ return uc($ampm) } |
1690
|
|
|
|
|
|
|
|
1691
|
|
|
|
|
|
|
# variable |
1692
|
77
|
|
|
|
|
46
|
my ($ampmhour); |
1693
|
|
|
|
|
|
|
|
1694
|
|
|
|
|
|
|
# calculate ampmhour, which is needed from here down |
1695
|
77
|
100
|
66
|
|
|
122
|
if ( ($dt->hour == 0) || ($dt->hour == 12) ) |
|
|
50
|
|
|
|
|
|
1696
|
2
|
|
|
|
|
18
|
{ $ampmhour = 12 } |
1697
|
|
|
|
|
|
|
elsif ($dt->hour > 12) |
1698
|
0
|
|
|
|
|
0
|
{ $ampmhour = $dt->hour - 12 } |
1699
|
|
|
|
|
|
|
else |
1700
|
75
|
|
|
|
|
715
|
{ $ampmhour = $dt->hour } |
1701
|
|
|
|
|
|
|
|
1702
|
|
|
|
|
|
|
# am/pm hour |
1703
|
77
|
100
|
|
|
|
240
|
if ($key eq 'ampmhour') |
1704
|
60
|
|
|
|
|
72
|
{ return zeropad_2($ampmhour) } |
1705
|
|
|
|
|
|
|
|
1706
|
|
|
|
|
|
|
# hour and minute with ampm |
1707
|
17
|
50
|
33
|
|
|
50
|
if ( |
1708
|
|
|
|
|
|
|
($key eq 'clocktime') || |
1709
|
|
|
|
|
|
|
($key eq 'clocktimestrict') |
1710
|
|
|
|
|
|
|
) { |
1711
|
|
|
|
|
|
|
|
1712
|
|
|
|
|
|
|
return |
1713
|
17
|
|
|
|
|
56
|
$ampmhour . ':' . |
1714
|
|
|
|
|
|
|
zeropad_2($dt->minute) . ' ' . |
1715
|
|
|
|
|
|
|
$ampm; |
1716
|
|
|
|
|
|
|
} |
1717
|
|
|
|
|
|
|
|
1718
|
|
|
|
|
|
|
# tz |
1719
|
0
|
0
|
|
|
|
0
|
if ( $key eq 'tz' ) { |
1720
|
0
|
|
|
|
|
0
|
return $dt->time_zone_short_name; |
1721
|
|
|
|
|
|
|
} |
1722
|
|
|
|
|
|
|
|
1723
|
|
|
|
|
|
|
# olson |
1724
|
0
|
0
|
|
|
|
0
|
if ( $key eq 'olson' ) { |
1725
|
0
|
|
|
|
|
0
|
return $dt->time_zone_long_name; |
1726
|
|
|
|
|
|
|
} |
1727
|
|
|
|
|
|
|
|
1728
|
|
|
|
|
|
|
# else we don't know what property is needed |
1729
|
0
|
|
|
|
|
0
|
return $eztied->warn("unknown-format: do not know this format: $orgkey"); |
1730
|
|
|
|
|
|
|
} |
1731
|
|
|
|
|
|
|
# |
1732
|
|
|
|
|
|
|
# FETCH |
1733
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1734
|
|
|
|
|
|
|
|
1735
|
|
|
|
|
|
|
|
1736
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1737
|
|
|
|
|
|
|
# warn |
1738
|
|
|
|
|
|
|
# |
1739
|
|
|
|
|
|
|
sub warn { |
1740
|
0
|
|
|
0
|
|
0
|
my $eztied = shift; |
1741
|
0
|
0
|
|
|
|
0
|
my $level = defined($eztied->{'warnings'}) ? $eztied->{'warnings'} : $Date::EzDate2::default_warning; |
1742
|
|
|
|
|
|
|
|
1743
|
|
|
|
|
|
|
# TESTING |
1744
|
|
|
|
|
|
|
# println subname(); ##i |
1745
|
|
|
|
|
|
|
|
1746
|
|
|
|
|
|
|
# if no level, return undef |
1747
|
0
|
0
|
|
|
|
0
|
$level or return undef; |
1748
|
|
|
|
|
|
|
|
1749
|
0
|
0
|
|
|
|
0
|
if ($level == WARN_STDERR) { |
1750
|
|
|
|
|
|
|
# showstack(); |
1751
|
0
|
|
|
|
|
0
|
carp 'WARNING: ', @_; |
1752
|
0
|
|
|
|
|
0
|
return undef; |
1753
|
|
|
|
|
|
|
} |
1754
|
|
|
|
|
|
|
|
1755
|
|
|
|
|
|
|
# croak |
1756
|
0
|
|
|
|
|
0
|
croak @_; |
1757
|
|
|
|
|
|
|
} |
1758
|
|
|
|
|
|
|
# |
1759
|
|
|
|
|
|
|
# warn |
1760
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1761
|
|
|
|
|
|
|
|
1762
|
|
|
|
|
|
|
|
1763
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1764
|
|
|
|
|
|
|
# get_alias |
1765
|
|
|
|
|
|
|
# |
1766
|
|
|
|
|
|
|
sub get_alias { |
1767
|
1970
|
|
|
1970
|
|
1861
|
my ($eztied, $key, %opts) = @_; |
1768
|
|
|
|
|
|
|
|
1769
|
|
|
|
|
|
|
# normalize |
1770
|
1970
|
100
|
|
|
|
3806
|
unless ($key =~ m|[\{\%]|) { |
1771
|
1352
|
|
|
|
|
1690
|
$key =~ s|\s||g; |
1772
|
1352
|
|
|
|
|
1300
|
$key = lc($key); |
1773
|
|
|
|
|
|
|
|
1774
|
|
|
|
|
|
|
# strip "nozero" if that option was sent |
1775
|
1352
|
100
|
|
|
|
1969
|
$opts{'strip_no_zero'} and $key =~ s|nozero||g; |
1776
|
|
|
|
|
|
|
} |
1777
|
|
|
|
|
|
|
|
1778
|
|
|
|
|
|
|
# if this key has an alias |
1779
|
1970
|
100
|
|
|
|
2839
|
if (exists $PCodes{$key}) |
1780
|
604
|
|
|
|
|
1010
|
{return $eztied->get_alias($PCodes{$key}, %opts)} |
1781
|
|
|
|
|
|
|
|
1782
|
|
|
|
|
|
|
# if this is a named format |
1783
|
1366
|
100
|
|
|
|
1817
|
if (exists $eztied->{'formats'}->{$key}) |
1784
|
7
|
|
|
|
|
14
|
{return $eztied->{'formats'}->{$key}} |
1785
|
|
|
|
|
|
|
|
1786
|
1359
|
|
|
|
|
2044
|
return $key; |
1787
|
|
|
|
|
|
|
} |
1788
|
|
|
|
|
|
|
# |
1789
|
|
|
|
|
|
|
# get_alias |
1790
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1791
|
|
|
|
|
|
|
|
1792
|
|
|
|
|
|
|
|
1793
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1794
|
|
|
|
|
|
|
# ym, ymd |
1795
|
|
|
|
|
|
|
# |
1796
|
|
|
|
|
|
|
sub ym { |
1797
|
0
|
|
|
0
|
|
0
|
my ($eztied) = @_; |
1798
|
0
|
|
|
|
|
0
|
return @$eztied{qw{year monthnum}}; |
1799
|
|
|
|
|
|
|
} |
1800
|
|
|
|
|
|
|
|
1801
|
|
|
|
|
|
|
sub ymd { |
1802
|
0
|
|
|
0
|
|
0
|
my ($eztied) = @_; |
1803
|
0
|
|
|
|
|
0
|
return @$eztied{qw{year monthnum dayofmonth}}; |
1804
|
|
|
|
|
|
|
} |
1805
|
|
|
|
|
|
|
# |
1806
|
|
|
|
|
|
|
# ym, ymd |
1807
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1808
|
|
|
|
|
|
|
|
1809
|
|
|
|
|
|
|
|
1810
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1811
|
|
|
|
|
|
|
# next_month |
1812
|
|
|
|
|
|
|
# |
1813
|
|
|
|
|
|
|
sub next_month { |
1814
|
3
|
|
|
3
|
|
4
|
my ($eztied, $count) = @_; |
1815
|
|
|
|
|
|
|
|
1816
|
|
|
|
|
|
|
# TESTING |
1817
|
|
|
|
|
|
|
# println subname(); ##i |
1818
|
|
|
|
|
|
|
|
1819
|
|
|
|
|
|
|
# add months and return |
1820
|
3
|
|
|
|
|
7
|
return $eztied->{'dt'}->add(months => $count, end_of_month=>'limit'); |
1821
|
|
|
|
|
|
|
} |
1822
|
|
|
|
|
|
|
# |
1823
|
|
|
|
|
|
|
# next_month |
1824
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1825
|
|
|
|
|
|
|
|
1826
|
|
|
|
|
|
|
|
1827
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1828
|
|
|
|
|
|
|
# DELETE |
1829
|
|
|
|
|
|
|
# |
1830
|
|
|
|
|
|
|
sub DELETE { |
1831
|
0
|
|
|
0
|
|
|
my ($eztied, $key) = @_; |
1832
|
|
|
|
|
|
|
|
1833
|
|
|
|
|
|
|
# normalize key |
1834
|
0
|
|
|
|
|
|
$key =~ s|\s||gs; |
1835
|
0
|
|
|
|
|
|
$key = lc($key); |
1836
|
|
|
|
|
|
|
|
1837
|
|
|
|
|
|
|
# delete from formats, but not properties |
1838
|
0
|
|
|
|
|
|
return delete $eztied->{'formats'}->{$key}; |
1839
|
|
|
|
|
|
|
} |
1840
|
|
|
|
|
|
|
# |
1841
|
|
|
|
|
|
|
# DELETE |
1842
|
|
|
|
|
|
|
#------------------------------------------------------------------------------ |
1843
|
|
|
|
|
|
|
|
1844
|
|
|
|
|
|
|
# |
1845
|
|
|
|
|
|
|
# Date::EzDate2::Tie |
1846
|
|
|
|
|
|
|
############################################################################### |
1847
|
|
|
|
|
|
|
|
1848
|
|
|
|
|
|
|
|
1849
|
|
|
|
|
|
|
# return true |
1850
|
|
|
|
|
|
|
1; |
1851
|
|
|
|
|
|
|
|
1852
|
|
|
|
|
|
|
__END__ |