/tags/v2-104/lib/site/DateTime.pm

# · Perl · 2337 lines · 1701 code · 522 blank · 114 comment · 146 complexity · 313d3930f39bfc2a27110ecca317ec65 MD5 · raw file

Large files are truncated click here to view the full file

  1. package DateTime;
  2. use strict;
  3. use vars qw($VERSION);
  4. use Carp;
  5. use DateTime::Helpers;
  6. BEGIN
  7. {
  8. $VERSION = '0.39';
  9. my $loaded = 0;
  10. unless ( $ENV{PERL_DATETIME_PP} )
  11. {
  12. eval
  13. {
  14. if ( $] >= 5.006 )
  15. {
  16. require XSLoader;
  17. XSLoader::load( 'DateTime', $DateTime::VERSION );
  18. }
  19. else
  20. {
  21. require DynaLoader;
  22. @DateTime::ISA = 'DynaLoader';
  23. DateTime->bootstrap( $DateTime::VERSION );
  24. }
  25. $DateTime::IsPurePerl = 0;
  26. };
  27. die $@ if $@ && $@ !~ /object version|loadable object/;
  28. $loaded = 1 unless $@;
  29. }
  30. if ($loaded)
  31. {
  32. require DateTimePPExtra
  33. unless defined &DateTime::_normalize_tai_seconds;
  34. }
  35. else
  36. {
  37. require DateTimePP;
  38. }
  39. }
  40. use DateTime::Duration;
  41. use DateTime::Locale;
  42. use DateTime::TimeZone 0.38;
  43. use Params::Validate qw( validate validate_pos SCALAR BOOLEAN HASHREF OBJECT );
  44. use Time::Local ();
  45. # for some reason, overloading doesn't work unless fallback is listed
  46. # early.
  47. #
  48. # 3rd parameter ( $_[2] ) means the parameters are 'reversed'.
  49. # see: "Calling conventions for binary operations" in overload docs.
  50. #
  51. use overload ( 'fallback' => 1,
  52. '<=>' => '_compare_overload',
  53. 'cmp' => '_compare_overload',
  54. '""' => '_stringify',
  55. '-' => '_subtract_overload',
  56. '+' => '_add_overload',
  57. 'eq' => '_string_equals_overload',
  58. 'ne' => '_string_not_equals_overload',
  59. );
  60. # Have to load this after overloading is defined, after BEGIN blocks
  61. # or else weird crashes ensue
  62. require DateTime::Infinite;
  63. use constant MAX_NANOSECONDS => 1_000_000_000; # 1E9 = almost 32 bits
  64. use constant INFINITY => (9 ** 9 ** 9);
  65. use constant NEG_INFINITY => -1 * (9 ** 9 ** 9);
  66. use constant NAN => INFINITY - INFINITY;
  67. use constant SECONDS_PER_DAY => 86400;
  68. my( @MonthLengths, @LeapYearMonthLengths );
  69. BEGIN
  70. {
  71. @MonthLengths =
  72. ( 31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 );
  73. @LeapYearMonthLengths = @MonthLengths;
  74. $LeapYearMonthLengths[1]++;
  75. }
  76. {
  77. # I'd rather use Class::Data::Inheritable for this, but there's no
  78. # way to add the module-loading behavior to an accessor it
  79. # creates, despite what its docs say!
  80. my $DefaultLocale;
  81. sub DefaultLocale
  82. {
  83. my $class = shift;
  84. if (@_)
  85. {
  86. my $lang = shift;
  87. DateTime::Locale->load($lang);
  88. $DefaultLocale = $lang;
  89. }
  90. return $DefaultLocale;
  91. }
  92. # backwards compat
  93. *DefaultLanguage = \&DefaultLocale;
  94. }
  95. __PACKAGE__->DefaultLocale('en_US');
  96. my $BasicValidate =
  97. { year => { type => SCALAR },
  98. month => { type => SCALAR, default => 1,
  99. callbacks =>
  100. { 'is between 1 and 12' =>
  101. sub { $_[0] >= 1 && $_[0] <= 12 }
  102. },
  103. },
  104. day => { type => SCALAR, default => 1,
  105. callbacks =>
  106. { 'is a possible valid day of month' =>
  107. sub { $_[0] >= 1 && $_[0] <= 31 }
  108. },
  109. },
  110. hour => { type => SCALAR, default => 0,
  111. callbacks =>
  112. { 'is between 0 and 23' =>
  113. sub { $_[0] >= 0 && $_[0] <= 23 },
  114. },
  115. },
  116. minute => { type => SCALAR, default => 0,
  117. callbacks =>
  118. { 'is between 0 and 59' =>
  119. sub { $_[0] >= 0 && $_[0] <= 59 },
  120. },
  121. },
  122. second => { type => SCALAR, default => 0,
  123. callbacks =>
  124. { 'is between 0 and 61' =>
  125. sub { $_[0] >= 0 && $_[0] <= 61 },
  126. },
  127. },
  128. nanosecond => { type => SCALAR, default => 0,
  129. callbacks =>
  130. { 'cannot be negative' =>
  131. sub { $_[0] >= 0 },
  132. }
  133. },
  134. locale => { type => SCALAR | OBJECT,
  135. default => undef },
  136. language => { type => SCALAR | OBJECT,
  137. optional => 1 },
  138. };
  139. my $NewValidate =
  140. { %$BasicValidate,
  141. time_zone => { type => SCALAR | OBJECT,
  142. default => 'floating' },
  143. formatter => { type => SCALAR | OBJECT, can => 'format_datetime', optional => 1 },
  144. };
  145. sub new
  146. {
  147. my $class = shift;
  148. my %p = validate( @_, $NewValidate );
  149. Carp::croak( "Invalid day of month (day = $p{day} - month = $p{month})\n" )
  150. if $p{day} > $class->_month_length( $p{year}, $p{month} );
  151. my $self = bless {}, $class;
  152. $p{locale} = delete $p{language} if exists $p{language};
  153. $p{locale} = $class->DefaultLocale unless defined $p{locale};
  154. if ( ref $p{locale} )
  155. {
  156. $self->{locale} = $p{locale};
  157. }
  158. else
  159. {
  160. $self->{locale} = DateTime::Locale->load( $p{locale} );
  161. }
  162. $self->{tz} =
  163. ( ref $p{time_zone} ?
  164. $p{time_zone} :
  165. DateTime::TimeZone->new( name => $p{time_zone} )
  166. );
  167. $self->{local_rd_days} =
  168. $class->_ymd2rd( @p{ qw( year month day ) } );
  169. $self->{local_rd_secs} =
  170. $class->_time_as_seconds( @p{ qw( hour minute second ) } );
  171. $self->{offset_modifier} = 0;
  172. $self->{rd_nanosecs} = $p{nanosecond};
  173. $self->{formatter} = $p{formatter};
  174. $self->_normalize_nanoseconds( $self->{local_rd_secs}, $self->{rd_nanosecs} );
  175. # Set this explicitly since it can't be calculated accurately
  176. # without knowing our time zone offset, and it's possible that the
  177. # offset can't be calculated without having at least a rough guess
  178. # of the datetime's year. This year need not be correct, as long
  179. # as its equal or greater to the correct number, so we fudge by
  180. # adding one to the local year given to the constructor.
  181. $self->{utc_year} = $p{year} + 1;
  182. $self->_calc_utc_rd;
  183. $self->_handle_offset_modifier( $p{second} );
  184. $self->_calc_local_rd;
  185. if ( $p{second} > 59 )
  186. {
  187. if ( $self->{tz}->is_floating ||
  188. # If true, this means that the actual calculated leap
  189. # second does not occur in the second given to new()
  190. ( $self->{utc_rd_secs} - 86399
  191. <
  192. $p{second} - 59 )
  193. )
  194. {
  195. Carp::croak( "Invalid second value ($p{second})\n" );
  196. }
  197. }
  198. return $self;
  199. }
  200. sub _handle_offset_modifier
  201. {
  202. my $self = shift;
  203. $self->{offset_modifier} = 0;
  204. return if $self->{tz}->is_floating;
  205. my $second = shift;
  206. my $utc_is_valid = shift;
  207. my $utc_rd_days = $self->{utc_rd_days};
  208. my $offset = $utc_is_valid ? $self->offset : $self->_offset_for_local_datetime;
  209. if ( $offset >= 0
  210. && $self->{local_rd_secs} >= $offset
  211. )
  212. {
  213. if ( $second < 60 && $offset > 0 )
  214. {
  215. $self->{offset_modifier} =
  216. $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY;
  217. $self->{local_rd_secs} += $self->{offset_modifier};
  218. }
  219. elsif ( $second == 60
  220. &&
  221. ( ( $self->{local_rd_secs} == $offset
  222. && $offset > 0 )
  223. ||
  224. ( $offset == 0
  225. && $self->{local_rd_secs} > 86399 ) )
  226. )
  227. {
  228. my $mod = $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY;
  229. unless ( $mod == 0 )
  230. {
  231. $self->{utc_rd_secs} -= $mod;
  232. $self->_normalize_seconds;
  233. }
  234. }
  235. }
  236. elsif ( $offset < 0
  237. && $self->{local_rd_secs} >= SECONDS_PER_DAY + $offset )
  238. {
  239. if ( $second < 60 )
  240. {
  241. $self->{offset_modifier} =
  242. $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY;
  243. $self->{local_rd_secs} += $self->{offset_modifier};
  244. }
  245. elsif ( $second == 60 && $self->{local_rd_secs} == SECONDS_PER_DAY + $offset )
  246. {
  247. my $mod = $self->_day_length( $utc_rd_days - 1 ) - SECONDS_PER_DAY;
  248. unless ( $mod == 0 )
  249. {
  250. $self->{utc_rd_secs} -= $mod;
  251. $self->_normalize_seconds;
  252. }
  253. }
  254. }
  255. }
  256. sub _calc_utc_rd
  257. {
  258. my $self = shift;
  259. delete $self->{utc_c};
  260. if ( $self->{tz}->is_utc || $self->{tz}->is_floating )
  261. {
  262. $self->{utc_rd_days} = $self->{local_rd_days};
  263. $self->{utc_rd_secs} = $self->{local_rd_secs};
  264. }
  265. else
  266. {
  267. my $offset = $self->_offset_for_local_datetime;
  268. $offset += $self->{offset_modifier};
  269. $self->{utc_rd_days} = $self->{local_rd_days};
  270. $self->{utc_rd_secs} = $self->{local_rd_secs} - $offset;
  271. }
  272. # We account for leap seconds in the new() method and nowhere else
  273. # except date math.
  274. $self->_normalize_tai_seconds( $self->{utc_rd_days}, $self->{utc_rd_secs} );
  275. }
  276. sub _normalize_seconds
  277. {
  278. my $self = shift;
  279. return if $self->{utc_rd_secs} >= 0 && $self->{utc_rd_secs} <= 86399;
  280. if ( $self->{tz}->is_floating )
  281. {
  282. $self->_normalize_tai_seconds( $self->{utc_rd_days}, $self->{utc_rd_secs} );
  283. }
  284. else
  285. {
  286. $self->_normalize_leap_seconds( $self->{utc_rd_days}, $self->{utc_rd_secs} );
  287. }
  288. }
  289. sub _calc_local_rd
  290. {
  291. my $self = shift;
  292. delete $self->{local_c};
  293. # We must short circuit for UTC times or else we could end up with
  294. # loops between DateTime.pm and DateTime::TimeZone
  295. if ( $self->{tz}->is_utc || $self->{tz}->is_floating )
  296. {
  297. $self->{local_rd_days} = $self->{utc_rd_days};
  298. $self->{local_rd_secs} = $self->{utc_rd_secs};
  299. }
  300. else
  301. {
  302. my $offset = $self->offset;
  303. $self->{local_rd_days} = $self->{utc_rd_days};
  304. $self->{local_rd_secs} = $self->{utc_rd_secs} + $offset;
  305. # intentionally ignore leap seconds here
  306. $self->_normalize_tai_seconds( $self->{local_rd_days}, $self->{local_rd_secs} );
  307. $self->{local_rd_secs} += $self->{offset_modifier};
  308. }
  309. $self->_calc_local_components;
  310. }
  311. sub _calc_local_components
  312. {
  313. my $self = shift;
  314. @{ $self->{local_c} }{ qw( year month day day_of_week
  315. day_of_year quarter day_of_quarter) } =
  316. $self->_rd2ymd( $self->{local_rd_days}, 1 );
  317. @{ $self->{local_c} }{ qw( hour minute second ) } =
  318. $self->_seconds_as_components
  319. ( $self->{local_rd_secs}, $self->{utc_rd_secs}, $self->{offset_modifier} );
  320. }
  321. sub _calc_utc_components
  322. {
  323. my $self = shift;
  324. die "Cannot get UTC components before UTC RD has been calculated\n"
  325. unless defined $self->{utc_rd_days};
  326. @{ $self->{utc_c} }{ qw( year month day ) } =
  327. $self->_rd2ymd( $self->{utc_rd_days} );
  328. @{ $self->{utc_c} }{ qw( hour minute second ) } =
  329. $self->_seconds_as_components( $self->{utc_rd_secs} );
  330. }
  331. sub _utc_ymd
  332. {
  333. my $self = shift;
  334. $self->_calc_utc_components unless exists $self->{utc_c}{year};
  335. return @{ $self->{utc_c} }{ qw( year month day ) };
  336. }
  337. sub _utc_hms
  338. {
  339. my $self = shift;
  340. $self->_calc_utc_components unless exists $self->{utc_c}{hour};
  341. return @{ $self->{utc_c} }{ qw( hour minute second ) };
  342. }
  343. sub from_epoch
  344. {
  345. my $class = shift;
  346. my %p = validate( @_,
  347. { epoch => { type => SCALAR },
  348. locale => { type => SCALAR | OBJECT, optional => 1 },
  349. language => { type => SCALAR | OBJECT, optional => 1 },
  350. time_zone => { type => SCALAR | OBJECT, optional => 1 },
  351. formatter => { type => SCALAR | OBJECT, can => 'format_datetime',
  352. optional => 1 },
  353. }
  354. );
  355. my %args;
  356. # Because epoch may come from Time::HiRes
  357. my $fraction = $p{epoch} - int( $p{epoch} );
  358. $args{nanosecond} = int( $fraction * MAX_NANOSECONDS )
  359. if $fraction;
  360. # Note, for very large negative values this may give a blatantly
  361. # wrong answer.
  362. @args{ qw( second minute hour day month year ) } =
  363. ( gmtime( int delete $p{epoch} ) )[ 0..5 ];
  364. $args{year} += 1900;
  365. $args{month}++;
  366. my $self = $class->new( %p, %args, time_zone => 'UTC' );
  367. $self->set_time_zone( $p{time_zone} ) if exists $p{time_zone};
  368. return $self;
  369. }
  370. # use scalar time in case someone's loaded Time::Piece
  371. sub now { shift->from_epoch( epoch => (scalar time), @_ ) }
  372. sub today { shift->now(@_)->truncate( to => 'day' ) }
  373. sub from_object
  374. {
  375. my $class = shift;
  376. my %p = validate( @_,
  377. { object => { type => OBJECT,
  378. can => 'utc_rd_values',
  379. },
  380. locale => { type => SCALAR | OBJECT, optional => 1 },
  381. language => { type => SCALAR | OBJECT, optional => 1 },
  382. formatter => { type => SCALAR | OBJECT, can => 'format_datetime',
  383. optional => 1 },
  384. },
  385. );
  386. my $object = delete $p{object};
  387. my ( $rd_days, $rd_secs, $rd_nanosecs ) = $object->utc_rd_values;
  388. # A kludge because until all calendars are updated to return all
  389. # three values, $rd_nanosecs could be undef
  390. $rd_nanosecs ||= 0;
  391. # This is a big hack to let _seconds_as_components operate naively
  392. # on the given value. If the object _is_ on a leap second, we'll
  393. # add that to the generated seconds value later.
  394. my $leap_seconds = 0;
  395. if ( $object->can('time_zone') && ! $object->time_zone->is_floating
  396. && $rd_secs > 86399 && $rd_secs <= $class->_day_length($rd_days) )
  397. {
  398. $leap_seconds = $rd_secs - 86399;
  399. $rd_secs -= $leap_seconds;
  400. }
  401. my %args;
  402. @args{ qw( year month day ) } = $class->_rd2ymd($rd_days);
  403. @args{ qw( hour minute second ) } =
  404. $class->_seconds_as_components($rd_secs);
  405. $args{nanosecond} = $rd_nanosecs;
  406. $args{second} += $leap_seconds;
  407. my $new = $class->new( %p, %args, time_zone => 'UTC' );
  408. if ( $object->can('time_zone') )
  409. {
  410. $new->set_time_zone( $object->time_zone );
  411. }
  412. else
  413. {
  414. $new->set_time_zone( 'floating' );
  415. }
  416. return $new;
  417. }
  418. my $LastDayOfMonthValidate = { %$NewValidate };
  419. foreach ( keys %$LastDayOfMonthValidate )
  420. {
  421. my %copy = %{ $LastDayOfMonthValidate->{$_} };
  422. delete $copy{default};
  423. $copy{optional} = 1 unless $_ eq 'year' || $_ eq 'month';
  424. $LastDayOfMonthValidate->{$_} = \%copy;
  425. }
  426. sub last_day_of_month
  427. {
  428. my $class = shift;
  429. my %p = validate( @_, $LastDayOfMonthValidate );
  430. my $day = $class->_month_length( $p{year}, $p{month} );
  431. return $class->new( %p, day => $day );
  432. }
  433. sub _month_length
  434. {
  435. return ( $_[0]->_is_leap_year( $_[1] ) ?
  436. $LeapYearMonthLengths[ $_[2] - 1 ] :
  437. $MonthLengths[ $_[2] - 1 ]
  438. );
  439. }
  440. my $FromDayOfYearValidate = { %$NewValidate };
  441. foreach ( keys %$FromDayOfYearValidate )
  442. {
  443. next if $_ eq 'month' || $_ eq 'day';
  444. my %copy = %{ $FromDayOfYearValidate->{$_} };
  445. delete $copy{default};
  446. $copy{optional} = 1 unless $_ eq 'year' || $_ eq 'month';
  447. $FromDayOfYearValidate->{$_} = \%copy;
  448. }
  449. $FromDayOfYearValidate->{day_of_year} =
  450. { type => SCALAR,
  451. callbacks =>
  452. { 'is between 1 and 366' =>
  453. sub { $_[0] >= 1 && $_[0] <= 366 }
  454. }
  455. };
  456. sub from_day_of_year
  457. {
  458. my $class = shift;
  459. my %p = validate( @_, $FromDayOfYearValidate );
  460. my $is_leap_year = $class->_is_leap_year( $p{year} );
  461. Carp::croak( "$p{year} is not a leap year.\n" )
  462. if $p{day_of_year} == 366 && ! $is_leap_year;
  463. my $month = 1;
  464. my $day = delete $p{day_of_year};
  465. while ( $month <= 12 && $day > $class->_month_length( $p{year}, $month ) )
  466. {
  467. $day -= $class->_month_length( $p{year}, $month );
  468. $month++;
  469. }
  470. return DateTime->new( %p,
  471. month => $month,
  472. day => $day,
  473. );
  474. }
  475. sub formatter { $_[0]->{formatter} }
  476. sub clone { bless { %{ $_[0] } }, ref $_[0] }
  477. sub year { $_[0]->{local_c}{year} }
  478. sub ce_year { $_[0]->{local_c}{year} <= 0 ?
  479. $_[0]->{local_c}{year} - 1 :
  480. $_[0]->{local_c}{year} }
  481. sub era_name { $_[0]->{locale}->era_name( $_[0] ) }
  482. sub era_abbr { $_[0]->{locale}->era_abbreviation( $_[0] ) }
  483. # deprecated
  484. *era = \&era_abbr;
  485. sub christian_era { $_[0]->ce_year > 0 ? 'AD' : 'BC' }
  486. sub secular_era { $_[0]->ce_year > 0 ? 'CE' : 'BCE' }
  487. sub year_with_era { (abs $_[0]->ce_year) . $_[0]->era_abbr }
  488. sub year_with_christian_era { (abs $_[0]->ce_year) . $_[0]->christian_era }
  489. sub year_with_secular_era { (abs $_[0]->ce_year) . $_[0]->secular_era }
  490. sub month { $_[0]->{local_c}{month} }
  491. *mon = \&month;
  492. sub month_0 { $_[0]->{local_c}{month} - 1 };
  493. *mon_0 = \&month_0;
  494. sub month_name { $_[0]->{locale}->month_name( $_[0] ) }
  495. sub month_abbr { $_[0]->{locale}->month_abbreviation( $_[0] ) }
  496. sub day_of_month { $_[0]->{local_c}{day} }
  497. *day = \&day_of_month;
  498. *mday = \&day_of_month;
  499. sub weekday_of_month { use integer; ( ( $_[0]->day - 1 ) / 7 ) + 1 }
  500. sub quarter {$_[0]->{local_c}{quarter} };
  501. sub quarter_name { $_[0]->{locale}->quarter_name( $_[0] ) }
  502. sub quarter_abbr { $_[0]->{locale}->quarter_abbreviation( $_[0] ) }
  503. sub day_of_month_0 { $_[0]->{local_c}{day} - 1 }
  504. *day_0 = \&day_of_month_0;
  505. *mday_0 = \&day_of_month_0;
  506. sub day_of_week { $_[0]->{local_c}{day_of_week} }
  507. *wday = \&day_of_week;
  508. *dow = \&day_of_week;
  509. sub day_of_week_0 { $_[0]->{local_c}{day_of_week} - 1 }
  510. *wday_0 = \&day_of_week_0;
  511. *dow_0 = \&day_of_week_0;
  512. sub day_name { $_[0]->{locale}->day_name( $_[0] ) }
  513. sub day_abbr { $_[0]->{locale}->day_abbreviation( $_[0] ) }
  514. sub day_of_quarter { $_[0]->{local_c}{day_of_quarter} }
  515. *doq = \&day_of_quarter;
  516. sub day_of_quarter_0 { $_[0]->day_of_quarter - 1 }
  517. *doq_0 = \&day_of_quarter_0;
  518. sub day_of_year { $_[0]->{local_c}{day_of_year} }
  519. *doy = \&day_of_year;
  520. sub day_of_year_0 { $_[0]->{local_c}{day_of_year} - 1 }
  521. *doy_0 = \&day_of_year_0;
  522. sub ymd
  523. {
  524. my ( $self, $sep ) = @_;
  525. $sep = '-' unless defined $sep;
  526. return sprintf( "%0.4d%s%0.2d%s%0.2d",
  527. $self->year, $sep,
  528. $self->{local_c}{month}, $sep,
  529. $self->{local_c}{day} );
  530. }
  531. *date = \&ymd;
  532. sub mdy
  533. {
  534. my ( $self, $sep ) = @_;
  535. $sep = '-' unless defined $sep;
  536. return sprintf( "%0.2d%s%0.2d%s%0.4d",
  537. $self->{local_c}{month}, $sep,
  538. $self->{local_c}{day}, $sep,
  539. $self->year );
  540. }
  541. sub dmy
  542. {
  543. my ( $self, $sep ) = @_;
  544. $sep = '-' unless defined $sep;
  545. return sprintf( "%0.2d%s%0.2d%s%0.4d",
  546. $self->{local_c}{day}, $sep,
  547. $self->{local_c}{month}, $sep,
  548. $self->year );
  549. }
  550. sub hour { $_[0]->{local_c}{hour} }
  551. sub hour_1 { $_[0]->{local_c}{hour} + 1 }
  552. sub hour_12 { my $h = $_[0]->hour % 12; return $h ? $h : 12 }
  553. sub hour_12_0 { $_[0]->hour % 12 }
  554. sub minute { $_[0]->{local_c}{minute} }
  555. *min = \&minute;
  556. sub second { $_[0]->{local_c}{second} }
  557. *sec = \&second;
  558. sub fractional_second { $_[0]->second + $_[0]->nanosecond / MAX_NANOSECONDS }
  559. sub nanosecond { $_[0]->{rd_nanosecs} }
  560. sub millisecond { _round( $_[0]->{rd_nanosecs} / 1000000 ) }
  561. sub microsecond { _round( $_[0]->{rd_nanosecs} / 1000 ) }
  562. sub _round
  563. {
  564. my $val = shift;
  565. my $int = int $val;
  566. return $val - $int >= 0.5 ? $int + 1 : $int;
  567. }
  568. sub leap_seconds
  569. {
  570. my $self = shift;
  571. return 0 if $self->{tz}->is_floating;
  572. return DateTime->_accumulated_leap_seconds( $self->{utc_rd_days} );
  573. }
  574. sub _stringify
  575. {
  576. my $self = shift;
  577. return $self->iso8601 unless $self->{formatter};
  578. return $self->{formatter}->format_datetime($self);
  579. }
  580. sub hms
  581. {
  582. my ( $self, $sep ) = @_;
  583. $sep = ':' unless defined $sep;
  584. return sprintf( "%0.2d%s%0.2d%s%0.2d",
  585. $self->{local_c}{hour}, $sep,
  586. $self->{local_c}{minute}, $sep,
  587. $self->{local_c}{second} );
  588. }
  589. # don't want to override CORE::time()
  590. *DateTime::time = \&hms;
  591. sub iso8601 { join 'T', $_[0]->ymd('-'), $_[0]->hms(':') }
  592. *datetime = \&iso8601;
  593. sub is_leap_year { $_[0]->_is_leap_year( $_[0]->year ) }
  594. sub week
  595. {
  596. my $self = shift;
  597. unless ( defined $self->{local_c}{week_year} )
  598. {
  599. # This algorithm was taken from Date::Calc's DateCalc.c file
  600. my $jan_one_dow_m1 =
  601. ( ( $self->_ymd2rd( $self->year, 1, 1 ) + 6 ) % 7 );
  602. $self->{local_c}{week_number} =
  603. int( ( ( $self->day_of_year - 1 ) + $jan_one_dow_m1 ) / 7 );
  604. $self->{local_c}{week_number}++ if $jan_one_dow_m1 < 4;
  605. if ( $self->{local_c}{week_number} == 0 )
  606. {
  607. $self->{local_c}{week_year} = $self->year - 1;
  608. $self->{local_c}{week_number} =
  609. $self->_weeks_in_year( $self->{local_c}{week_year} );
  610. }
  611. elsif ( $self->{local_c}{week_number} == 53 &&
  612. $self->_weeks_in_year( $self->year ) == 52 )
  613. {
  614. $self->{local_c}{week_number} = 1;
  615. $self->{local_c}{week_year} = $self->year + 1;
  616. }
  617. else
  618. {
  619. $self->{local_c}{week_year} = $self->year;
  620. }
  621. }
  622. return @{ $self->{local_c} }{ 'week_year', 'week_number' }
  623. }
  624. # Also from DateCalc.c
  625. sub _weeks_in_year
  626. {
  627. my $self = shift;
  628. my $year = shift;
  629. my $jan_one_dow =
  630. ( ( $self->_ymd2rd( $year, 1, 1 ) + 6 ) % 7 ) + 1;
  631. my $dec_31_dow =
  632. ( ( $self->_ymd2rd( $year, 12, 31 ) + 6 ) % 7 ) + 1;
  633. return $jan_one_dow == 4 || $dec_31_dow == 4 ? 53 : 52;
  634. }
  635. sub week_year { ($_[0]->week)[0] }
  636. sub week_number { ($_[0]->week)[1] }
  637. # ISO says that the first week of a year is the first week containing
  638. # a Thursday. Extending that says that the first week of the month is
  639. # the first week containing a Thursday. ICU agrees.
  640. #
  641. # Algorithm supplied by Rick Measham, who doesn't understand how it
  642. # works. Neither do I. Please feel free to explain this to me!
  643. sub week_of_month
  644. {
  645. my $self = shift;
  646. # Faster than cloning just to get the dow
  647. my $first_wday_of_month = ( 8 - ( $self->day - $self->dow ) % 7 ) % 7;
  648. $first_wday_of_month = 7 unless $first_wday_of_month;
  649. my $wom = int( ( $self->day + $first_wday_of_month - 2 ) / 7 );
  650. return ( $first_wday_of_month <= 4 ) ? $wom + 1 : $wom;
  651. }
  652. sub time_zone { $_[0]->{tz} }
  653. sub offset { $_[0]->{tz}->offset_for_datetime( $_[0] ) }
  654. sub _offset_for_local_datetime { $_[0]->{tz}->offset_for_local_datetime( $_[0] ) }
  655. sub is_dst { $_[0]->{tz}->is_dst_for_datetime( $_[0] ) }
  656. sub time_zone_long_name { $_[0]->{tz}->name }
  657. sub time_zone_short_name { $_[0]->{tz}->short_name_for_datetime( $_[0] ) }
  658. sub locale { $_[0]->{locale} }
  659. *language = \&locale;
  660. sub utc_rd_values { @{ $_[0] }{ 'utc_rd_days', 'utc_rd_secs', 'rd_nanosecs' } }
  661. sub local_rd_values { @{ $_[0] }{ 'local_rd_days', 'local_rd_secs', 'rd_nanosecs' } }
  662. # NOTE: no nanoseconds, no leap seconds
  663. sub utc_rd_as_seconds { ( $_[0]->{utc_rd_days} * SECONDS_PER_DAY ) + $_[0]->{utc_rd_secs} }
  664. # NOTE: no nanoseconds, no leap seconds
  665. sub local_rd_as_seconds { ( $_[0]->{local_rd_days} * SECONDS_PER_DAY ) + $_[0]->{local_rd_secs} }
  666. # RD 1 is JD 1,721,424.5 - a simple offset
  667. sub jd
  668. {
  669. my $self = shift;
  670. my $jd = $self->{utc_rd_days} + 1_721_424.5;
  671. my $day_length = $self->_day_length( $self->{utc_rd_days} );
  672. return ( $jd +
  673. ( $self->{utc_rd_secs} / $day_length ) +
  674. ( $self->{rd_nanosecs} / $day_length / MAX_NANOSECONDS )
  675. );
  676. }
  677. sub mjd { $_[0]->jd - 2_400_000.5 }
  678. my %formats =
  679. ( 'a' => sub { $_[0]->day_abbr },
  680. 'A' => sub { $_[0]->day_name },
  681. 'b' => sub { $_[0]->month_abbr },
  682. 'B' => sub { $_[0]->month_name },
  683. 'c' => sub { $_[0]->strftime( $_[0]->{locale}->default_datetime_format ) },
  684. 'C' => sub { int( $_[0]->year / 100 ) },
  685. 'd' => sub { sprintf( '%02d', $_[0]->day_of_month ) },
  686. 'D' => sub { $_[0]->strftime( '%m/%d/%y' ) },
  687. 'e' => sub { sprintf( '%2d', $_[0]->day_of_month ) },
  688. 'F' => sub { $_[0]->ymd('-') },
  689. 'g' => sub { substr( $_[0]->week_year, -2 ) },
  690. 'G' => sub { $_[0]->week_year },
  691. 'H' => sub { sprintf( '%02d', $_[0]->hour ) },
  692. 'I' => sub { sprintf( '%02d', $_[0]->hour_12 ) },
  693. 'j' => sub { $_[0]->day_of_year },
  694. 'k' => sub { sprintf( '%2d', $_[0]->hour ) },
  695. 'l' => sub { sprintf( '%2d', $_[0]->hour_12 ) },
  696. 'm' => sub { sprintf( '%02d', $_[0]->month ) },
  697. 'M' => sub { sprintf( '%02d', $_[0]->minute ) },
  698. 'n' => sub { "\n" }, # should this be OS-sensitive?
  699. 'N' => \&_format_nanosecs,
  700. 'p' => sub { $_[0]->{locale}->am_pm( $_[0] ) },
  701. 'P' => sub { lc $_[0]->{locale}->am_pm( $_[0] ) },
  702. 'r' => sub { $_[0]->strftime( '%I:%M:%S %p' ) },
  703. 'R' => sub { $_[0]->strftime( '%H:%M' ) },
  704. 's' => sub { $_[0]->epoch },
  705. 'S' => sub { sprintf( '%02d', $_[0]->second ) },
  706. 't' => sub { "\t" },
  707. 'T' => sub { $_[0]->strftime( '%H:%M:%S' ) },
  708. 'u' => sub { $_[0]->day_of_week },
  709. # algorithm from Date::Format::wkyr
  710. 'U' => sub { my $dow = $_[0]->day_of_week;
  711. $dow = 0 if $dow == 7; # convert to 0-6, Sun-Sat
  712. my $doy = $_[0]->day_of_year - 1;
  713. return sprintf( '%02d', int( ( $doy - $dow + 13 ) / 7 - 1 ) )
  714. },
  715. 'V' => sub { sprintf( '%02d', $_[0]->week_number ) },
  716. 'w' => sub { my $dow = $_[0]->day_of_week;
  717. return $dow % 7;
  718. },
  719. 'W' => sub { my $dow = $_[0]->day_of_week;
  720. my $doy = $_[0]->day_of_year - 1;
  721. return sprintf( '%02d', int( ( $doy - $dow + 13 ) / 7 - 1 ) )
  722. },
  723. 'x' => sub { $_[0]->strftime( $_[0]->{locale}->default_date_format ) },
  724. 'X' => sub { $_[0]->strftime( $_[0]->{locale}->default_time_format ) },
  725. 'y' => sub { sprintf( '%02d', substr( $_[0]->year, -2 ) ) },
  726. 'Y' => sub { return $_[0]->year },
  727. 'z' => sub { DateTime::TimeZone::offset_as_string( $_[0]->offset ) },
  728. 'Z' => sub { $_[0]->{tz}->short_name_for_datetime( $_[0] ) },
  729. '%' => sub { '%' },
  730. );
  731. $formats{h} = $formats{b};
  732. sub strftime
  733. {
  734. my $self = shift;
  735. # make a copy or caller's scalars get munged
  736. my @formats = @_;
  737. my @r;
  738. foreach my $f (@formats)
  739. {
  740. $f =~ s/
  741. (?:
  742. %{(\w+)} # method name like %{day_name}
  743. |
  744. %([%a-zA-Z]) # single character specifier like %d
  745. |
  746. %(\d+)N # special case for %N
  747. )
  748. /
  749. ( $1
  750. ? ( $self->can($1) ? $self->$1() : "\%{$1}" )
  751. : $2
  752. ? ( $formats{$2} ? $formats{$2}->($self) : "\%$2" )
  753. : $3
  754. ? $formats{N}->($self, $3)
  755. : '' # this won't happen
  756. )
  757. /sgex;
  758. return $f unless wantarray;
  759. push @r, $f;
  760. }
  761. return @r;
  762. }
  763. sub _format_nanosecs
  764. {
  765. my $self = shift;
  766. my $precision = shift;
  767. my $ret = sprintf( "%09d", $self->{rd_nanosecs} );
  768. return $ret unless $precision; # default = 9 digits
  769. # rd_nanosecs might contain a fractional separator
  770. my ( $int, $frac ) = split /[.,]/, $self->{rd_nanosecs};
  771. $ret .= $frac if $frac;
  772. return substr( $ret, 0, $precision );
  773. }
  774. sub epoch
  775. {
  776. my $self = shift;
  777. return $self->{utc_c}{epoch}
  778. if exists $self->{utc_c}{epoch};
  779. my ( $year, $month, $day ) = $self->_utc_ymd;
  780. my @hms = $self->_utc_hms;
  781. $self->{utc_c}{epoch} =
  782. eval { Time::Local::timegm_nocheck( ( reverse @hms ),
  783. $day,
  784. $month - 1,
  785. $year,
  786. ) };
  787. return $self->{utc_c}{epoch};
  788. }
  789. sub hires_epoch
  790. {
  791. my $self = shift;
  792. my $epoch = $self->epoch;
  793. return undef unless defined $epoch;
  794. my $nano = $self->{rd_nanosecs} / MAX_NANOSECONDS;
  795. return $epoch + $nano;
  796. }
  797. sub is_finite { 1 }
  798. sub is_infinite { 0 }
  799. # added for benefit of DateTime::TimeZone
  800. sub utc_year { $_[0]->{utc_year} }
  801. # returns a result that is relative to the first datetime
  802. sub subtract_datetime
  803. {
  804. my $dt1 = shift;
  805. my $dt2 = shift;
  806. $dt2 = $dt2->clone->set_time_zone( $dt1->time_zone )
  807. unless $dt1->time_zone->name eq $dt2->time_zone->name;
  808. # We only want a negative duration if $dt2 > $dt1 ($self)
  809. my ( $bigger, $smaller, $negative ) =
  810. ( $dt1 >= $dt2 ?
  811. ( $dt1, $dt2, 0 ) :
  812. ( $dt2, $dt1, 1 )
  813. );
  814. my $is_floating = $dt1->time_zone->is_floating &&
  815. $dt2->time_zone->is_floating;
  816. my $minute_length = 60;
  817. unless ($is_floating)
  818. {
  819. my ( $utc_rd_days, $utc_rd_secs ) = $smaller->utc_rd_values;
  820. if ( $utc_rd_secs >= 86340 && ! $is_floating )
  821. {
  822. # If the smaller of the two datetimes occurs in the last
  823. # UTC minute of the UTC day, then that minute may not be
  824. # 60 seconds long. If we need to subtract a minute from
  825. # the larger datetime's minutes count in order to adjust
  826. # the seconds difference to be positive, we need to know
  827. # how long that minute was. If one of the datetimes is
  828. # floating, we just assume a minute is 60 seconds.
  829. $minute_length = $dt1->_day_length($utc_rd_days) - 86340;
  830. }
  831. }
  832. # This is a gross hack that basically figures out if the bigger of
  833. # the two datetimes is the day of a DST change. If it's a 23 hour
  834. # day (switching _to_ DST) then we subtract 60 minutes from the
  835. # local time. If it's a 25 hour day then we add 60 minutes to the
  836. # local time.
  837. #
  838. # This produces the most "intuitive" results, though there are
  839. # still reversibility problems with the resultant duration.
  840. #
  841. # However, if the two objects are on the same (local) date, and we
  842. # are not crossing a DST change, we don't want to invoke the hack
  843. # - see 38local-subtract.t
  844. my $bigger_min = $bigger->hour * 60 + $bigger->minute;
  845. if ( $bigger->time_zone->has_dst_changes
  846. && ( $bigger->ymd ne $smaller->ymd
  847. || $bigger->is_dst != $smaller->is_dst )
  848. )
  849. {
  850. $bigger_min -= 60
  851. # it's a 23 hour (local) day
  852. if ( $bigger->is_dst
  853. &&
  854. do { my $prev_day = eval { $bigger->clone->subtract( days => 1 ) };
  855. $prev_day && ! $prev_day->is_dst ? 1 : 0 }
  856. );
  857. $bigger_min += 60
  858. # it's a 25 hour (local) day
  859. if ( ! $bigger->is_dst
  860. &&
  861. do { my $prev_day = eval { $bigger->clone->subtract( days => 1 ) };
  862. $prev_day && $prev_day->is_dst ? 1 : 0 }
  863. );
  864. }
  865. my ( $months, $days, $minutes, $seconds, $nanoseconds ) =
  866. $dt1->_adjust_for_positive_difference
  867. ( $bigger->year * 12 + $bigger->month, $smaller->year * 12 + $smaller->month,
  868. $bigger->day, $smaller->day,
  869. $bigger_min, $smaller->hour * 60 + $smaller->minute,
  870. $bigger->second, $smaller->second,
  871. $bigger->nanosecond, $smaller->nanosecond,
  872. $minute_length,
  873. # XXX - using the smaller as the month length is
  874. # somewhat arbitrary, we could also use the bigger -
  875. # either way we have reversibility problems
  876. $dt1->_month_length( $smaller->year, $smaller->month ),
  877. );
  878. if ($negative)
  879. {
  880. for ( $months, $days, $minutes, $seconds, $nanoseconds )
  881. {
  882. # Some versions of Perl can end up with -0 if we do "0 * -1"!!
  883. $_ *= -1 if $_;
  884. }
  885. }
  886. return
  887. DateTime::Duration->new
  888. ( months => $months,
  889. days => $days,
  890. minutes => $minutes,
  891. seconds => $seconds,
  892. nanoseconds => $nanoseconds,
  893. );
  894. }
  895. sub _adjust_for_positive_difference
  896. {
  897. my ( $self,
  898. $month1, $month2,
  899. $day1, $day2,
  900. $min1, $min2,
  901. $sec1, $sec2,
  902. $nano1, $nano2,
  903. $minute_length,
  904. $month_length,
  905. ) = @_;
  906. if ( $nano1 < $nano2 )
  907. {
  908. $sec1--;
  909. $nano1 += MAX_NANOSECONDS;
  910. }
  911. if ( $sec1 < $sec2 )
  912. {
  913. $min1--;
  914. $sec1 += $minute_length;
  915. }
  916. # A day always has 24 * 60 minutes, though the minutes may vary in
  917. # length.
  918. if ( $min1 < $min2 )
  919. {
  920. $day1--;
  921. $min1 += 24 * 60;
  922. }
  923. if ( $day1 < $day2 )
  924. {
  925. $month1--;
  926. $day1 += $month_length;
  927. }
  928. return ( $month1 - $month2,
  929. $day1 - $day2,
  930. $min1 - $min2,
  931. $sec1 - $sec2,
  932. $nano1 - $nano2,
  933. );
  934. }
  935. sub subtract_datetime_absolute
  936. {
  937. my $self = shift;
  938. my $dt = shift;
  939. my $utc_rd_secs1 = $self->utc_rd_as_seconds;
  940. $utc_rd_secs1 += DateTime->_accumulated_leap_seconds( $self->{utc_rd_days} )
  941. if ! $self->time_zone->is_floating;
  942. my $utc_rd_secs2 = $dt->utc_rd_as_seconds;
  943. $utc_rd_secs2 += DateTime->_accumulated_leap_seconds( $dt->{utc_rd_days} )
  944. if ! $dt->time_zone->is_floating;
  945. my $seconds = $utc_rd_secs1 - $utc_rd_secs2;
  946. my $nanoseconds = $self->nanosecond - $dt->nanosecond;
  947. if ( $nanoseconds < 0 )
  948. {
  949. $seconds--;
  950. $nanoseconds += MAX_NANOSECONDS;
  951. }
  952. return
  953. DateTime::Duration->new
  954. ( seconds => $seconds,
  955. nanoseconds => $nanoseconds,
  956. );
  957. }
  958. sub delta_md
  959. {
  960. my $self = shift;
  961. my $dt = shift;
  962. my ( $smaller, $bigger ) = sort $self, $dt;
  963. my ( $months, $days, undef, undef, undef ) =
  964. $dt->_adjust_for_positive_difference
  965. ( $bigger->year * 12 + $bigger->month, $smaller->year * 12 + $smaller->month,
  966. $bigger->day, $smaller->day,
  967. 0, 0,
  968. 0, 0,
  969. 0, 0,
  970. 60,
  971. $smaller->_month_length( $smaller->year, $smaller->month ),
  972. );
  973. return DateTime::Duration->new( months => $months,
  974. days => $days );
  975. }
  976. sub delta_days
  977. {
  978. my $self = shift;
  979. my $dt = shift;
  980. my ( $smaller, $bigger ) = sort( ($self->local_rd_values)[0], ($dt->local_rd_values)[0] );
  981. DateTime::Duration->new( days => $bigger - $smaller );
  982. }
  983. sub delta_ms
  984. {
  985. my $self = shift;
  986. my $dt = shift;
  987. my ( $smaller, $greater ) = sort $self, $dt;
  988. my $days = int( $greater->jd - $smaller->jd );
  989. my $dur = $greater->subtract_datetime($smaller);
  990. my %p;
  991. $p{hours} = $dur->hours + ( $days * 24 );
  992. $p{minutes} = $dur->minutes;
  993. $p{seconds} = $dur->seconds;
  994. return DateTime::Duration->new(%p);
  995. }
  996. sub _add_overload
  997. {
  998. my ( $dt, $dur, $reversed ) = @_;
  999. if ($reversed)
  1000. {
  1001. ( $dur, $dt ) = ( $dt, $dur );
  1002. }
  1003. unless ( DateTime::Helpers::isa( $dur, 'DateTime::Duration' ) )
  1004. {
  1005. my $class = ref $dt;
  1006. my $dt_string = overload::StrVal($dt);
  1007. Carp::croak( "Cannot add $dur to a $class object ($dt_string).\n"
  1008. . " Only a DateTime::Duration object can "
  1009. . " be added to a $class object." );
  1010. }
  1011. return $dt->clone->add_duration($dur);
  1012. }
  1013. sub _subtract_overload
  1014. {
  1015. my ( $date1, $date2, $reversed ) = @_;
  1016. if ($reversed)
  1017. {
  1018. ( $date2, $date1 ) = ( $date1, $date2 );
  1019. }
  1020. if ( DateTime::Helpers::isa( $date2, 'DateTime::Duration' ) )
  1021. {
  1022. my $new = $date1->clone;
  1023. $new->add_duration( $date2->inverse );
  1024. return $new;
  1025. }
  1026. elsif ( DateTime::Helpers::isa( $date2, 'DateTime' ) )
  1027. {
  1028. return $date1->subtract_datetime($date2);
  1029. }
  1030. else
  1031. {
  1032. my $class = ref $date1;
  1033. my $dt_string = overload::StrVal($date1);
  1034. Carp::croak( "Cannot subtract $date2 from a $class object ($dt_string).\n"
  1035. . " Only a DateTime::Duration or DateTime object can "
  1036. . " be subtracted from a $class object." );
  1037. }
  1038. }
  1039. sub add { return shift->add_duration( DateTime::Duration->new(@_) ) }
  1040. sub subtract { return shift->subtract_duration( DateTime::Duration->new(@_) ) }
  1041. sub subtract_duration { return $_[0]->add_duration( $_[1]->inverse ) }
  1042. sub add_duration
  1043. {
  1044. my $self = shift;
  1045. my ($dur) = validate_pos( @_, { isa => 'DateTime::Duration' } );
  1046. # simple optimization
  1047. return $self if $dur->is_zero;
  1048. my %deltas = $dur->deltas;
  1049. # This bit isn't quite right since DateTime::Infinite::Future -
  1050. # infinite duration should NaN
  1051. foreach my $val ( values %deltas )
  1052. {
  1053. my $inf;
  1054. if ( $val == INFINITY )
  1055. {
  1056. $inf = DateTime::Infinite::Future->new;
  1057. }
  1058. elsif ( $val == NEG_INFINITY )
  1059. {
  1060. $inf = DateTime::Infinite::Past->new;
  1061. }
  1062. if ($inf)
  1063. {
  1064. %$self = %$inf;
  1065. bless $self, ref $inf;
  1066. return $self;
  1067. }
  1068. }
  1069. return $self if $self->is_infinite;
  1070. if ( $deltas{days} )
  1071. {
  1072. $self->{local_rd_days} += $deltas{days};
  1073. $self->{utc_year} += int( $deltas{days} / 365 ) + 1;
  1074. }
  1075. if ( $deltas{months} )
  1076. {
  1077. # For preserve mode, if it is the last day of the month, make
  1078. # it the 0th day of the following month (which then will
  1079. # normalize back to the last day of the new month).
  1080. my ($y, $m, $d) = ( $dur->is_preserve_mode ?
  1081. $self->_rd2ymd( $self->{local_rd_days} + 1 ) :
  1082. $self->_rd2ymd( $self->{local_rd_days} )
  1083. );
  1084. $d -= 1 if $dur->is_preserve_mode;
  1085. if ( ! $dur->is_wrap_mode && $d > 28 )
  1086. {
  1087. # find the rd for the last day of our target month
  1088. $self->{local_rd_days} = $self->_ymd2rd( $y, $m + $deltas{months} + 1, 0 );
  1089. # what day of the month is it? (discard year and month)
  1090. my $last_day = ($self->_rd2ymd( $self->{local_rd_days} ))[2];
  1091. # if our original day was less than the last day,
  1092. # use that instead
  1093. $self->{local_rd_days} -= $last_day - $d if $last_day > $d;
  1094. }
  1095. else
  1096. {
  1097. $self->{local_rd_days} = $self->_ymd2rd( $y, $m + $deltas{months}, $d );
  1098. }
  1099. $self->{utc_year} += int( $deltas{months} / 12 ) + 1;
  1100. }
  1101. if ( $deltas{days} || $deltas{months} )
  1102. {
  1103. $self->_calc_utc_rd;
  1104. $self->_handle_offset_modifier( $self->second );
  1105. }
  1106. if ( $deltas{minutes} )
  1107. {
  1108. $self->{utc_rd_secs} += $deltas{minutes} * 60;
  1109. # This intentionally ignores leap seconds
  1110. $self->_normalize_tai_seconds( $self->{utc_rd_days}, $self->{utc_rd_secs} );
  1111. }
  1112. if ( $deltas{seconds} || $deltas{nanoseconds} )
  1113. {
  1114. $self->{utc_rd_secs} += $deltas{seconds};
  1115. if ( $deltas{nanoseconds} )
  1116. {
  1117. $self->{rd_nanosecs} += $deltas{nanoseconds};
  1118. $self->_normalize_nanoseconds( $self->{utc_rd_secs}, $self->{rd_nanosecs} );
  1119. }
  1120. $self->_normalize_seconds;
  1121. # This might be some big number much bigger than 60, but
  1122. # that's ok (there are tests in 19leap_second.t to confirm
  1123. # that)
  1124. $self->_handle_offset_modifier( $self->second + $deltas{seconds} );
  1125. }
  1126. my $new =
  1127. (ref $self)->from_object
  1128. ( object => $self,
  1129. locale => $self->{locale},
  1130. ( $self->{formatter} ? ( formatter => $self->{formatter} ) : () ),
  1131. );
  1132. %$self = %$new;
  1133. return $self;
  1134. }
  1135. sub _compare_overload
  1136. {
  1137. # note: $_[1]->compare( $_[0] ) is an error when $_[1] is not a
  1138. # DateTime (such as the INFINITY value)
  1139. return $_[2] ? - $_[0]->compare( $_[1] ) : $_[0]->compare( $_[1] );
  1140. }
  1141. sub compare
  1142. {
  1143. shift->_compare( @_, 0 );
  1144. }
  1145. sub compare_ignore_floating
  1146. {
  1147. shift->_compare( @_, 1 );
  1148. }
  1149. sub _compare
  1150. {
  1151. my ( $class, $dt1, $dt2, $consistent ) = ref $_[0] ? ( undef, @_ ) : @_;
  1152. return undef unless defined $dt2;
  1153. if ( ! ref $dt2 && ( $dt2 == INFINITY || $dt2 == NEG_INFINITY ) )
  1154. {
  1155. return $dt1->{utc_rd_days} <=> $dt2;
  1156. }
  1157. unless ( DateTime::Helpers::can( $dt1, 'utc_rd_values' )
  1158. && DateTime::Helpers::can( $dt2, 'utc_rd_values' ) )
  1159. {
  1160. my $dt1_string = overload::StrVal($dt1);
  1161. my $dt2_string = overload::StrVal($dt2);
  1162. Carp::croak( "A DateTime object can only be compared to"
  1163. . " another DateTime object ($dt1_string, $dt2_string)." );
  1164. }
  1165. if ( ! $consistent &&
  1166. DateTime::Helpers::can( $dt1, 'time_zone' ) &&
  1167. DateTime::Helpers::can( $dt2, 'time_zone' )
  1168. )
  1169. {
  1170. my $is_floating1 = $dt1->time_zone->is_floating;
  1171. my $is_floating2 = $dt2->time_zone->is_floating;
  1172. if ( $is_floating1 && ! $is_floating2 )
  1173. {
  1174. $dt1 = $dt1->clone->set_time_zone( $dt2->time_zone );
  1175. }
  1176. elsif ( $is_floating2 && ! $is_floating1 )
  1177. {
  1178. $dt2 = $dt2->clone->set_time_zone( $dt1->time_zone );
  1179. }
  1180. }
  1181. my @dt1_components = $dt1->utc_rd_values;
  1182. my @dt2_components = $dt2->utc_rd_values;
  1183. foreach my $i ( 0..2 )
  1184. {
  1185. return $dt1_components[$i] <=> $dt2_components[$i]
  1186. if $dt1_components[$i] != $dt2_components[$i]
  1187. }
  1188. return 0;
  1189. }
  1190. sub _string_equals_overload
  1191. {
  1192. my ( $class, $dt1, $dt2 ) = ref $_[0] ? ( undef, @_ ) : @_;
  1193. return unless
  1194. ( DateTime::Helpers::can( $dt1, 'utc_rd_values' )
  1195. && DateTime::Helpers::can( $dt2, 'utc_rd_values' )
  1196. );
  1197. $class ||= ref $dt1;
  1198. return ! $class->compare( $dt1, $dt2 );
  1199. }
  1200. sub _string_not_equals_overload
  1201. {
  1202. return ! _string_equals_overload(@_);
  1203. }
  1204. sub _normalize_nanoseconds
  1205. {
  1206. use integer;
  1207. # seconds, nanoseconds
  1208. if ( $_[2] < 0 )
  1209. {
  1210. my $overflow = 1 + $_[2] / MAX_NANOSECONDS;
  1211. $_[2] += $overflow * MAX_NANOSECONDS;
  1212. $_[1] -= $overflow;
  1213. }
  1214. elsif ( $_[2] >= MAX_NANOSECONDS )
  1215. {
  1216. my $overflow = $_[2] / MAX_NANOSECONDS;
  1217. $_[2] -= $overflow * MAX_NANOSECONDS;
  1218. $_[1] += $overflow;
  1219. }
  1220. }
  1221. # Many of the same parameters as new() but all of them are optional,
  1222. # and there are no defaults.
  1223. my $SetValidate =
  1224. { map { my %copy = %{ $BasicValidate->{$_} };
  1225. delete $copy{default};
  1226. $copy{optional} = 1;
  1227. $_ => \%copy }
  1228. keys %$BasicValidate };
  1229. sub set
  1230. {
  1231. my $self = shift;
  1232. my %p = validate( @_, $SetValidate );
  1233. my %old_p =
  1234. ( map { $_ => $self->$_() }
  1235. qw( year month day hour minute second nanosecond locale time_zone )
  1236. );
  1237. my $new_dt = (ref $self)->new( %old_p, %p );
  1238. %$self = %$new_dt;
  1239. return $self;
  1240. }
  1241. sub set_year { $_[0]->set( year => $_[1] ) }
  1242. sub set_month { $_[0]->set( month => $_[1] ) }
  1243. sub set_day { $_[0]->set( day => $_[1] ) }
  1244. sub set_hour { $_[0]->set( hour => $_[1] ) }
  1245. sub set_minute { $_[0]->set( minute => $_[1] ) }
  1246. sub set_second { $_[0]->set( second => $_[1] ) }
  1247. sub set_nanosecond { $_[0]->set( nanosecond => $_[1] ) }
  1248. sub set_locale { $_[0]->set( locale => $_[1] ) }
  1249. sub set_formatter { $_[0]->{formatter} = $_[1] }
  1250. sub truncate
  1251. {
  1252. my $self = shift;
  1253. my %p = validate( @_,
  1254. { to =>
  1255. { regex => qr/^(?:year|month|week|day|hour|minute|second)$/ },
  1256. },
  1257. );
  1258. my %new = ( locale => $self->{locale},
  1259. time_zone => $self->{tz},
  1260. );
  1261. if ( $p{to} eq 'week' )
  1262. {
  1263. my $day_diff = $self->day_of_week - 1;
  1264. if ($day_diff)
  1265. {
  1266. $self->add( days => -1 * $day_diff );
  1267. }
  1268. return $self->truncate( to => 'day' );
  1269. }
  1270. else
  1271. {
  1272. foreach my $f ( qw( year month day hour minute second ) )
  1273. {
  1274. $new{$f} = $self->$f();
  1275. last if $p{to} eq $f;
  1276. }
  1277. }
  1278. my $new_dt = (ref $self)->new(%new);
  1279. %$self = %$new_dt;
  1280. return $self;
  1281. }
  1282. sub set_time_zone
  1283. {
  1284. my ( $self, $tz ) = @_;
  1285. # This is a bit of a hack but it works because time zone objects
  1286. # are singletons, and if it doesn't work all we lose is a little
  1287. # bit of speed.
  1288. return $self if $self->{tz} eq $tz;
  1289. my $was_floating = $self->{tz}->is_floating;
  1290. $self->{tz} = ref $tz ? $tz : DateTime::TimeZone->new( name => $tz );
  1291. $self->_handle_offset_modifier( $self->second, 1 );
  1292. # if it either was or now is floating (but not both)
  1293. if ( $self->{tz}->is_floating xor $was_floating )
  1294. {
  1295. $self->_calc_utc_rd;
  1296. }
  1297. elsif ( ! $was_floating )
  1298. {
  1299. $self->_calc_local_rd;
  1300. }
  1301. return $self;
  1302. }
  1303. sub STORABLE_freeze
  1304. {
  1305. my $self = shift;
  1306. my $cloning = shift;
  1307. my $serialized = '';
  1308. foreach my $key ( qw( utc_rd_days
  1309. utc_rd_secs
  1310. rd_nanosecs ) )
  1311. {
  1312. $serialized .= "$key:$self->{$key}|";
  1313. }
  1314. # not used yet, but may be handy in the future.
  1315. $serialized .= "version:$VERSION";
  1316. # Formatter needs to be returned as a reference since it may be
  1317. # undef or a class name, and Storable will complain if extra
  1318. # return values aren't refs
  1319. return $serialized, $self->{locale}, $self->{tz}, \$self->{formatter};
  1320. }
  1321. sub STORABLE_thaw
  1322. {
  1323. my $self = shift;
  1324. my $cloning = shift;
  1325. my $serialized = shift;
  1326. my %serialized = map { split /:/ } split /\|/, $serialized;
  1327. my ( $locale, $tz, $formatter );
  1328. # more recent code version
  1329. if (@_)
  1330. {
  1331. ( $locale, $tz, $formatter ) = @_;
  1332. }
  1333. else
  1334. {
  1335. $tz = DateTime::TimeZone->new( name => delete $serialized{tz} );
  1336. $locale =
  1337. DateTime::Locale->load( exists $serialized{language}
  1338. ? delete $serialized{language}
  1339. : delete $serialized{locale}
  1340. );
  1341. }
  1342. delete $serialized{version};
  1343. my $object = bless { utc_vals => [ $serialized{utc_rd_days},
  1344. $serialized{utc_rd_secs},
  1345. $serialized{rd_nanosecs},
  1346. ],
  1347. tz => $tz,
  1348. }, 'DateTime::_Thawed';
  1349. my %formatter = defined $$formatter ? ( formatter => $$formatter ) : ();
  1350. my $new = (ref $self)->from_object( object => $object,
  1351. locale => $locale,
  1352. %formatter,
  1353. );
  1354. %$self = %$new;
  1355. return $self;
  1356. }
  1357. package DateTime::_Thawed;
  1358. sub utc_rd_values { @{ $_[0]->{utc_vals} } }
  1359. sub time_zone { $_[0]->{tz} }
  1360. 1;
  1361. __END__
  1362. =head1 NAME
  1363. DateTime - A date and time object
  1364. =head1 SYNOPSIS
  1365. use DateTime;
  1366. $dt = DateTime->new( year => 1964,
  1367. month => 10,
  1368. day => 16,
  1369. hour => 16,
  1370. minute => 12,
  1371. second => 47,
  1372. nanosecond => 500000000,
  1373. time_zone => 'Asia/Taipei',
  1374. );
  1375. $dt = DateTime->from_epoch( epoch => $epoch );
  1376. $dt = DateTime->now; # same as ( epoch => time() )
  1377. $year = $dt->year;
  1378. $month = $dt->month; # 1-12 - also mon
  1379. $day = $dt->day; # 1-31 - also day_of_month, mday
  1380. $dow = $dt->day_of_week; # 1-7 (Monday is 1) - also dow, wday
  1381. $hour = $dt->hour; # 0-23
  1382. $minute = $dt->minute; # 0-59 - also min
  1383. $second = $dt->second; # 0-61 (leap seconds!) - also sec
  1384. $doy = $dt->day_of_year; # 1-366 (leap years) - also doy
  1385. $doq = $dt->day_of_quarter; # 1.. - also doq
  1386. $qtr = $dt->quarter; # 1-4
  1387. # all of the start-at-1 methods above have correponding start-at-0
  1388. # methods, such as $dt->day_of_month_0, $dt->month_0 and so on
  1389. $ymd = $dt->ymd; # 2002-12-06
  1390. $ymd = $dt->ymd('/'); # 2002/12/06 - also date
  1391. $mdy = $dt->mdy; # 12-06-2002
  1392. $mdy = $dt->mdy('/'); # 12/06/2002
  1393. $dmy = $dt->dmy; # 06-12-2002
  1394. $dmy = $dt->dmy('/'); # 06/12/2002
  1395. $hms = $dt->hms; # 14:02:29
  1396. $hms = $dt->hms('!'); # 14!02!29 - also time
  1397. $is_leap = $dt->is_leap_year;
  1398. # these are localizable, see Locales section
  1399. $month_name = $dt->month_name; # January, February, ...
  1400. $month_abbr = $dt->month_abbr; # Jan, Feb, ...
  1401. $day_name = $dt->day_name; # Monday, Tuesday, ...
  1402. $day_abbr = $dt->day_abbr; # Mon, Tue, ...
  1403. $epoch_time = $dt->epoch;
  1404. # may return undef if the datetime is outside the range that is
  1405. # representable by your OS's epoch system.
  1406. $dt2 = $dt + $duration_object;
  1407. $dt3 = $dt - $duration_object;
  1408. $duration_object = $dt - $dt2;
  1409. $dt->set( year => 1882 );
  1410. $dt->set_time_zone( 'America/Chicago' );
  1411. $dt->set_formatter( $formatter );
  1412. =head1 DESCRIPTION
  1413. DateTime is a class for the representation of date/time combinations,
  1414. and is part of the Perl DateTime project. For details on this project
  1415. please see L<http://datetime.perl.org/>. The DateTime site has a FAQ
  1416. which may help answer many "how do I do X?" questions. The FAQ is at
  1417. L<http://datetime.perl.org/?FAQ>.
  1418. It represents the Gregorian calendar, extended backwards in time
  1419. before its creation (in 1582). This is sometimes known as the
  1420. "proleptic Gregorian calendar". In this calendar, the first day