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