| 1 | # Date::Simple::NoXS - used internally by Date::Simple. |
| 2 | |
| 3 | use strict; |
| 4 | |
| 5 | package Date::Simple; |
| 6 | |
| 7 | sub ymd { |
| 8 | my $days = &ymd_to_days; |
| 9 | return undef unless defined ($days); |
| 10 | return (bless (\$days, __PACKAGE__)); |
| 11 | } |
| 12 | |
| 13 | sub d8 { |
| 14 | my ($d8) = @_; |
| 15 | my @ymd = $d8 =~ m/^(\d{4})(\d\d)(\d\d)$/ or return undef; |
| 16 | return ymd (@ymd); |
| 17 | } |
| 18 | |
| 19 | # Precise integer arithmetic functions unfortunately missing from |
| 20 | # Perl's core: |
| 21 | |
| 22 | sub _divmod { |
| 23 | my ($quot, $int); |
| 24 | |
| 25 | $quot = $_[0] / $_[1]; |
| 26 | $int = int($quot); |
| 27 | $int -= 1 if $int > $quot; |
| 28 | $_[0] %= $_[1]; |
| 29 | return $int; |
| 30 | }; |
| 31 | |
| 32 | sub _div { |
| 33 | my ($quot, $int); |
| 34 | |
| 35 | $quot = $_[0] / $_[1]; |
| 36 | $int = int($quot); |
| 37 | return $int - 1 if $int > $quot; |
| 38 | return $int; |
| 39 | }; |
| 40 | |
| 41 | sub leap_year { |
| 42 | my $y = shift; |
| 43 | return (($y%4==0) and ($y%400==0 or $y%100!=0)) || 0; |
| 44 | } |
| 45 | |
| 46 | my @days_in_month = ( |
| 47 | [0,31,28,31,30,31,30,31,31,30,31,30,31], |
| 48 | [0,31,29,31,30,31,30,31,31,30,31,30,31], |
| 49 | ); |
| 50 | |
| 51 | sub days_in_month ($$) { |
| 52 | my ($y,$m) = @_; |
| 53 | return $days_in_month[leap_year($y)][$m]; |
| 54 | } |
| 55 | |
| 56 | sub validate ($$$) { |
| 57 | my ($y, $m, $d)= @_; |
| 58 | # any +ve integral year is valid |
| 59 | return 0 if $y != abs int $y; |
| 60 | return 0 unless 1 <= $m and $m <= 12; |
| 61 | return 0 unless 1 <= $d and $d <= $days_in_month[leap_year($y)][$m]; |
| 62 | return 1; |
| 63 | } |
| 64 | |
| 65 | # Given a year, month, and day, return the canonical day number. |
| 66 | # That is the number of days since 1 January 1970, negative if earlier. |
| 67 | sub ymd_to_days { |
| 68 | my ($Y, $M, $D) = @_; |
| 69 | my ($days, $x); |
| 70 | |
| 71 | if ($M < 1 || $M > 12 || $D < 1 || |
| 72 | ($D > 28 && $D > days_in_month($Y, $M))) |
| 73 | { |
| 74 | return undef; |
| 75 | } |
| 76 | |
| 77 | $days = $D + |
| 78 | (undef, -1, 30, 58, 89, 119, 150, 180, 211, 242, 272, 303, 333)[$M]; |
| 79 | $days += 365 * ($Y - 1970); |
| 80 | $x = ($M <= 2 ? $Y-1 : $Y); |
| 81 | $days += _div (($x - 1968), 4); |
| 82 | $days -= _div (($x - 1900), 100); |
| 83 | $days += _div (($x - 1600), 400); |
| 84 | return $days; |
| 85 | } |
| 86 | |
| 87 | sub days_since_1970 { ${$_[0]} } |
| 88 | |
| 89 | # Given a canonical day number (days since 1 Jan 1970), return the |
| 90 | # year, month, and day. |
| 91 | sub days_to_ymd { |
| 92 | my ($days) = @_; |
| 93 | my ($year, $mnum, $mday, $tmp); |
| 94 | |
| 95 | # Shift frame of reference from 1 Jan 1970 to (the imaginary) 1 Mar 0AD. |
| 96 | $tmp = $days + 719468; |
| 97 | |
| 98 | # Do the math. |
| 99 | $year = 400 * _divmod ($tmp, 146097); |
| 100 | if ($tmp == 146096) { |
| 101 | # Handle 29 Feb 2000, 2400, ... |
| 102 | $year += 400; |
| 103 | $mnum = 2; |
| 104 | $mday = 29; |
| 105 | } else { |
| 106 | $year += 100 * _divmod ($tmp, 36524); |
| 107 | $year += 4 * _divmod ($tmp, 1461); |
| 108 | if ($tmp == 1460) { |
| 109 | $year += 4; |
| 110 | $mnum = 2; |
| 111 | $mday = 29; |
| 112 | } else { |
| 113 | $year += _divmod ($tmp, 365); |
| 114 | $mnum = _divmod ($tmp, 31); |
| 115 | $mday = $tmp + (1, 1, 2, 2, 3, 3, 3, 4, 4, 5, 5, 5)[$mnum]; |
| 116 | $tmp = (31, 30, 31, 30, 31, 31, 30, 31, 30, 31, 31, 28)[$mnum]; |
| 117 | if ($mday > $tmp) { |
| 118 | $mday -= $tmp; |
| 119 | $mnum += 1; |
| 120 | } |
| 121 | if ($mnum > 9) { |
| 122 | $mnum -= 9; |
| 123 | $year += 1; |
| 124 | } else { |
| 125 | $mnum += 3; |
| 126 | } |
| 127 | } |
| 128 | } |
| 129 | return ($year, $mnum, $mday); |
| 130 | } |
| 131 | |
| 132 | sub as_ymd { return days_to_ymd (${$_[0]}); } |
| 133 | sub as_d8 { return sprintf ("%04d%02d%02d", &as_ymd); } |
| 134 | |
| 135 | sub year { return (&as_ymd) [0]; } |
| 136 | sub month { return (&as_ymd) [1]; } |
| 137 | sub day { return (&as_ymd) [2]; } |
| 138 | |
| 139 | sub day_of_week { |
| 140 | return ((${$_[0]} + 4) % 7); |
| 141 | } |
| 142 | |
| 143 | #------------------------------------------------------------------------------ |
| 144 | # the following methods are called by the overloaded operators, so they should |
| 145 | # not normally be called directly. |
| 146 | #------------------------------------------------------------------------------ |
| 147 | sub _stringify { return sprintf ("%04d-%02d-%02d", &as_ymd); } |
| 148 | |
| 149 | sub _add { |
| 150 | my ($date, $diff) = @_; |
| 151 | |
| 152 | if ($diff !~ /^-?\d+$/) { |
| 153 | Carp::croak ("Date interval must be an integer"); |
| 154 | } |
| 155 | return (bless (\ ($$date + $diff), ref($date))); |
| 156 | } |
| 157 | |
| 158 | sub _subtract { |
| 159 | my ($left, $right, $reverse) = @_; |
| 160 | |
| 161 | if ($reverse) { |
| 162 | Carp::croak ("Can't subtract a date from a non-date"); |
| 163 | } |
| 164 | if (ref($right) eq '' && $right =~ /^-?\d+$/) { |
| 165 | return (bless (\ ($$left - $right), ref($left))); |
| 166 | } |
| 167 | return ($$left - $$right); |
| 168 | } |
| 169 | |
| 170 | sub _compare { |
| 171 | my ($left, $right, $reverse) = @_; |
| 172 | |
| 173 | $right = $left->new($right) || _inval ($left, $right); |
| 174 | return ($reverse ? $$right <=> $$left : $$left <=> $$right); |
| 175 | } |
| 176 | |
| 177 | sub _eq { |
| 178 | my ($left, $right) = @_; |
| 179 | return (($right = $left->_new($right)) && $$right == $$left); |
| 180 | } |
| 181 | |
| 182 | sub _ne { |
| 183 | return (!&_eq); |
| 184 | } |
| 185 | |
| 186 | 1; |
| 187 | |
| 188 | =head1 NAME |
| 189 | |
| 190 | Date::Simple::NoXS - Pure Perl support for Date::Simple. |
| 191 | |
| 192 | =head1 SYNOPSIS |
| 193 | |
| 194 | use Date::Simple; |
| 195 | |
| 196 | =head1 DESCRIPTION |
| 197 | |
| 198 | Used internally by Date::Simple. |
| 199 | |
| 200 | =head1 SEE ALSO |
| 201 | |
| 202 | L<Date::Simple>. |
| 203 | |
| 204 | =cut |