WIP: full Time::Moment 0.46 Java provider

docs/about/changelog.md

@@ -11,6 +11,7 @@ Release history of PerlOnJava. See [Roadmap](roadmap.md) for future plans.
 - Bundle the complete CPAN `File::Path` 2.18 implementation, including modern
  `rmtree`/`remove_tree` options such as `keep_root`, `error`, `result`,
  `safe`, and `verbose`.
+- Add `Time::Moment` 0.46 as a Java-backed bundled provider using `java.time`.
 
 ## v5.44.1: Regex, Threads, Async/Await, and CPAN Compatibility
 

docs/reference/bundled-modules.md

@@ -347,6 +347,7 @@ These are loaded automatically or via `use`:
 | `Time::HiRes` | Java | `System.nanoTime()` |
 | `Time::UTC::Now` | Java + Perl | `java.time.Instant`; reports no trusted accuracy bound |
 | `Time::Piece` | Java + Perl | |
+| `Time::Moment` | Java + Perl | Compatible with Time-Moment 0.46; uses `java.time` fixed-offset values. |
 | `Time::Local` | Perl | |
 | `DateTime` | Java + Perl | Java backend bundled; install `DateTime` from CPAN with `jcpan -i DateTime` (timezone data gets frequent updates) |
 | `POSIX` | Java | Includes `strftime`, `mktime`, etc. |

src/main/perl/lib/PerlOnJava/providers.json

