view release on metacpan or  search on metacpan

t/integration.t  view on Meta::CPAN

#!perl

# Black-box integration tests for DateTime::Format::Genealogy.
#
# These tests exercise stateful, cross-method workflows: constructor flags
# flowing into parse_datetime, per-object cache isolation, cloning chains,
# optional-dependency fallbacks, and concurrent independent instances.
#
# Calling convention: Params::Get does NOT support mixing a positional scalar
# with named key-value flags.  All parse_datetime calls that pass flags use
# the named (date => '...', quiet => 1) or hashref form.

use strict;
use warnings;

use Test::Most;
use Test::Returns;
use Readonly;
use Scalar::Util qw(blessed refaddr);

# Test::Without::Module blocks require() at load time; import it before the
# module under test so we can selectively hide optional back-ends.
use Test::Without::Module ();

BEGIN { use_ok('DateTime::Format::Genealogy') || BAIL_OUT('Cannot load module') }

Readonly my $PKG => 'DateTime::Format::Genealogy';

# ---------------------------------------------------------------------------
# Lightweight stubs for optional calendar back-ends.
#
# Neither DateTime::Calendar::Hebrew nor DateTime::Calendar::FrenchRevolutionary
# is installed in this environment, so we inject stubs that behave like the
# real modules.  %INC entries prevent require() from searching @INC.
#
# The stubs record how they are constructed so spy-style assertions can verify
# that _convert_calendar passes the right coordinates.
# ---------------------------------------------------------------------------

my @hebrew_new_calls;
my @french_new_calls;

{
	package DateTime::Calendar::Hebrew;
	sub new {
		my ($class, %args) = @_;
		push @hebrew_new_calls, \%args;
		return bless { %args }, $class;
	}
}
$INC{'DateTime/Calendar/Hebrew.pm'} = 1;

{
	package DateTime::Calendar::FrenchRevolutionary;
	sub new {
		my ($class, %args) = @_;
		push @french_new_calls, \%args;
		return bless { %args }, $class;
	}
}
$INC{'DateTime/Calendar/FrenchRevolutionary.pm'} = 1;

# ===========================================================================
# SECTION 1: Multi-instance isolation
#
# Two independent objects must not share mutable state (the all_dates cache
# or the internal DFN/date_parser lazy singletons).
# ===========================================================================

subtest 'two independent objects do not share cache state' => sub {
	my $obj_a = $PKG->new();
	my $obj_b = $PKG->new();

	isnt(refaddr($obj_a), refaddr($obj_b), 'objects are distinct references');

	# Populate obj_a's cache.
	$obj_a->parse_datetime('25 Dec 2022');
	my $cache_a = $obj_a->{all_dates} // {};

	# obj_b must have an empty cache (or at least not share obj_a's hashref).
	my $cache_b = $obj_b->{all_dates} // {};

	isnt(refaddr($cache_a), refaddr($cache_b),
		'per-object caches are distinct hashrefs')
		if %{$cache_a} && %{$cache_b};

	ok(!exists $cache_b->{'25 Dec 2022'},
		"obj_b cache does not contain obj_a's parsed entry");

	diag('obj_a cache keys: ' . join(', ', keys %{$cache_a}))
		if $ENV{TEST_VERBOSE};
};

subtest 'concurrent instances with different flags do not interfere' => sub {
	# quiet_obj silences carps; loud_obj emits them; they must not share flags.
	my $quiet_obj = $PKG->new(quiet => 1);
	my $loud_obj  = $PKG->new();

t/integration.t  view on Meta::CPAN

	my $st = $PKG->new(strict => 1, quiet => 1);

	my @ns_range = $ns->parse_datetime('from 1 Jan 2000 to 31 Dec 2000');
	is(scalar @ns_range, 2, 'non-strict: from...to... yields 2 elements');
	is($ns_range[0]->dmy, '01-01-2000', 'from start correct');
	is($ns_range[1]->dmy, '31-12-2000', 'from end correct');

	# Strict treats "from ... to ..." as unparseable, returns empty list.
	my @st_range = $st->parse_datetime('from 1 Jan 2000 to 31 Dec 2000');
	is(scalar @st_range, 0, 'strict: from...to... yields empty list');
};

