view release on metacpan or  search on metacpan

t/function.t  view on Meta::CPAN

	is(silence_stderr { datecmp('BEF. 1932', '2005-06-16') }, $LT,
		'BEF. 1932 < 2005-06-16');

	# Cases the code explicitly cannot handle fall back to 0 without dying
	is(silence_stderr { datecmp('aft 1900', 'BET 1890 AND 1910') }, $EQ,
		'unhandled aft/BET combo returns 0');
};

# =========================================================================
# 10. Approximate prefix stripping — left side
# "Abt.", "Abt", "ca.", "ca", and trailing "?" must all be stripped to
# expose the underlying year for numeric comparison.
# =========================================================================
subtest 'approximate prefix stripping on left side' => sub {
	is(datecmp('Abt. 1900', '1900'), $EQ, 'Abt. 1900 == 1900');
	is(datecmp('Abt 1900',  '1900'), $EQ, 'Abt (no dot) == 1900');
	is(datecmp('ca. 1900',  '1900'), $EQ, 'ca. 1900 == 1900');
	is(datecmp('ca 1900',   '1900'), $EQ, 'ca 1900 == 1900');
	is(datecmp('1900 ?',    '1900'), $EQ, 'trailing ? stripped');

	cmp_ok(datecmp('Abt. 1899', '1900'), '<', $EQ, 'Abt. 1899 < 1900');
	cmp_ok(datecmp('ca 1901',   '1900'), '>', $EQ, 'ca 1901 > 1900');
};

# =========================================================================
# 11. Month-range stripping — left side
# "Oct/Nov/Dec YYYY" and similar slash-separated month lists must be
# reduced to the year component before comparison.
# =========================================================================
subtest 'month range stripped to year on left side' => sub {
	is(datecmp('Oct/Nov/Dec 1950', '1950'),  $EQ, 'Oct/Nov/Dec 1950 == 1950');
	cmp_ok(datecmp('Oct/Nov/Dec 1949', '1950'), '<', $EQ,
		'Oct/Nov/Dec 1949 < 1950');
};

# =========================================================================
# 12. Left-side "or" range
# "1802 or 1803" uses the first (start) year.  If both years are the same
# the optional complain callback must be invoked.
# =========================================================================
subtest 'left-side "or" range uses start year and fires complain when equal' => sub {
	cmp_ok(datecmp('1802 or 1803', '1801'), '>', $EQ, '1802 or 1803 > 1801');
	cmp_ok(datecmp('1802 or 1803', '1804'), '<', $EQ, '1802 or 1803 < 1804');

	# The RHS must share the same year as the "or" range so the fast-path
	# year comparison ties and falls through to the "or" branch.  Using a
	# different RHS year (e.g. 1803) would cause the fast path to return
	# immediately and the complain callback would never be reached.
	my $complaint;
	datecmp('1802 or 1802', '1802', sub { $complaint = $_[0] });
	like($complaint, qr/the years are the same/, 'complain fires for same-year "or"');
};

# =========================================================================
# 13. Left-side date range (dash and BET forms)
# A range [from, to] on the LHS is compared with a scalar year on the RHS.
# - year < from  → range returns +1  (range is later)
# - year in [from,to] → 0
# - year > to    → range returns -1  (range is earlier)
# An inverted range (from > to) triggers the complain callback and returns 0.
# Equal endpoints collapse to a single year and also fire complain.
# =========================================================================
subtest 'left-side date range comparison (dash and BET forms)' => sub {
	# Dash form
	is(datecmp('1900-1902', '1899'), $GT,  'dash range > year before start');
	is(datecmp('1900-1902', '1900'), $EQ,  'dash range == start year');
	is(datecmp('1900-1902', '1901'), $EQ,  'dash range == mid year');
	is(datecmp('1900-1902', '1902'), $EQ,  'dash range == end year');
	is(datecmp('1900-1902', '1903'), $LT,  'dash range < year after end');

	# BET … AND … form must be equivalent for every case
	is(datecmp('BET 1900 AND 1902', '1899'), $GT,  'BET > year before');
	is(datecmp('BET 1900 AND 1902', '1901'), $EQ,  'BET == mid year');
	is(datecmp('BET 1900 AND 1902', '1903'), $LT,  'BET < year after');

	is(datecmp('1830-1832', '1831'),
	   datecmp('BET 1830 AND 1832', '1831'),
	   'dash and BET forms give identical results');

	# Inverted range (from > to): complain, return 0
	my $inv_complaint;
	is(silence_stderr { datecmp('1902-1900', '1901', sub { $inv_complaint = $_[0] }) },
		$EQ, 'inverted dash range returns 0');
	like($inv_complaint, qr/\d+ > \d+/, 'inverted range fires complain');

	# Same endpoints: collapse to that year, fire complain
	my $eq_complaint;
	is(datecmp('1900-1900', '1900', sub { $eq_complaint = $_[0] }),
		$EQ, 'same-endpoint range == that year');
	like($eq_complaint, qr/from == to/, 'same-endpoint range fires complain');
};

# =========================================================================
# 14. BEF qualifier on right side
# =========================================================================
subtest 'BEF qualifier on right side' => sub {
	# Plain integer LHS < bef-year on RHS → -1
	is(datecmp(1939, 'bef 1 Jun 1965'), $LT, '1939 < bef 1 Jun 1965');

	# The "Before not handled" fallback only fires when $left is not a plain
	# integer (i.e. it is a DateTime ref after DFG parsing), because the code
	# first checks "$left =~ /^\d+$/" and a ref does not satisfy that.
	# Using the same year forces all fast-path ties so DFG is reached.
	is(silence_stderr { datecmp('1 Jan 1900', 'bef 1900') }, $EQ,
		'unhandled BEF on RHS with DateTime LHS returns 0');
};

