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