# ===========================================================================
# SECTION 5: Per-object cache behaviour
#
# The all_dates cache must accelerate repeated identical calls on the same
# object but must not prevent correct parsing of different date strings.
# ===========================================================================

subtest 'cache accelerates repeated calls and yields equal DateTime values' => sub {
	my $obj = $PKG->new();

	Readonly my $DATE => '5 Jan 2019';

	my $first  = $obj->parse_datetime($DATE);
	my $second = $obj->parse_datetime($DATE);
	my $third  = $obj->parse_datetime($DATE);

	isa_ok($first, 'DateTime', 'first parse returns DateTime');
	is($first->dmy,  $second->dmy, 'second parse value matches first');
	is($second->dmy, $third->dmy,  'third parse value matches second');

	# Cache must contain exactly one entry for the key.
	my $cache = $obj->{all_dates} // {};
	ok(exists $cache->{$DATE}, 'date string is in the cache after first parse');
	is(scalar keys %{$cache}, 1, 'only one entry in cache after three identical calls')
		if scalar keys %{$cache} > 0;

	diag("Cache entry key: '$DATE'") if $ENV{TEST_VERBOSE};
};

subtest 'different date strings each get their own cache entry' => sub {
	my $obj = $PKG->new();

	Readonly my @DATES => ('25 Dec 2022', '5 Jan 2019', '29 Sep 1939');

	for my $date (@DATES) {
		$obj->parse_datetime($date);
	}

	my $cache = $obj->{all_dates} // {};
	for my $date (@DATES) {
		ok(exists $cache->{$date}, "cache contains entry for '$date'");
	}

	diag('Cache entries: ' . join(', ', sort keys %{$cache}))
		if $ENV{TEST_VERBOSE};
};

# ===========================================================================
# SECTION 6: GEDCOM calendar escapes — end-to-end with stubs installed
# ===========================================================================

subtest '@#DJULIAN@ escape applies correct offset for each century tier' => sub {
	my $obj = $PKG->new();

	# Offset tiers: <1700 => 10, <1800 => 11, <1900 => 12, >= 1900 => 13
	Readonly my %JULIAN_CASES => (
		# [ input_day, month, year ] => expected_gregorian_day (same month/year)
		'15 Mar 1620' => { day => 25, offset => 10 },
		'1 Mar 1750'  => { day => 12, offset => 11 },
		'1 Mar 1850'  => { day => 13, offset => 12 },
		'1 Mar 1920'  => { day => 14, offset => 13 },
	);

	while (my ($date_str, $expected) = each %JULIAN_CASES) {
		my $dt = $obj->parse_datetime("@#DJULIAN@ $date_str");
		isa_ok($dt, 'DateTime', "@#DJULIAN@ $date_str parses to DateTime");
		if (defined $dt) {
			is($dt->day, $expected->{day},
				"$date_str: day advanced by $expected->{offset} days");
		}
	}
};

subtest '@#DHEBREW@ escape delegates to Hebrew stub and returns converted DateTime' => sub {
	# Reset the spy array so only calls from this subtest are counted.
	@hebrew_new_calls = ();

	# Override DateTime->from_object to return a sentinel year that proves
	# _convert_calendar returned the converted object and not the original.
	Readonly my $SENTINEL_YEAR => 5783;
	no warnings 'redefine';
	local *DateTime::from_object = sub {
		return DateTime->new(year => $SENTINEL_YEAR, month => 10, day => 1);
	};

	my $obj = $PKG->new();
	my $dt  = $obj->parse_datetime('@#DHEBREW@ 9 Oct 2022');

	isa_ok($dt, 'DateTime', '@#DHEBREW@ returns a DateTime');
	is($dt->year, $SENTINEL_YEAR,
		'@#DHEBREW@: from_object result returned, not original Gregorian');

	# The stub must have been called with Gregorian coordinates from the
	# date string so that _convert_calendar passed the right year/month/day.
	is(scalar @hebrew_new_calls, 1, 'Hebrew::new called exactly once');
	is($hebrew_new_calls[0]{year},  2022, 'Hebrew::new passed correct year');
	is($hebrew_new_calls[0]{month},   10, 'Hebrew::new passed correct month');
	is($hebrew_new_calls[0]{day},      9, 'Hebrew::new passed correct day');

	diag("Hebrew stub called with: " . join(', ', map { "$_=$hebrew_new_calls[0]{$_}" } qw(year month day)))
		if $ENV{TEST_VERBOSE};
};

