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