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,
  122. )
  123. }
  124. method !clone-without-validating(*%_) { # A premature optimization.
  125. my $h := nqp::getattr(%_,Map,'$!storage');
  126. nqp::create(self)!SET-SELF(
  127. nqp::existskey($h,'year') ?? nqp::atkey($h,'year') !! $!year,
  128. nqp::existskey($h,'month') ?? nqp::atkey($h,'month') !! $!month,
  129. nqp::existskey($h,'day') ?? nqp::atkey($h,'day') !! $!day,
  130. &!formatter,
  131. )
  132. }
  133. method succ(Date:D:) {
  134. self.new-from-daycount(self.daycount + 1);
  135. }
  136. method pred(Date:D:) {
  137. self.new-from-daycount(self.daycount - 1);
  138. }
  139. multi method perl(Date:D:) {
  140. self.^name ~ ".new($!year,$!month,$!day)"
  141. }
  142. multi method ACCEPTS(Date:D: DateTime:D $dt) {
  143. $dt.day == $!day && $dt.month == $!month && $dt.year == $!year
  144. }
  145. proto method DateTime() { * }
  146. multi method DateTime(Date:D:) { DateTime.new(:$!year, :$!month, :$!day) }
  147. multi method DateTime(Date:U:) { DateTime }
  148. method Date() { self }
  149. }
  150. multi sub infix:<+>(Date:D $d, Int:D $x) {
  151. Date.new-from-daycount($d.daycount + $x)
  152. }
  153. multi sub infix:<+>(Int:D $x, Date:D $d) {
  154. Date.new-from-daycount($d.daycount + $x)
  155. }
  156. multi sub infix:<->(Date:D $d, Int:D $x) {
  157. Date.new-from-daycount($d.daycount - $x)
  158. }
  159. multi sub infix:<->(Date:D $a, Date:D $b) {
  160. $a.daycount - $b.daycount;
  161. }
  162. multi sub infix:<cmp>(Date:D $a, Date:D $b) {
  163. $a.daycount cmp $b.daycount
  164. }
  165. multi sub infix:«<=>»(Date:D $a, Date:D $b) {
  166. $a.daycount <=> $b.daycount
  167. }
  168. multi sub infix:<==>(Date:D $a, Date:D $b) {
  169. $a.daycount == $b.daycount
  170. }
  171. multi sub infix:«<=»(Date:D $a, Date:D $b) {
  172. $a.daycount <= $b.daycount
  173. }
  174. multi sub infix:«<»(Date:D $a, Date:D $b) {
  175. $a.daycount < $b.daycount
  176. }
  177. multi sub infix:«>=»(Date:D $a, Date:D $b) {
  178. $a.daycount >= $b.daycount
  179. }
  180. multi sub infix:«>»(Date:D $a, Date:D $b) {
  181. $a.daycount > $b.daycount
  182. }
  183. sub sleep($seconds = Inf --> Nil) {
  184. # 1e9 seconds is a large enough value that still makes VMs sleep
  185. # larger values cause nqp::sleep() to exit immediatelly (esp. on 32-bit)
  186. if $seconds == Inf || nqp::istype($seconds,Whatever) {
  187. nqp::sleep(1e9) while True;
  188. }
  189. elsif $seconds > 1e9 {
  190. nqp::sleep($_) for gather {
  191. 1e9.take xx ($seconds / 1e9);
  192. take $seconds - 1e9 * ($seconds / 1e9).Int;
  193. }
  194. }
  195. elsif $seconds > 0 {
  196. nqp::sleep($seconds.Num);
  197. }
  198. }
  199. sub sleep-timer(Real() $seconds = Inf --> Duration:D) {
  200. if $seconds <= 0 {
  201. Duration.new(0);
  202. }
  203. else {
  204. my $time1 = now;
  205. nqp::sleep($seconds.Num);
  206. Duration.new( ( $seconds - (now - $time1) ) max 0 );
  207. }
  208. }
  209. sub sleep-until(Instant() $until --> Bool:D) {
  210. my $seconds = $until - now;
  211. return False if $seconds < 0;
  212. Nil while $seconds = sleep-timer($seconds);
  213. True;
  214. }