@@ -1,6 +1,14 @@
 {
  "schema_version": 1,
  "providers": [
+ {
+ "module": "Time::Moment",
+ "version": "0.46",
+ "distribution": "Time-Moment",
+ "provider": "java-xs",
+ "shadow_policy": "forbidden",
+ "test_strategy": "bundled-provider"
+ },
  {
  "module": "DBI",
  "version": "1.643",

src/main/perl/lib/Time/Moment.pm

@@ -0,0 +1,121 @@
+package Time::Moment;
+
+use strict;
+use warnings;
+use Carp qw[];
+
+our $VERSION = '0.46';
+
+# The value and calendar operations are implemented by the bundled Java XS
+# provider. Keep this wrapper deliberately close to upstream so callers see
+# the usual Time::Moment package and version.
+use XSLoader;
+XSLoader::load(__PACKAGE__, $VERSION);
+
+use overload
+ '""' => 'to_string',
+ '<=>' => 'compare',
+ fallback => 1;
+
+sub STORABLE_freeze {
+ my ($self, $cloning) = @_;
+ return if $cloning;
+ return pack 'nnNNN', 0x544D, $self->offset, $self->utc_rd_values;
+}
+
+sub STORABLE_thaw {
+ my ($self, $cloning, $packed) = @_;
+ return if $cloning;
+ my $restored = _thaw_moment(ref($self), $packed);
+ # The upstream XS object is a scalar reference. The Java provider uses a
+ # blessed hash, so retain upstream's in-place replacement semantics by
+ # copying the restored hash payload into Storable's placeholder.
+ %$self = %$restored;
+}
+
+# PerlOnJava's Storable reader deliberately supports STORABLE_attach: it is
+# the representation-neutral hook for replacing a placeholder. Prefer it
+# for Java-backed (blessed-hash) moments; retain STORABLE_thaw above for
+# compatibility with Storable implementations that use that older hook.
+sub STORABLE_attach {
+ my ($class, $cloning, $packed) = @_;
+ return if $cloning;
+ return _thaw_moment($class, $packed);
+}
+
+sub _thaw_moment {
+ my ($class, $packed) = @_;
+ (length($packed) == 16 && vec($packed, 0, 16) == 0x544D)
+ or die 'Cannot deserialize corrupted data';
+ my ($offset, $rdn, $sod, $nos) = unpack 'xxnNNN', $packed;
+ $offset = ($offset & 0x7FFF) - 0x8000 if $offset & 0x8000;
+ my $seconds = ($rdn - 719163) * 86400 + $sod;
+ return $class->from_epoch($seconds, $nos)
+ ->with_offset_same_instant($offset);
+}
+
+sub TO_JSON { $_[0]->to_string }
+sub FREEZE { $_[0]->to_string }
+sub THAW { $_[0]->from_string($_[2]) }
+
+*with_offset = \&with_offset_same_instant;
+
+sub utc_year { $_[0]->with_offset_same_instant(0)->year }
+
+sub with {
+ my ($self, $adjuster) = @_;
+ ref($adjuster) eq 'CODE'
+ or Carp::croak("Parameter: 'adjuster' is not a CODE reference");
+ my $result = $adjuster->($self);
+ eval { $result->isa('Time::Moment') }
+ or Carp::croak("Expected an instance of Time::Moment from adjuster");
+ return $result;
+}
+
+# Keep object coercion in Perl, as upstream does: this lets ecosystem objects
+# opt in with __as_Time_Moment while reusing the Java-backed constructors.
+sub from_object {
+ my ($class, $object) = @_;
+ my $type = ref($object) || $object || 'unknown';
+
+ if (eval { $object->can('__as_Time_Moment') }) {
+ $object = $object->__as_Time_Moment;
+ }
+
+ if (eval { $object->can('time_zone') }
+ && eval { $object->time_zone->is_floating }) {
+ Carp::croak("Cannot coerce object of type $type with 'floating' time zone");
+ }
+
+ unless (eval { $object->can('epoch') }) {
+ Carp::croak("Cannot coerce object of type $type");
+ }
+
+ my $nanosecond = eval { $object->can('nanosecond') }
+ ? $object->nanosecond : 0;
+ my $offset = 0;
+ if (eval { $object->can('tzoffset') }) {
+ $offset = $object->tzoffset / 60; # Time::Piece: seconds
+ }
+ elsif (eval { $object->can('offset') }) {
+ $offset = $object->offset / 60; # DateTime: seconds
+ }
+
+ return $class->from_epoch($object->epoch, nanosecond => $nanosecond)
+ ->with_offset_same_instant($offset);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Time::Moment - immutable date/time values with a fixed UTC offset
+
+=head1 COPYRIGHT
+
+Compatible with Time-Moment 0.46 by Christian Hansen. The PerlOnJava
+provider is backed by C<java.time>.
+
+=cut

src/main/perl/lib/Time/Moment/Adjusters.pm

@@ -0,0 +1,45 @@
+package Time::Moment::Adjusters;
+use strict;
+use warnings;
+use Carp qw[];
+
+our $VERSION = '0.46';
+our @EXPORT_OK = qw[NextDayOfWeek NextOrSameDayOfWeek PreviousDayOfWeek PreviousOrSameDayOfWeek NearestDayOfWeek FirstDayOfWeekInMonth LastDayOfWeekInMonth NthDayOfWeekInMonth WesternEasterSunday OrthodoxEasterSunday NearestMinuteInterval];
+our %EXPORT_TAGS = (all => [@EXPORT_OK]);
+require Exporter;
+*import = \&Exporter::import;
+
+sub _day { my ($day) = @_; ($day >= 1 && $day <= 7) or Carp::croak(q<Parameter 'day' is out of the range [1, 7]>); $day }
+sub NextDayOfWeek { @_ == 1 or Carp::croak(q<Usage: NextDayOfWeek(day)>); my $d=_day($_[0]); sub { $_[0]->plus_days(($d-$_[0]->day_of_week+6)%7+1) } }
+sub NextOrSameDayOfWeek { @_ == 1 or Carp::croak(q<Usage: NextOrSameDayOfWeek(day)>); my $d=_day($_[0]); sub { $_[0]->plus_days(($d-$_[0]->day_of_week)%7) } }
+sub PreviousDayOfWeek { @_ == 1 or Carp::croak(q<Usage: PreviousDayOfWeek(day)>); my $d=_day($_[0]); sub { $_[0]->minus_days(($_[0]->day_of_week-$d+6)%7+1) } }
+sub PreviousOrSameDayOfWeek { @_ == 1 or Carp::croak(q<Usage: PreviousOrSameDayOfWeek(day)>); my $d=_day($_[0]); sub { $_[0]->minus_days(($_[0]->day_of_week-$d)%7) } }
+sub NearestDayOfWeek { @_ == 1 or Carp::croak(q<Usage: NearestDayOfWeek(day)>); my $d=_day($_[0]); sub { $_[0]->plus_days((($d-$_[0]->day_of_week+3)%7)-3) } }
+sub FirstDayOfWeekInMonth { @_ == 1 or Carp::croak(q<Usage: FirstDayOfWeekInMonth(day)>); my $d=_day($_[0]); sub { my $t=$_[0]->with_day_of_month(1); $t->plus_days(($d-$t->day_of_week)%7) } }
+sub LastDayOfWeekInMonth { @_ == 1 or Carp::croak(q<Usage: LastDayOfWeekInMonth(day)>); my $d=_day($_[0]); sub { my $t=$_[0]->at_last_day_of_month; $t->minus_days(($t->day_of_week-$d)%7) } }
+sub NthDayOfWeekInMonth {
+ @_ == 2 or Carp::croak(q<Usage: NthDayOfWeekInMonth(ordinal, day)>);
+ my ($o,$d)=@_; ($o >= -4 && $o <= 4 && $o) or Carp::croak(q<Parameter 'ordinal' is out of the range [-4, -1] u [1, 4]>); _day($d);
+ return $o>0 ? sub { my $t=$_[0]->with_day_of_month(1); $t->plus_days(7*($o-1)+($d-$t->day_of_week)%7) }
+ : sub { my $t=$_[0]->at_last_day_of_month; $t->plus_days(7*($o+1)-($t->day_of_week-$d)%7) };
+}
+sub _western_easter {
+ my ($year)=@_; my $a=$year%19; my $b=int($year/100); my $c=$year%100; my $d=int($b/4); my $e=$b%4; my $f=int(($b+8)/25); my $g=int(($b-$f+1)/3); my $h=(19*$a+$b-$d-$g+15)%30; my $i=int($c/4); my $k=$c%4; my $l=(32+2*$e+2*$i-$h-$k)%7; my $m=int(($a+11*$h+22*$l)/451); return (int(($h+$l-7*$m+114)/31), ($h+$l-7*$m+114)%31+1);
+}
+sub WesternEasterSunday { @_ == 0 or Carp::croak(q<Usage: WesternEasterSunday()>); sub { my ($m,$d)=_western_easter($_[0]->year); $_[0]->with_month($m)->with_day_of_month($d) } }
+sub OrthodoxEasterSunday {
+ @_ == 0 or Carp::croak(q<Usage: OrthodoxEasterSunday()>);
+ return sub {
+ my ($tm) = @_;
+ my $year = $tm->year;
+ # Upstream XS uses the Julian computus then translates the March day
+ # into the proleptic Gregorian calendar.
+ my $a = ($year % 19 * 19 + 15) % 30;
+ my $julian_day = 28 + $a - ((int($year * 5 / 4) + $a) % 7);
+ my $days_after_march = $julian_day + int($year / 100)
+ - int($year / 400) - 3;
+ return $tm->with_month(3)->with_day_of_month(1)->plus_days($days_after_march);
+ };
+}
+sub NearestMinuteInterval { @_ == 1 or Carp::croak(q<Usage: NearestMinuteInterval(interval)>); my $i=$_[0]; ($i>=1 && $i<=1440) or Carp::croak(q<Parameter 'interval' is out of the range [1, 1440]>); my $msec=$i*60000; my $mid=int(($msec+1)/2); sub { $_[0]->with_millisecond_of_day($msec*int(($_[0]->millisecond_of_day+$mid)/$msec)) } }
+1;

src/test/resources/module/Time-Moment/t/010_core.t

@@ -0,0 +1,23 @@
+use strict;
+use warnings;
+use Test::More;
+use Storable qw[nfreeze thaw];
+
+use Time::Moment;
+use Time::Moment::Adjusters qw[OrthodoxEasterSunday];
+
+my $moment = Time::Moment->from_string('2012-12-24T15:30:45.123456789+01:30');
+is $moment->to_string, '2012-12-24T15:30:45.123456789+01:30',
+ 'round-trips a fixed-offset nanosecond instant';
+is $moment->strftime('%Y-%m-%d %H:%M:%S %z'), '2012-12-24 15:30:45 +0130',
+ 'uses the shared POSIX formatter';
+is $moment->with_rdn(719163)->to_string, '1970-01-01T15:30:45.123456789+01:30',
+ 'replaces the local Rata Die day';
+is thaw(nfreeze($moment))->to_string, $moment->to_string,
+ 'Storable restores a Java-backed moment';
+is Time::Moment->from_string('2024-01-01T09:00+02:00')
+ ->with(OrthodoxEasterSunday)->to_string,
+ '2024-05-05T09:00:00+02:00',
+ 'calculates Orthodox Easter with the upstream Julian computus';
+
+done_testing;

src/test/resources/unit/cpan_bundled_providers.t

@@ -14,7 +14,7 @@ if ($is_perlonjava) {
 ok(PerlOnJava::ProviderManifest->can('provider_for'), 'loaded provider manifest');
 
 my @providers = PerlOnJava::ProviderManifest->providers;
-is(scalar(@providers), 12, 'bundled-provider manifest has twelve module entries');
+is(scalar(@providers), 13, 'bundled-provider manifest has thirteen module entries');
 
 my %expected = (
  DBI => [ '1.643', 'bundled-perl' ],
@@ -29,6 +29,7 @@ my %expected = (
  'Scalar::Util' => [ '1.70', 'java-xs' ],
  'List::Util' => [ '1.70', 'java-xs' ],
  'Sub::Util' => [ '1.70', 'java-xs' ],
+ 'Time::Moment' => [ '0.46', 'java-xs' ],
 );
 
 for my $module (sort keys %expected) {

src/test/resources/unit/time_moment_java_xs.t

@@ -0,0 +1,25 @@
+use strict;
+use warnings;
+use Test::More;
+
+use Time::Moment;
+
+my $tm = Time::Moment->from_string('2012-12-24T15:30:45.123456789+01:30');
+is $tm->to_string, '2012-12-24T15:30:45.123456789+01:30', 'round-trips an offset ISO instant';
+is $tm->epoch, 1356357645, 'preserves the instant';
+is $tm->offset, 90, 'preserves offset minutes';
+is $tm->plus_months(2)->to_string, '2013-02-24T15:30:45.123456789+01:30', 'uses calendar arithmetic';
+is $tm->with_offset_same_instant(0)->to_string, '2012-12-24T14:00:45.123456789Z', 'changes display offset without changing instant';
+is $tm->strftime('%Y-%m-%d %H:%M:%S %z'), '2012-12-24 15:30:45 +0130', 'formats through the shared Java formatter';
+ok $tm->is_after(Time::Moment->from_epoch(0)), 'compares instants';
+is $tm->with_week(1)->week, 1, 'changes ISO week while preserving its weekday';
+is $tm->with_day_of_week(1)->day_of_week, 1, 'changes ISO weekday';
+is $tm->with_rdn(719163)->to_string, '1970-01-01T15:30:45.123456789+01:30', 'changes Rata Die day locally';
+ok $tm->is_leap_year, 'reports Gregorian leap years';
+is $tm->length_of_week_year, 52, 'reports ISO weeks in the week-based year';
+
+use Time::Moment::Adjusters qw[OrthodoxEasterSunday];
+is Time::Moment->from_string('2024-01-01T09:00+02:00')->with(OrthodoxEasterSunday)->to_string,
+ '2024-05-05T09:00:00+02:00', 'calculates Orthodox Easter using the Julian computus';
+
+done_testing;

src/test/resources/unit/time_moment_storable.t

@@ -0,0 +1,15 @@
+use strict;
+use warnings;
+use Test::More;
+use Storable qw[nfreeze thaw];
+
+use Time::Moment;
+
+my $original = Time::Moment->from_string('2012-12-24T15:30:45.123456789-01:00');
+my $restored = thaw(nfreeze($original));
+
+isa_ok $restored, 'Time::Moment', 'Storable thaw restores the Java-backed object';
+is $restored->to_string, $original->to_string,
+ 'Storable thaw preserves instant, precision, and fixed offset';
+
+done_testing;