1. my class Date does Dateish {
  2. method !formatter() { sprintf '%s-%02d-%02d',self!year-Str,$!month,$!day }
  3. my $valid-units := nqp::hash(
  4. 'day', 1,
  5. 'days', 1,
  6. 'week', 7,
  7. 'weeks', 7,
  8. 'month', 0,
  9. 'months', 0,
  10. 'year', 0,
  11. 'years', 0,
  12. );
  13. method !VALID-UNIT($unit) {
  14. nqp::existskey($valid-units,$unit)
  15. ?? $unit
  16. !! X::DateTime::InvalidDeltaUnit.new(:$unit).throw
  17. }
  18. method !SET-SELF($!year,$!month,$!day,&!formatter,$!daycount = Int) { self }
  19. proto method new(|) {*}
  20. multi method new(Date: Int:D() $year, Int:D() $month, Int:D() $day, :&formatter, *%_) {
  21. 1 <= $month <= 12
  22. || X::OutOfRange.new(:what<Month>,:got($month),:range<1..12>).throw;
  23. 1 <= $day <= self.DAYS-IN-MONTH($year,$month)
  24. || X::OutOfRange.new(
  25. :what<Day>,
  26. :got($day),
  27. :range("1..{self.DAYS-IN-MONTH($year,$month)}")
  28. ).throw;
  29. self === Date
  30. ?? nqp::create(self)!SET-SELF($year,$month,$day,&formatter)
  31. !! self.bless(:$year,:$month,:$day,:&formatter,|%_)
  32. }
  33. multi method new(Date: Int:D() :$year!, Int:D() :$month = 1, Int:D() :$day = 1, :&formatter, *%_) {
  34. 1 <= $month <= 12
  35. || X::OutOfRange.new(:what<Month>,:got($month),:range<1..12>).throw;
  36. 1 <= $day <= self.DAYS-IN-MONTH($year,$month)
  37. || X::OutOfRange.new(
  38. :what<Day>,
  39. :got($day),
  40. :range("1..{self.DAYS-IN-MONTH($year,$month)}")
  41. ).throw;
  42. self === Date
  43. ?? nqp::create(self)!SET-SELF($year,$month,$day,&formatter)
  44. !! self.bless(:$year,:$month,:$day,:&formatter,|%_)
  45. }
  46. multi method new(Date: Str $date, :&formatter, *%_) {
  47. X::Temporal::InvalidFormat.new(
  48. invalid-str => $date,
  49. target => 'Date',
  50. format => 'yyyy-mm-dd',
  51. ).throw unless $date.codes == $date.chars and $date ~~ /^
  52. (<[+-]>? \d**4 \d*) # year
  53. '-'
  54. (\d\d) # month
  55. '-'
  56. (\d\d) # day
  57. $/;
  58. self.new($0,$1,$2,:&formatter,|%_)
  59. }
  60. multi method new(Date: Dateish $d, :&formatter, *%_) {
  61. self === Date
  62. ?? nqp::create(self)!SET-SELF($d.year,$d.month,$d.day,&formatter)
  63. !! self.bless(
  64. :year($d.year),
  65. :month($d.month),
  66. :day($d.day),
  67. :&formatter,
  68. |%_
  69. )
  70. }
  71. multi method new(Date: Instant $i, :&formatter, *%_) {
  72. self.new(DateTime.new($i),:&formatter,|%_)
  73. }
  74. method new-from-daycount($daycount,:&formatter) {
  75. self!ymd-from-daycount($daycount, my $year, my $month, my $day);
  76. self === Date
  77. ?? nqp::create(self)!SET-SELF($year,$month,$day,&formatter,$daycount)
  78. !! self.bless(:$year,:$month,:$day,:&formatter,:$daycount)
  79. }
  80. method today(:&formatter) { self.new(DateTime.now, :&formatter) }
  81. multi method WHICH(Date:D:) {
  82. nqp::box_s(
  83. nqp::concat(
  84. nqp::if(
  85. nqp::eqaddr(self.WHAT,Date),
  86. 'Date|',
  87. nqp::concat(nqp::unbox_s(self.^name), '|')
  88. ),
  89. nqp::unbox_i(self.daycount)
  90. ),
  91. ValueObjAt
  92. )
  93. }
  94. method truncated-to(Cool $unit) {
  95. self!clone-without-validating(
  96. |self!truncate-ymd(self!VALID-UNIT($unit)));
  97. }
  98. method later(:$earlier, *%unit) {
  99. my @pairs = %unit.pairs;
  100. die "More than one time unit supplied" if @pairs > 1;
  101. die "No time unit supplied" unless @pairs;
  102. my $unit = self!VALID-UNIT(@pairs.AT-POS(0).key);
  103. my $amount = @pairs.AT-POS(0).value.Int;
  104. $amount = -$amount if $earlier;
  105. if nqp::atkey($valid-units,$unit) -> $multiplier {
  106. self.new-from-daycount(self.daycount + $multiplier * $amount )
  107. }
  108. elsif $unit.starts-with('month') {
  109. my int $month = $!month;
  110. my int $year = $!year;
  111. $month += $amount;
  112. $year += floor(($month - 1) / 12);
  113. $month = ($month - 1) % 12 + 1;
  114. # If we overflow on days in the month, rather than throw an
  115. # exception, we just clip to the last of the month
  116. self.new($year,$month,$!day > 28
  117. ?? $!day min self.DAYS-IN-MONTH($year,$month)
  118. !! $!day);
  119. }
  120. else { # year
  121. my int $year = $!year + $amount;
  122. self.new($year,$!month,$!day > 28
  123. ?? $!day min self.DAYS-IN-MONTH($year,$!month)
  124. !! $!day);
  125. }
  126. }
  127. method clone(*%_) {
  128. my $h := nqp::getattr(%_,Map,'$!storage');
  129. self.new(
  130. nqp::existskey($h,'year') ?? nqp::atkey($h,'year') !! $!year,
  131. nqp::existskey($h,'month') ?? nqp::atkey($h,'month') !! $!month,
  132. nqp::existskey($h,'day') ?? nqp::atkey($h,'day') !! $!day,
  133. formatter => nqp::existskey($h,'formatter')
  134. ?? nqp::atkey($h,'formatter') !! &!formatter,
  135. )
  136. }
  137. method !clone-without-validating(*%_) { # A premature optimization.
  138. my $h := nqp::getattr(%_,Map,'$!storage');
  139. nqp::create(self)!SET-SELF(
  140. nqp::existskey($h,'year') ?? nqp::atkey($h,'year') !! $!year,
  141. nqp::existskey($h,'month') ?? nqp::atkey($h,'month') !! $!month,
  142. nqp::existskey($h,'day') ?? nqp::atkey($h,'day') !! $!day,
  143. &!formatter,
  144. )
  145. }
  146. method succ(Date:D:) {
  147. self.new-from-daycount(self.daycount + 1);
  148. }
  149. method pred(Date:D:) {
  150. self.new-from-daycount(self.daycount - 1);
  151. }
  152. multi method perl(Date:D:) {
  153. self.^name ~ ".new($!year,$!month,$!day)"
  154. }
  155. multi method ACCEPTS(Date:D: DateTime:D $dt) {
  156. $dt.day == $!day && $dt.month == $!month && $dt.year == $!year
  157. }
  158. proto method DateTime() {*}
  159. multi method DateTime(Date:D:) { DateTime.new(:$!year, :$!month, :$!day) }
  160. multi method DateTime(Date:U:) { DateTime }
  161. method Date() { self }
  162. }
  163. multi sub infix:<+>(Date:D $d, Int:D $x) {
  164. Date.new-from-daycount($d.daycount + $x)
  165. }
  166. multi sub infix:<+>(Int:D $x, Date:D $d) {
  167. Date.new-from-daycount($d.daycount + $x)
  168. }
  169. multi sub infix:<->(Date:D $d, Int:D $x) {
  170. Date.new-from-daycount($d.daycount - $x)
  171. }
  172. multi sub infix:<->(Date:D $a, Date:D $b) {
  173. $a.daycount - $b.daycount;
  174. }
  175. multi sub infix:<cmp>(Date:D $a, Date:D $b) {
  176. $a.daycount cmp $b.daycount
  177. }
  178. multi sub infix:«<=>»(Date:D $a, Date:D $b) {
  179. $a.daycount <=> $b.daycount
  180. }
  181. multi sub infix:<==>(Date:D $a, Date:D $b) {
  182. $a.daycount == $b.daycount
  183. }
  184. multi sub infix:«<=»(Date:D $a, Date:D $b) {
  185. $a.daycount <= $b.daycount
  186. }
  187. multi sub infix:«<»(Date:D $a, Date:D $b) {
  188. $a.daycount < $b.daycount
  189. }
  190. multi sub infix:«>=»(Date:D $a, Date:D $b) {
  191. $a.daycount >= $b.daycount
  192. }
  193. multi sub infix:«>»(Date:D $a, Date:D $b) {
  194. $a.daycount > $b.daycount
  195. }
  196. proto sub sleep(|) {*}
  197. multi sub sleep(--> Nil) { sleep(*) }
  198. multi sub sleep($seconds --> Nil) {
  199. # 1e9 seconds is a large enough value that still makes VMs sleep
  200. # larger values cause nqp::sleep() to exit immediatelly (esp. on 32-bit)
  201. if nqp::istype($seconds,Whatever) || $seconds == Inf {
  202. nqp::sleep(1e9) while True;
  203. }
  204. elsif $seconds > 1e9 {
  205. nqp::sleep($_) for gather {
  206. 1e9.take xx ($seconds / 1e9);
  207. take $seconds - 1e9 * ($seconds / 1e9).Int;
  208. }
  209. }
  210. elsif $seconds > 0e0 {
  211. nqp::sleep($seconds.Num);
  212. }
  213. }
  214. proto sub sleep-timer(|) {*}
  215. multi sub sleep-timer(--> Duration:D) { sleep-timer(*) }
  216. multi sub sleep-timer($seconds --> Duration:D) {
  217. my $time1 = now;
  218. sleep($seconds);
  219. Duration.new( ( $seconds - (now - $time1) ) max 0 )
  220. }
  221. proto sub sleep-until(|) {*}
  222. multi sub sleep-until(Instant() $until --> Bool:D) {
  223. my $seconds = $until - now;
  224. return False if $seconds < 0;
  225. Nil while $seconds = sleep-timer($seconds);
  226. True;
  227. }