# =========================================================================
# 15. Approximate prefix stripping — right side
# =========================================================================
subtest 'approximate prefix stripping on right side' => sub {
	is(datecmp('1900', 'Abt. 1900'), $EQ, 'Abt. stripped on RHS');
	is(datecmp('1900', 'ca. 1900'),  $EQ, 'ca. stripped on RHS');
	is(datecmp('1900', 'ca 1900'),   $EQ, 'ca (no dot) stripped on RHS');
	is(datecmp('1900', '1900 ?'),    $EQ, 'trailing ? stripped on RHS');
	cmp_ok(datecmp('1901', 'ca 1900'), '>', $EQ, '1901 > ca 1900 after strip');
};

# =========================================================================
# 16. Month-range stripping — right side
# =========================================================================
subtest 'month range stripped to year on right side' => sub {
	is(datecmp('1892', 'Oct/Nov/Dec 1892'),     $EQ, 'RHS month range == year');
	cmp_ok(datecmp('1891', 'Oct/Nov/Dec 1892'), '<', $EQ,
		'year < RHS month-range year');
};

# =========================================================================
# 17. Right-side date range (dash and BET forms)
# Same semantics as section 13 but with the range on the RHS.
# =========================================================================
subtest 'right-side date range comparison (dash and BET forms)' => sub {
	is(datecmp(1899, 'BET 1900 AND 1902'), $LT,  'year before range < range');
	is(datecmp(1900, 'BET 1900 AND 1902'), $EQ,  'start year == range');
	is(datecmp(1901, 'BET 1900 AND 1902'), $EQ,  'mid year == range');
	is(datecmp(1902, 'BET 1900 AND 1902'), $EQ,  'end year == range');
	is(datecmp(1903, 'BET 1900 AND 1902'), $GT,  'year after range > range');

	is(datecmp(1831, '1830-1832'), $EQ,  'mid year == dash range');
	is(datecmp(1829, '1830-1832'), $LT,  'year before dash range');
	is(datecmp(1833, '1830-1832'), $GT,  'year after dash range');

	is(datecmp(1831, '1830-1832'),
	   datecmp(1831, 'BET 1830 AND 1832'),
	   'RHS dash and BET forms are equivalent');

	# Equal endpoints collapse to a single year and fire complain
	my $complaint;
	is(datecmp(1900, '1900-1900', sub { $complaint = $_[0] }),
		$EQ, 'same-endpoint RHS range == that year');
	like($complaint, qr/from == to/, 'same-endpoint RHS range fires complain');
};

# =========================================================================
# 18. Regression — DateTime object on LHS must be unwrapped before the
# right-side range comparison.
#
# Root cause: '1 Jan 1996' has its first \d{3,4} sequence as '1996',
# which equals the range start so the early-exit fast path does NOT fire.
# The string then falls through to DFG parsing and $left becomes a
# DateTime object.  The range handler's "$left == $to" comparison must
# unwrap $left first, or DateTime's overloaded == dies on a plain integer.
# =========================================================================
subtest 'DateTime LHS does not crash when compared against a year range' => sub {
	is(datecmp('1 Jan 1996', '1996-2000'),         $EQ, 'DateTime LHS within dash range');
	is(datecmp('1 Jan 1996', 'BET 1996 AND 2000'), $EQ, 'DateTime LHS within BET range');
	cmp_ok(datecmp('1 Jan 1994', '1996-2000'), '<', $EQ, 'DateTime LHS before dash range');
	cmp_ok(datecmp('1 Jan 2001', '1996-2000'), '>', $EQ, 'DateTime LHS after dash range');
};

# =========================================================================
# 19. DFG parsing path — controlled via mocked $dfg singleton
#
# We replace $Date::Cmp::dfg with a fresh MockDFG for each sub-case so
# queue state never leaks between assertions.
#
# Call-count verification uses MockDFG's built-in counter rather than
# Test::Mockingbird's spy(), which does not reliably intercept OO dispatch
# when the invocant is a non-DFG class installed via "local".
#
# For the failure paths we use Test::Mockingbird's mock() to override
# DateTime::Format::Genealogy::parse_datetime globally (and restore it
# with unmock() afterwards) so the real $dfg singleton returns nothing.
# =========================================================================
subtest 'DFG parsing paths (mocked $dfg)' => sub {
	# --- Left side parsed by DFG, right is a plain year ---
	# '1 Jan 1900' falls through all fast paths because its first \d{3,4}
	# match is 1900, which ties with the plain '1900' on the right; DFG
	# is therefore called for the left side and the returned year is used.
	{
		my $mock = MockDFG->new();
		local $Date::Cmp::dfg = $mock;
		$mock->enqueue([ Fake::DateTime->new(year => 1900) ]);
		is(datecmp('1 Jan 1900', '1900'), $EQ, 'DFG LHS year 1900 == plain 1900');
	}
	{
		my $mock = MockDFG->new();
		local $Date::Cmp::dfg = $mock;
		$mock->enqueue([ Fake::DateTime->new(year => 1899) ]);
		is(datecmp('1 Jan 1899', '1900'), $LT, 'DFG LHS year 1899 < plain 1900');
	}

	# --- Both sides parsed by DFG → final $left <=> $right via overloading ---
	# '1 Jan 1900' and '1 Feb 1900' share the same embedded year so every
	# fast-path numeric tie falls through.  After the left is replaced by a
	# Fake::DateTime that stringifies to "1900", the right-side fallback also
	# sees a tie and sends '1 Feb 1900' to DFG.  The mock returns a later
	# year for the right side; MockDFG.call_count() tracks invocations.
	{
		my $mock = MockDFG->new();
		local $Date::Cmp::dfg = $mock;