Date-Cmp
view release on metacpan or search on metacpan
Revision history for Date::Cmp
0.06 Sat Jul 18 13:48:01 EDT 2026
[ Bug Fixes ]
- Fix crash when a DateTime object (parsed from a complex left-hand date such as
'1 Jan 1996') was compared against a year-range right-hand value ('1996-2000'
or 'BET 1996 AND 2000'): DateTime's overloaded == rejected the plain integer.
Move the ref($left)->year() unwrap before the first range comparison.
- Fix crash when a right-hand range had equal endpoints (e.g. '1900-1900'):
after collapsing to a single year the code fell through to the DFG fallback
path, which cannot parse a bare integer and died. Return the comparison
immediately after the complain callback instead.
- More stringent validation
- Bumped minimum Test::Returns for https://www.cpantesters.org/cpan/report/271a9e76-9ff9-11f0-ac80-9a301de8b9fd
[ Enhancements ]
- Added test dashboard
- Allow the dates to be hashrefs, in which case use the date element of the hash
- A blessed object with a `date()` method returning a date string.
- A hash reference with a `date` key whose value is a date string.
- `$right` (required)
The right-hand date. Accepts the same types as `$left`.
- `$complain` (optional)
A CODE reference invoked with a diagnostic string for ambiguous conditions:
equal range endpoints or an inverted range. `undef` and other falsy values
are silently ignored (the guard is never triggered). A truthy non-CODE
value causes an immediate `croak`.
### Returns
- `-1` — `$left` is earlier than `$right`
- `0` — the two dates are considered equivalent
- `1` — `$left` is later than `$right`
When either argument is `undef` (or resolves to `undef` after unwrapping),
lib/Date/Cmp.pm view on Meta::CPAN
=back
=item C<$right> (required)
The right-hand date. Accepts the same types as C<$left>.
=item C<$complain> (optional)
A CODE reference invoked with a diagnostic string for ambiguous conditions:
equal range endpoints or an inverted range. C<undef> and other falsy values
are silently ignored (the guard is never triggered). A truthy non-CODE
value causes an immediate C<croak>.
=back
=head3 Returns
=over 4
=item * C<-1> — C<$left> is earlier than C<$right>
t/extended_tests.t view on Meta::CPAN
# from right (= '200'). 100 != 200 → return -1.
# =========================================================================
subtest 'lowercase "bet" right — first-match tie-break (lines 341-348)' => sub {
# Fast-paths tie on trailing 1900; first-match extraction differs (100 vs 200).
is(datecmp('100 and 1900', 'bet 200 and 1900'), $LT,
'100 (left first-digit) < 200 (right first-digit) via bet path');
# Uppercase BET is handled by the separate range handler (line 361),
# NOT by this branch — confirm the two paths stay independent.
is(datecmp('1900', 'BET 1900 AND 1900', sub {}), $EQ,
'uppercase BET with same endpoints == 0 (handled by range handler)');
returns_ok(datecmp('100 and 1900', 'bet 200 and 1900'), { type => 'integer' },
'return value is a defined integer');
diag 'lines 341-348 exercised: lowercase bet, start(100) != end(200) → -1'
if $ENV{TEST_VERBOSE};
};
# =========================================================================
# 3. BEF right qualifier — left is a pure-digit string
t/extended_tests.t view on Meta::CPAN
# /^\d{3,4}\-\d{3,4}$/ match in right disables FP1.
# =========================================================================
subtest 'right range from==to with DateTime left (line 491)' => sub {
{
my $mock = MockDFG->new();
local $Date::Cmp::dfg = $mock;
$mock->enqueue([ Fake::DateTime->new(year => 1900) ]);
my $complaint;
is(datecmp('1 Feb 1900', '1900-1900', sub { $complaint = $_[0] }),
$EQ, 'DateTime left <=> same-endpoint RHS range = 0 (line 491)');
like($complaint, qr/from == to/,
'complain callback fires for same-endpoint range');
}
{
# Without complain: same result, no crash.
my $mock = MockDFG->new();
local $Date::Cmp::dfg = $mock;
$mock->enqueue([ Fake::DateTime->new(year => 1901) ]);
is(datecmp('1 Feb 1901', '1901-1901'), $EQ,
'DateTime year 1901 vs same-endpoint range 1901-1901 = 0');
}
returns_ok(
do {
my $mock = MockDFG->new();
local $Date::Cmp::dfg = $mock;
$mock->enqueue([ Fake::DateTime->new(year => 1900) ]);
datecmp('1 Feb 1900', '1900-1900');
},
{ type => 'integer' },
t/function.t view on Meta::CPAN
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
t/function.t view on Meta::CPAN
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
t/function.t view on Meta::CPAN
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
t/integration.t view on Meta::CPAN
# ============================================================
# 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
'format:bef-lhs' => 'BEF qualifier on left side',
'format:bef-rhs' => 'BEF qualifier on right side',
# --- Input: blessed object with date() method (POD: datecmp Arguments) ---
'input:object-date-method' => 'blessed object with date() method',
# --- Input: hashref with date key (POD: datecmp Arguments) ---
'input:hashref-date-key' => 'hashref with date key',
# --- Complain callback (POD: $complain argument) ---
'complain:equal-endpoints' => 'callback for range with equal endpoints',
'complain:inverted-range' => 'callback for inverted range on left',
# --- Error: undef input (POD: Returns / ERROR HANDLING) ---
'error:undef-left-returns-0' => 'undef left returns 0',
'error:undef-right-returns-0'=> 'undef right returns 0',
# --- Error: invalid leading character (POD: ERROR HANDLING) ---
'error:invalid-left-dies' => 'invalid left char dies',
'error:invalid-right-dies' => 'invalid right char dies',
cmp_ok(datecmp($h1, $h2), '==', $GT, 'hashref 1689 later than hashref 1659');
cmp_ok(datecmp($h2, $h1), '==', $LT, 'hashref 1659 earlier than hashref 1689');
cmp_ok(datecmp($h1, $h1), '==', $EQ, 'same hashref date equals itself');
delete $ledger{'input:hashref-date-key'};
};
# ---------------------------------------------------------------------------
# 10. Complain callback
# ---------------------------------------------------------------------------
subtest 'complain callback: equal endpoints on right-side range' => sub {
# A range like '1900-1900' has equal endpoints.
# The callback must be invoked; return value should still be numeric.
my @messages;
my $result = silence_stderr {
datecmp('1900', '1900-1900', sub { push @messages, @_ });
};
ok(scalar(@messages) > 0, 'callback was invoked for equal-endpoint range');
like($messages[0], qr/1900/, 'callback message references the year');
returns_is($result, { type => 'integer' }, 'result is still an integer');
delete $ledger{'complain:equal-endpoints'};
};
subtest 'complain callback: inverted range on left side' => sub {
# A range like '1832-1830' has from > to (inverted).
my @messages;
my $result = silence_stderr {
datecmp('1832-1830', '1831', sub { push @messages, @_ });
};
ok(scalar(@messages) > 0, 'callback was invoked for inverted left range');
returns_is($result, { type => 'integer' }, 'result is still an integer after inverted range');
( run in 1.175 second using v1.01-cache-2.11-cpan-9789f410c06 )