1#!./perl
2
3use strict;
4use warnings;
5
6use Config;
7use Test::More 0.96;
8use Time::Local qw(
9    timegm
10    timelocal
11    timegm_modern
12    timelocal_modern
13    timegm_nocheck
14    timelocal_nocheck
15    timegm_posix
16    timelocal_posix
17);
18
19my @local_subs = qw(
20    timelocal
21    timelocal_modern
22    timelocal_posix
23    timelocal_nocheck
24);
25
26my @gm_subs = qw(
27    timegm
28    timegm_modern
29    timegm_posix
30    timegm_nocheck
31);
32
33# Use 3 days before the start of the epoch because with Borland on
34# Win32 it will work for -3600 _if_ your time zone is +01:00 (or
35# greater).
36my $neg_epoch_ok
37    = $^O eq 'VMS' ? 0 : defined( ( localtime(-259200) )[0] ) ? 1 : 0;
38
39my $large_epoch_ok = eval { ( gmtime 2**40 )[5] == 34912 };
40
41subtest( 'valid times',            \&_test_valid_times );
42subtest( 'diff between two calls', \&_test_diff_between_two_calls );
43subtest(
44    'DST transition bug - https://rt.perl.org/Ticket/Display.html?id=19393',
45    \&_test_dst_transition_bug,
46);
47subtest( 'Time::Local::_is_leap_year', \&_test_is_leap_year );
48subtest( 'negative epochs',            \&_test_negative_epochs );
49subtest( 'large epoch values',         \&_test_large_epoch_values );
50subtest( '2-digit years',              \&_test_2_digit_years );
51subtest( 'invalid values',             \&_test_invalid_values );
52
53sub _test_valid_times {
54    my %tests = (
55        'simple times' => [
56            [ 1970, 1,  2,  0,  0,  0 ],
57            [ 1980, 2,  28, 12, 0,  0 ],
58            [ 1980, 2,  29, 12, 0,  0 ],
59            [ 1999, 12, 31, 23, 59, 59 ],
60            [ 2000, 1,  1,  0,  0,  0 ],
61            [ 2010, 10, 12, 14, 13, 12 ],
62        ],
63        'leap days' => [
64            [ 2020, 2, 29, 12, 59, 59 ],
65            [ 2030, 7, 4,  17, 7,  6 ],
66        ],
67        'non-integer seconds' => [
68            [ 2010, 10, 12, 14, 13, 12.1 ],
69            [ 2010, 10, 12, 14, 13, 59.1 ],
70        ],
71    );
72
73    # The following test fails on a surprising number of systems
74    # so it is commented out. The end of the Epoch for a 32-bit signed
75    # implementation of time_t should be Jan 19, 2038  03:14:07 UTC.
76    #  [2038,  1, 17, 23, 59, 59],     # last full day in any tz
77
78    # more than 2**31 time_t - requires a 64bit safe localtime/gmtime
79    $tests{'greater than 2**31 seconds'} = [ [ 2258, 8, 11, 1, 49, 17 ] ]
80        if $] >= 5.012000;
81
82    # use vmsish 'time' makes for oddness around the Unix epoch
83    $tests{'simple times'}[0][2]++
84        if $^O eq 'VMS';
85
86    $tests{'negative epoch'} = [
87        [ 1969, 12, 31, 16, 59, 59 ],
88        [ 1950, 4,  12, 9,  30, 31 ],
89    ] if $neg_epoch_ok;
90
91    for my $group ( sort keys %tests ) {
92        subtest(
93            $group,
94            sub { _test_group( $tests{$group} ) },
95        );
96    }
97}
98
99sub _test_group {
100    my $group = shift;
101
102    for my $vals ( @{$group} ) {
103        my ( $year, $mon, $mday, $hour, $min, $sec ) = @{$vals};
104        $mon--;
105
106        # 1970 test on VOS fails
107        next if $^O eq 'vos' && $year == 1970;
108
109        for my $sub (@local_subs) {
110            my $y = $year;
111            $y -= 1900 if $sub =~ /posix/;
112            my $time = __PACKAGE__->can($sub)
113                ->( $sec, $min, $hour, $mday, $mon, $y );
114
115            my @lt = localtime($time);
116            is_deeply(
117                {
118                    second => $lt[0],
119                    minute => $lt[1],
120                    hour   => $lt[2],
121                    day    => $lt[3],
122                    month  => $lt[4],
123                    year   => $lt[5],
124                },
125                {
126                    second => int($sec),
127                    minute => $min,
128                    hour   => $hour,
129                    day    => $mday,
130                    month  => $mon,
131                    year   => $year - 1900,
132                },
133                "$sub( $sec, $min, $hour, $mday, $mon, $y )"
134            );
135        }
136
137        for my $sub (@gm_subs) {
138            my $y = $year;
139            $y -= 1900 if $sub =~ /posix/;
140            my $time = __PACKAGE__->can($sub)
141                ->( $sec, $min, $hour, $mday, $mon, $y );
142
143            my @gt = gmtime($time);
144            is_deeply(
145                {
146                    second => $gt[0],
147                    minute => $gt[1],
148                    hour   => $gt[2],
149                    day    => $gt[3],
150                    month  => $gt[4],
151                    year   => $gt[5],
152                },
153                {
154                    second => int($sec),
155                    minute => $min,
156                    hour   => $hour,
157                    day    => $mday,
158                    month  => $mon,
159                    year   => $year - 1900,
160                },
161                "$sub( $sec, $min, $hour, $mday, $mon, $y )"
162            );
163        }
164    }
165}
166
167sub _test_diff_between_two_calls {
168    for my $sub (@local_subs) {
169        subtest(
170            $sub,
171            sub {
172                my $year = 1990;
173                $year -= 1900 if $sub =~ /posix/;
174                my $sub_ref = __PACKAGE__->can($sub);
175                is(
176                          $sub_ref->( 0, 0, 1, 1, 0, $year )
177                        - $sub_ref->( 0, 0, 0, 1, 0, $year ),
178                    3600,
179                    'one hour difference between two calls'
180                );
181
182                is(
183                          $sub_ref->( 1, 2, 3, 1, 0, $year + 1 )
184                        - $sub_ref->( 1, 2, 3, 31, 11, $year ),
185                    24 * 3600,
186                    'one day difference between two calls across year boundary',
187                );
188            },
189        );
190    }
191
192    for my $sub (@gm_subs) {
193        subtest(
194            $sub,
195            sub {
196                my $year = 1980;
197                $year -= 1900 if $sub =~ /posix/;
198                my $sub_ref = __PACKAGE__->can($sub);
199
200                # Diff beween Jan 1, 1980 and Mar 1, 1980 = (31 + 29 = 60 days)
201                is(
202                          $sub_ref->( 0, 0, 0, 1, 2, 80 )
203                        - $sub_ref->( 0, 0, 0, 1, 0, 80 ),
204                    60 * 24 * 3600,
205                    '60 day difference between two calls',
206                );
207            },
208        );
209    }
210}
211
212sub _test_dst_transition_bug {
213    for my $sub (@local_subs) {
214        subtest(
215            $sub,
216            sub {
217                my $year = 2002;
218                $year -= 2002 if $sub =~ /posix/;
219                my $sub_ref = __PACKAGE__->can($sub);
220
221                # At a DST transition, the clock skips forward, eg from
222                # 01:59:59 to 03:00:00. In this case, 02:00:00 is an
223                # invalid time, and should be treated like 03:00:00 rather
224                # than 01:00:00 - negative zone offsets used to do the
225                # latter.
226                my $hour
227                    = ( localtime( $sub_ref->( 0, 0, 2, 7, 3, 102 ) ) )[2];
228
229                # testers in US/Pacific should get 3,
230                # other testers should get 2
231                ok( $hour == 2 || $hour == 3, 'hour should be 2 or 3' );
232            },
233        );
234    }
235}
236
237sub _test_is_leap_year {
238    my @years = (
239        [ 1900 => 0 ],
240        [ 1947 => 0 ],
241        [ 1996 => 1 ],
242        [ 2000 => 1 ],
243        [ 2100 => 0 ],
244    );
245
246    for my $p (@years) {
247        my ( $year, $is_leap_year ) = @$p;
248
249        my $string = $is_leap_year ? 'is' : 'is not';
250        ## no critic (Subroutines::ProtectPrivateSubs)
251        is(
252            Time::Local::_is_leap_year($year), $is_leap_year,
253            "$year $string a leap year"
254        );
255    }
256}
257
258sub _test_negative_epochs {
259    plan skip_all => 'this platform does not support negative epochs.'
260        unless $neg_epoch_ok;
261
262    for my $sub (@gm_subs) {
263        subtest(
264            $sub,
265            sub {
266                my $year_mod = $sub =~ /posix/ ? -1900 : 0;
267                my $sub_ref  = __PACKAGE__->can($sub);
268
269                unless ( $sub =~ /nocheck/ ) {
270                    local $@ = undef;
271                    eval { $sub_ref->( 0, 0, 0, 29, 1, 1900 + $year_mod ); };
272                    like(
273                        $@, qr/Day '29' out of range 1\.\.28/,
274                        'does not accept leap day in 1900'
275                    );
276
277                    local $@ = undef;
278                    eval { $sub_ref->( 0, 0, 0, 29, 1, 200 + $year_mod ) };
279                    like(
280                        $@, qr/Day '29' out of range 1\.\.28/,
281                        'does not accept leap day in 2100 (year passed as 200)'
282                    );
283                }
284
285                local $@ = undef;
286                eval { $sub_ref->( 0, 0, 0, 29, 1, 0 + $year_mod ) };
287                is(
288                    $@, q{},
289                    'no error with leap day of 2000 (year passed as 0)'
290                );
291
292                local $@ = undef;
293                eval { $sub_ref->( 0, 0, 0, 29, 1, 1904 + $year_mod ) };
294                is( $@, q{}, 'no error with leap day of 1904' );
295
296                local $@ = undef;
297                eval { $sub_ref->( 0, 0, 0, 29, 1, 4 + $year_mod ) };
298                is(
299                    $@, q{},
300                    'no error with leap day of 2004 (year passed as 4)'
301                );
302
303                local $@ = undef;
304                eval { $sub_ref->( 0, 0, 0, 29, 1, 96 + $year_mod ) };
305                is(
306                    $@, q{},
307                    'no error with leap day of 1996 (year passed as 96)'
308                );
309            },
310        );
311    }
312}
313
314sub _test_large_epoch_values {
315    plan skip_all => 'These tests require support for large epoch values'
316        unless $large_epoch_ok;
317
318    for my $sub (@gm_subs) {
319        subtest(
320            $sub,
321            sub {
322                my $year_mod = $sub =~ /posix/ ? -1900 : 0;
323                my $sub_ref  = __PACKAGE__->can($sub);
324
325                is(
326                    $sub_ref->( 8, 14, 3, 19, 0, 2038 + $year_mod ),
327                    2**31,
328                    'can call with 2**31 epoch seconds',
329                );
330                is(
331                    $sub_ref->( 16, 28, 6, 7, 1, 2106 + $year_mod ),
332                    2**32,
333                    'can call with 2**32 epoch seconds (on a 64-bit system)',
334                );
335                is(
336                    $sub_ref->( 16, 36, 0, 20, 1, 36812 + $year_mod ),
337                    2**40,
338                    'can call with 2**40 epoch seconds (on a 64-bit system)',
339                );
340            },
341        );
342    }
343}
344
345sub _test_2_digit_years {
346    my $current_year = ( localtime() )[5];
347    my $pre_break    = ( $current_year + 49 ) - 100;
348    my $break        = ( $current_year + 50 ) - 100;
349    my $post_break   = ( $current_year + 51 ) - 100;
350
351    subtest(
352        'legacy year munging',
353        sub {
354            plan skip_all => 'Requires support for an large epoch values'
355                unless $large_epoch_ok;
356
357            is(
358                (
359                    ( localtime( timelocal( 0, 0, 0, 1, 1, $pre_break ) ) )[5]
360                ),
361                $pre_break + 100,
362                "year $pre_break is treated as next century",
363            );
364            is(
365                ( ( localtime( timelocal( 0, 0, 0, 1, 1, $break ) ) )[5] ),
366                $break + 100,
367                "year $break is treated as next century",
368            );
369            is(
370                (
371                    ( localtime( timelocal( 0, 0, 0, 1, 1, $post_break ) ) )
372                    [5]
373                ),
374                $post_break,
375                "year $post_break is treated as current century",
376            );
377        }
378    );
379
380    subtest(
381        'modern',
382        sub {
383            plan skip_all =>
384                'Requires negative epoch support and large epoch support'
385                unless $neg_epoch_ok && $large_epoch_ok;
386
387            is(
388                (
389                    (
390                        localtime(
391                            timelocal_modern( 0, 0, 0, 1, 1, $pre_break )
392                        )
393                    )[5]
394                ) + 1900,
395                $pre_break,
396                "year $pre_break is treated as year $pre_break",
397            );
398            is(
399                (
400                    (
401                        localtime(
402                            timelocal_modern( 0, 0, 0, 1, 1, $break )
403                        )
404                    )[5]
405                ) + 1900,
406                $break,
407                "year $break is treated as year $break",
408            );
409            is(
410                (
411                    (
412                        localtime(
413                            timelocal_modern( 0, 0, 0, 1, 1, $post_break )
414                        )
415                    )[5]
416                ) + 1900,
417                $post_break,
418                "year $post_break is treated as year $post_break",
419            );
420        },
421    );
422}
423
424sub _test_invalid_values {
425    my %bad = (
426        'month > bounds'  => [ 1995, 13, 1,  1,  1,  1 ],
427        'day > bounds'    => [ 1995, 2,  30, 1,  1,  1 ],
428        'hour > bounds'   => [ 1995, 2,  10, 25, 1,  1 ],
429        'minute > bounds' => [ 1995, 2,  10, 1,  60, 1 ],
430        'second > bounds' => [ 1995, 2,  10, 1,  1,  60 ],
431        'month < bounds'  => [ 1995, -1, 1,  1,  1,  1 ],
432        'day < bounds'    => [ 1995, 2,  -1, 1,  1,  1 ],
433        'hour < bounds'   => [ 1995, 2,  10, -1, 1,  1 ],
434        'minute < bounds' => [ 1995, 2,  10, 1,  -1, 1 ],
435        'second < bounds' => [ 1995, 2,  10, 1,  1,  -1 ],
436    );
437
438    for my $sub ( grep { !/nocheck/ } @local_subs, @gm_subs ) {
439        subtest(
440            $sub,
441            sub {
442                for my $key ( sort keys %bad ) {
443                    my ( $year, $mon, $mday, $hour, $min, $sec )
444                        = @{ $bad{$key} };
445                    $mon--;
446
447                    local $@ = undef;
448                    eval {
449                        __PACKAGE__->can($sub)
450                            ->( $sec, $min, $hour, $mday, $mon, $year );
451                    };
452
453                    like(
454                        $@, qr/.*out of range.*/,
455                        "$key - @{ $bad{$key} }"
456                    );
457                }
458            },
459        );
460    }
461
462    for my $sub ( grep {/nocheck/} @local_subs, @gm_subs ) {
463        subtest(
464            $sub,
465            sub {
466                for my $key ( sort keys %bad ) {
467                    local $@ = q{};
468                    eval { __PACKAGE__->can($sub)->( @{ $bad{$key} } ); };
469                    is(
470                        $@, q{},
471                        "$key - @{ $bad{$key} } - no exception with checks disabled"
472                    );
473                }
474            },
475        );
476    }
477}
478
479done_testing();
480