subtest '@#DFRENCH R@ escape delegates to FrenchRevolutionary stub' => sub {
	@french_new_calls = ();

	Readonly my $SENTINEL_YEAR => 1792;
	no warnings 'redefine';
	local *DateTime::from_object = sub {
		return DateTime->new(year => $SENTINEL_YEAR, month => 9, day => 22);
	};

	my $obj = $PKG->new();
	my $dt  = $obj->parse_datetime('@#DFRENCH R@ 22 Sep 1792');

	isa_ok($dt, 'DateTime', '@#DFRENCH R@ returns a DateTime');
	is($dt->year, $SENTINEL_YEAR,
		'@#DFRENCH R@: from_object result returned');

	is(scalar @french_new_calls, 1, 'FrenchRevolutionary::new called exactly once');

	diag("French stub called with year=$french_new_calls[0]{year}")
		if $ENV{TEST_VERBOSE};
};

# ===========================================================================
# SECTION 7: Optional-dependency fallbacks with Test::Without::Module
#
# When DateTime::Calendar::Hebrew or DateTime::Calendar::FrenchRevolutionary
# is absent, the module must gracefully degrade: carp (unless quiet) and
# return undef rather than dying.
#
# Test::Without::Module removes modules from %INC and blocks their loading,
# so we must run these tests before the stubs registered above could be
# re-used.  We localise %INC inside the block to undo the stub injection
# for the duration of each Without::Module scope.
# ===========================================================================

subtest 'graceful degradation without DateTime::Calendar::Hebrew' => sub {
	# Temporarily unregister the Hebrew stub so require() fails as if the
	# real module is absent.
	local %INC = %INC;
	delete $INC{'DateTime/Calendar/Hebrew.pm'};

	Test::Without::Module->import('DateTime::Calendar::Hebrew');

	my $obj = $PKG->new();

	# Must carp about conversion failure (not die).
	warning_like(
		sub { $obj->parse_datetime('@#DHEBREW@ 9 Oct 2022') },
		qr/Hebrew calendar conversion failed/,
		'missing Hebrew module: parse_datetime carps',
	);

	# With quiet => 1 the carp must be suppressed and undef returned.
	warnings_are(
		sub {
			my $rc = $obj->parse_datetime(date => '@#DHEBREW@ 9 Oct 2022', quiet => 1);
			ok(!defined $rc, 'missing Hebrew module + quiet: returns undef');
		},
		[],
		'missing Hebrew module + quiet: no warnings',
	);

	Test::Without::Module->unimport('DateTime::Calendar::Hebrew');

	# Re-register the stub so later tests can still use it.
	$INC{'DateTime/Calendar/Hebrew.pm'} = 1;
};

