view release on metacpan or  search on metacpan

t/integration.t  view on Meta::CPAN

	for my $marriage (@marriage_variants) {
		for my $death (@death_variants) {
			cmp_ok(datecmp($marriage, $death), '==', $LT,
				"'$marriage' < '$death' (marriage before death)");
		}
	}

	# Transitivity spot-check: birth < marriage < death
	cmp_ok(datecmp($DATE{birth_approx}, $DATE{marriage_exact}), '==', $LT,
		'birth (Abt. 1842) before marriage (1867-04-12)');
	cmp_ok(datecmp($DATE{marriage_exact}, $DATE{death_iso}), '==', $LT,
		'marriage (1867-04-12) before death (1902-11-23)');

	diag("Birth variants: @birth_variants") if $ENV{TEST_VERBOSE};
};

# ============================================================
# SECTION 4 — $dfg singleton stability across many calls
# ============================================================

# The module-level $dfg object is reused for every call.  Verify that
# exercising many different code paths does not corrupt the singleton
# and that all comparisons remain correct after repeated use.

subtest '$dfg singleton is the same object before and after many calls' => sub {
	my $dfg_identity_before = $Date::Cmp::dfg;

	# Drive calls through many distinct paths: fast-path years, approx
	# prefixes, DFG-parsed complex dates, BET ranges, and BEF qualifiers.
	datecmp('1900',              '1950');
	datecmp('Abt. 1850',        '1860');
	datecmp($DATE{complex_1},   $DATE{complex_2});
	datecmp($DATE{range_bet},   $DATE{range_mid});
	datecmp('bef 1 Jun 1965',   '1969');
	datecmp($DATE{event_1},     $DATE{event_2});
	datecmp('1929/06/26',       '1939');

	my $dfg_identity_after = $Date::Cmp::dfg;
	is($dfg_identity_before, $dfg_identity_after,
		'$dfg is the identical object after many varied calls');

	# Sanity: results are still correct after many prior calls.
	cmp_ok(datecmp('1800', '1900'), '==', $LT, 'comparison still correct after prior calls');
	cmp_ok(datecmp('1900', '1900'), '==', $EQ, 'equality still correct after prior calls');
	cmp_ok(datecmp('1900', '1800'), '==', $GT, 'reverse still correct after prior calls');
};

# ============================================================
# SECTION 5 — Complain-callback batch accumulation
# ============================================================

# In a batch-processing genealogy workflow a user collects all ambiguous-date
# warnings by passing the same callback to multiple datecmp calls.  Verify
# that callbacks from independent calls do not interfere with each other.

subtest 'complain callbacks accumulate correctly across multiple calls' => sub {
	my @diagnostics;
	my $collector = sub { push @diagnostics, @_ };

	# First ambiguous call: equal-endpoint range on RHS.
	my $r1 = silence_stderr { datecmp('1900', '1900-1900', $collector) };
	my $count_after_first = scalar @diagnostics;
	ok($count_after_first > 0, 'first ambiguous call invokes callback');

	# Clean call: must NOT add to the diagnostic list.
	my $r2 = datecmp('1800', '1900');
	is(scalar @diagnostics, $count_after_first,
		'clean call does not grow the diagnostic list');

	# Second ambiguous call: another equal-endpoint range.
	my $r3 = silence_stderr { datecmp('1850', '1850-1850', $collector) };
	ok(scalar @diagnostics > $count_after_first,
		'second ambiguous call adds more diagnostics');

	# Third ambiguous call: inverted left-side range.
	my $r4 = silence_stderr { datecmp('1832-1830', '1831', $collector) };
	ok(scalar @diagnostics > 0, 'total diagnostic count is positive');

	# All results must be integers.
	returns_is($r1, { type => 'integer' }, 'r1 (equal-endpoint) returns integer');
	returns_is($r2, { type => 'integer' }, 'r2 (clean)          returns integer');
	returns_is($r3, { type => 'integer' }, 'r3 (equal-endpoint) returns integer');
	returns_is($r4, { type => 'integer' }, 'r4 (inverted range) returns integer');

	diag('Diagnostics: ' . join('; ', @diagnostics)) if $ENV{TEST_VERBOSE};
};

# ============================================================
# SECTION 6 — Cross-format transitivity chain
# ============================================================

# For any three dates a, b, c: if a < b and b < c then a < c, regardless
# of the input format used for each.  This verifies that format normalisation
# is consistent across the boundary between different parsers.

subtest 'cross-format comparison chain satisfies transitivity' => sub {
	my @chain = (
		'1673-07-01',           # ISO date (16th/17th century)
		'26 Aug 1744',          # day-month-year string -> DFG
		$DATE{range_bet},       # BET 1830 AND 1832
		'Abt. 1880',            # approximate prefix
		'1902-11-23',           # ISO date
	);

	# Verify every consecutive pair is strictly increasing.
	for my $i (0 .. $#chain - 1) {
		cmp_ok(
			datecmp($chain[$i], $chain[$i + 1]),
			'==', $LT,
			"chain[$i] < chain[${\($i+1)}]: '$chain[$i]' < '$chain[$i+1]'",
		);
	}

	# Verify first < last (long-range transitivity).
	cmp_ok(datecmp($chain[0], $chain[-1]), '==', $LT,
		'first element is before last element (transitivity)');

	# Verify the reverse direction is consistently $GT.
	cmp_ok(datecmp($chain[-1], $chain[0]), '==', $GT,
		'last element is after first element (reverse transitivity)');
};

# ============================================================
# SECTION 7 — Mixed-type sort (objects, hashrefs, strings)
# ============================================================

# A real genealogy application may provide dates from heterogeneous sources:
# a model object from an ORM, a raw hashref from JSON, and a plain string
# from user input.  All three must sort together correctly.

{
	package GedcomRecord;
	sub new  { bless { date => $_[1] }, $_[0] }
	sub date { $_[0]->{date} }
}

subtest 'objects, hashrefs, and strings interoperate in a sort workflow' => sub {
	my @sources = (
		GedcomRecord->new('1 Jan 1802'),     # blessed object
		{ date => 'BET 1820 AND 1825' },     # hashref
		'1835',                              # plain string
		GedcomRecord->new('Abt. 1860'),      # blessed object, approx