1. my role Dateish {
  2. has Int $.year;
  3. has Int $.month; # should be int
  4. has Int $.day; # should be int
  5. has Int $.daycount;
  6. has &.formatter;
  7. method IO(Dateish:D:) { IO::Path.new(~self) } # because Dateish is not Cool
  8. # this sub is also used by DAYS-IN-MONTH, which is used by other types
  9. sub IS-LEAP-YEAR($y) { $y %% 4 and not $y %% 100 or $y %% 400 }
  10. method is-leap-year(Dateish:D:) { IS-LEAP-YEAR($!year) }
  11. my $days-in-month := nqp::list_i(
  12. 0, 31, 0, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31
  13. );
  14. # This method is used by Date and DateTime:
  15. method DAYS-IN-MONTH(\year, \month) {
  16. nqp::atpos_i($days-in-month,month) ||
  17. ( month == 2 ?? 28 + IS-LEAP-YEAR(year) !! Nil );
  18. }
  19. method days-in-month(Dateish:D:) { self.DAYS-IN-MONTH($!year,$!month) }
  20. method !year-Str() {
  21. sprintf 0 <= $!year <= 9999 ?? '%04d' !! '%+05d', $!year;
  22. }
  23. multi method new(Dateish:) {
  24. Failure.new(
  25. "Cannot call {self.^name}.new with "
  26. ~ (%_ ?? "these named parameters: {%_.keys}" !! "no parameters")
  27. )
  28. }
  29. multi method Str(Dateish:D:) {
  30. &!formatter ?? &!formatter(self) !! self!formatter
  31. }
  32. multi method gist(Dateish:D:) { self.Str }
  33. method daycount() {
  34. $!daycount //= do {
  35. # taken from <http://www.merlyn.demon.co.uk/daycount.htm>
  36. my int $m = $!month < 3 ?? $!month + 12 !! $!month;
  37. my int $y = $!year - ($!month < 3);
  38. -678973 + $!day + (153 * $m - 2) div 5
  39. + 365 * $y + $y div 4
  40. - $y div 100 + $y div 400;
  41. }
  42. }
  43. method !ymd-from-daycount($daycount,\year,\month,\day --> Nil) {
  44. # taken from <http://www.merlyn.demon.co.uk/daycount.htm>
  45. my Int $dc = $daycount.Int + 678881;
  46. my Int $ti = (4 * ($dc + 36525)) div 146097 - 1;
  47. my Int $year = 100 * $ti;
  48. my int $day = $dc - (36524 * $ti + ($ti div 4));
  49. my int $t = (4 * ($day + 366)) div 1461 - 1;
  50. year = $year + $t;
  51. $day = $day - (365 * $t + ($t div 4));
  52. my int $month = (5 * $day + 2) div 153;
  53. day = $day - ((2 + $month * 153) div 5 - 1);
  54. if ($month > 9) {
  55. month = $month - 9;
  56. year = year + 1;
  57. }
  58. else {
  59. month = $month + 3;
  60. }
  61. }
  62. method day-of-month() { $!day }
  63. method day-of-week(Dateish:D:) { (self.daycount + 2) % 7 + 1 }
  64. method week() { # algorithm from Claus T√łndering
  65. my int $a = $!year - ($!month <= 2).floor.Int;
  66. my int $b = $a div 4 - $a div 100 + $a div 400;
  67. my int $c = ($a - 1) div 4 - ($a - 1) div 100 + ($a - 1) div 400;
  68. my int $s = $b - $c;
  69. my int $e = $!month <= 2 ?? 0 !! $s + 1;
  70. my int $f = $!day
  71. + ($!month <= 2
  72. ?? 31*($!month - 1) - 1
  73. !! (153*($!month - 3) + 2) div 5 + 58 + $s);
  74. my int $g = ($a + $b) % 7;
  75. my int $d = ($f + $g - $e) % 7;
  76. my int $n = $f + 3 - $d;
  77. $n < 0 ?? ($!year - 1, 53 - ($g - $s) div 5)
  78. !! $n > 364 + $s ?? ($!year + 1, 1 )
  79. !! ($!year, $n div 7 + 1 );
  80. }
  81. method week-year() { self.week.AT-POS(0) }
  82. method week-number() { self.week.AT-POS(1) }
  83. method weekday-of-month {
  84. ($!day - 1) div 7 + 1
  85. }
  86. my $days-at-start-of-month := nqp::list_i(
  87. 0, 0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334
  88. );
  89. method day-of-year() {
  90. $!day
  91. + nqp::atpos_i($days-at-start-of-month,$!month)
  92. + ($!month > 2 && IS-LEAP-YEAR($!year));
  93. }
  94. method yyyy-mm-dd() { sprintf '%04d-%02d-%02d',$!year,$!month,$!day }
  95. method earlier(*%unit) { self.later(:earlier, |%unit) }
  96. method !truncate-ymd(Cool:D $unit, %parts? is copy) {
  97. if $unit eq 'week' | 'weeks' {
  98. my $new-dc = self.daycount - self.day-of-week + 1;
  99. self!ymd-from-daycount($new-dc,
  100. %parts<year>,%parts<month>,%parts<day>);
  101. }
  102. else { # $unit eq 'month' | 'months' | 'year' | 'years'
  103. %parts<day> = 1;
  104. %parts<month> = 1 if $unit eq 'year' | 'years';
  105. }
  106. %parts;
  107. }
  108. }
  109. # =begin pod
  110. #
  111. # =head1 SEE ALSO
  112. # Perl 6 spec <S32-Temporal|http://design.perl6.org/S32/Temporal.html>.
  113. # The Perl 5 DateTime Project home page L<http://datetime.perl.org>.
  114. # Perl 5 perldoc L<doc:DateTime> and L<doc:Time::Local>.
  115. #
  116. # The best yet seen explanation of calendars, by Claus T√łndering
  117. # L<Calendar FAQ|http://www.tondering.dk/claus/calendar.html>.
  118. # Similar algorithms at L<http://www.hermetic.ch/cal_stud/jdn.htm>
  119. # and L<http://www.merlyn.demon.co.uk/daycount.htm>.
  120. #
  121. # <ISO 8601|http://en.wikipedia.org/wiki/ISO_8601>
  122. # <Time zones|http://en.wikipedia.org/wiki/List_of_time_zones>
  123. #
  124. # As per the recommendation, the strftime() method has bee moved into a
  125. # loadable module called DateTime::strftime.
  126. #
  127. # =end pod