subtest 'graceful degradation without DateTime::Calendar::FrenchRevolutionary' => sub {
	local %INC = %INC;
	delete $INC{'DateTime/Calendar/FrenchRevolutionary.pm'};

	Test::Without::Module->import('DateTime::Calendar::FrenchRevolutionary');

	my $obj = $PKG->new();

	warning_like(
		sub { $obj->parse_datetime('@#DFRENCH R@ 22 Sep 1792') },
		qr/French Republican calendar conversion failed/,
		'missing FrenchRevolutionary module: parse_datetime carps',
	);

	warnings_are(
		sub {
			my $rc = $obj->parse_datetime(date => '@#DFRENCH R@ 22 Sep 1792', quiet => 1);
			ok(!defined $rc, 'missing FrenchRevolutionary + quiet: returns undef');
		},
		[],
		'missing FrenchRevolutionary + quiet: no warnings',
	);

	Test::Without::Module->unimport('DateTime::Calendar::FrenchRevolutionary');
	$INC{'DateTime/Calendar/FrenchRevolutionary.pm'} = 1;
};

subtest 'graceful degradation with both optional calendar modules absent' => sub {
	local %INC = %INC;
	delete $INC{'DateTime/Calendar/Hebrew.pm'};
	delete $INC{'DateTime/Calendar/FrenchRevolutionary.pm'};

	Test::Without::Module->import(
		'DateTime::Calendar::Hebrew',
		'DateTime::Calendar::FrenchRevolutionary',
	);

	my $obj = $PKG->new(quiet => 1);

	# Core functionality must be completely unaffected.
	my $dt = $obj->parse_datetime('25 Dec 2022');
	isa_ok($dt, 'DateTime', 'core parse works without optional calendar modules');
	is($dt->dmy, '25-12-2022', 'correct date value');

	my $julian = $obj->parse_datetime('@#DJULIAN@ 15 Mar 1620');
	isa_ok($julian, 'DateTime', 'DJULIAN works without optional calendar modules');
	is($julian->day, 25, 'Julian offset still applied');

	# Both optional escapes must degrade gracefully (no die, no exception).
	my $h = $obj->parse_datetime('@#DHEBREW@ 9 Oct 2022');
	ok(!defined $h, 'DHEBREW with both absent returns undef (quiet)');

	my $f = $obj->parse_datetime('@#DFRENCH R@ 22 Sep 1792');
	ok(!defined $f, 'DFRENCH R with both absent returns undef (quiet)');

	Test::Without::Module->unimport(
		'DateTime::Calendar::Hebrew',
		'DateTime::Calendar::FrenchRevolutionary',
	);
	$INC{'DateTime/Calendar/Hebrew.pm'}             = 1;
	$INC{'DateTime/Calendar/FrenchRevolutionary.pm'} = 1;
};

# ===========================================================================
# SECTION 8: Class-method and bare-function calling forms
#
# All documented invocation styles must produce the same result regardless
# of whether a constructor was called first.
# ===========================================================================

subtest 'all documented calling forms produce consistent results' => sub {
	Readonly my $DATE   => '29 Sep 1939';
	Readonly my $EXPECT => '29-09-1939';

	my $obj = $PKG->new();

	my @forms = (
		[ sub { $obj->parse_datetime($DATE)->dmy },               'object + plain string'    ],
		[ sub { $obj->parse_datetime(date => $DATE)->dmy },       'object + named arg'       ],
		[ sub { $obj->parse_datetime({ date => $DATE })->dmy },   'object + hashref'         ],
		[ sub { $PKG->parse_datetime($DATE)->dmy },               'class method + string'    ],
		[ sub { $PKG->parse_datetime({ date => $DATE })->dmy },   'class method + hashref'   ],
		[ sub { DateTime::Format::Genealogy::parse_datetime($DATE)->dmy }, 'bare function'   ],
	);

	for my $pair (@forms) {
		my ($code, $label) = @{$pair};
		is($code->(), $EXPECT, $label);
	}
};

# ===========================================================================
# SECTION 9: Global state integrity across multiple calls
#
# parse_datetime must not clobber $_, $!, or $@ between calls.
# ===========================================================================

subtest 'parse_datetime does not clobber global variables across multiple calls' => sub {
	my $obj = $PKG->new(quiet => 1);

	# Prime $_ so a clobber would be detectable.
	local $_ = 'sentinel';

	$obj->parse_datetime('25 Dec 2022');
	is($_, 'sentinel', '$_ intact after successful parse');