lib/Date/Cmp.pm

        start → end → jump
        

    1: package Date::Cmp;
    2: 
    3: # Compare two genealogy-style date strings with approximate-date support.
    4: # TODO: handle when only months are known (no year).
    5: 
    6: use strict;
    7: use warnings;
    8: 
    9: use autodie 2.06 qw(:all);
   10: use Carp qw(croak);
   11: use DateTime::Format::Genealogy 0.11;
   12: use Readonly;
   13: use Scalar::Util qw(blessed);
   14: use Term::ANSIColor;
   15: 
   16: use Exporter qw(import);
   17: our @EXPORT_OK = qw(datecmp);
   18: 
   19: # Characters permitted in any date string.
   20: # Covers every character that appears in a supported genealogy date:
   21: #   A-Za-z  — month abbreviations; BEF/BET/AFT/AND/Abt/ca prefixes
   22: #   0-9     — year and day digits
   23: #   (space) — component separator
   24: #   .       — Abt. prefix dot
   25: #   ,       — occasional list separator
   26: #   /       — slash-dates (M/D/YYYY) and month ranges (Oct/Nov/Dec)
   27: #   -       — ISO dates (YYYY-MM-DD) and year ranges (1830-1832)
   28: #   ?       — uncertainty suffix ("1828 ?")
   29: #   :       — ISO T-timestamp ("1941-08-02T00:00:00")
   30: Readonly my $DATE_CHARS => qr/[A-Ya-y0-9 .,\/\-?:]/;	# No month contains Z
   31: 
   32: =encoding utf-8
   33: 
   34: =head1 NAME
   35: 
   36: Date::Cmp - Compare two dates with approximate parsing support
   37: 
   38: =head1 VERSION
   39: 
   40: Version 0.06
   41: 
   42: =cut
   43: 
   44: our $VERSION = '0.06';
   45: 
   46: # Singleton DFG parser reused across calls for speed.  Tests may swap it
   47: # with a mock under "local $Date::Cmp::dfg = MockDFG->new()".
   48: our $dfg = DateTime::Format::Genealogy->new();
   49: 
   50: =head1 SYNOPSIS
   51: 
   52:   use Date::Cmp qw(datecmp);
   53: 
   54:   my $cmp = datecmp('1914', '1918');            # -1 (1914 is earlier)
   55:   my $cmp = datecmp('Abt. 1850', '1855');       # -1
   56:   my $cmp = datecmp('BET 1830 AND 1832', '1831'); # 0 (within range)
   57: 
   58:   # Optional complaint callback for ambiguous range edge-cases:
   59:   $cmp = datecmp('1996-2000', '1996',
   60:       sub { warn "ambiguous: @_" });
   61: 
   62: =head1 DESCRIPTION
   63: 
   64: C<Date::Cmp> provides a single exported function, C<datecmp>, which compares
   65: two date strings or date-like objects, returning a numeric result like Perl's
   66: C<< <=> >> operator.
   67: 
   68: The comparison handles approximate dates (C<Abt. 1902>, C<BET 1830 AND 1832>,
   69: C<Oct/Nov/Dec 1950>), partial dates (year-only), and the common genealogy
   70: qualifiers C<BEF> and C<AFT>.  Exact parsing delegates to
   71: L<DateTime::Format::Genealogy>; a cascade of fast-path heuristics handles
   72: the most common year-only comparisons without invoking the heavier parser.
   73: 
   74: =head1 FUNCTIONS
   75: 
   76: =head2 datecmp
   77: 
   78: =head3 Purpose
   79: 
   80: Compare two genealogy-style date strings (or date-like objects) and return
   81: a value equivalent to Perl's spaceship operator (C<< <=> >>): C<-1> if the
   82: left operand is earlier, C<0> if equivalent, or C<1> if later.
   83: 
   84: =head3 Arguments
   85: 
   86: =over 4
   87: 
   88: =item C<$left> (required)
   89: 
   90: The left-hand date.  Accepted types:
   91: 
   92: =over 8
   93: 
   94: =item * A string in any format listed under L</SUPPORTED FORMATS>.
   95: 
   96: =item * A blessed object with a C<date()> method returning a date string.
   97: 
   98: =item * A hash reference with a C<date> key whose value is a date string.
   99: 
  100: =back
  101: 
  102: =item C<$right> (required)
  103: 
  104: The right-hand date.  Accepts the same types as C<$left>.
  105: 
  106: =item C<$complain> (optional)
  107: 
  108: A CODE reference invoked with a diagnostic string for ambiguous conditions:
  109: equal range endpoints or an inverted range.  C<undef> and other falsy values
  110: are silently ignored (the guard is never triggered).  A truthy non-CODE
  111: value causes an immediate C<croak>.
  112: 
  113: =back
  114: 
  115: =head3 Returns
  116: 
  117: =over 4
  118: 
  119: =item * C<-1> — C<$left> is earlier than C<$right>
  120: 
  121: =item * C<0>  — the two dates are considered equivalent
  122: 
  123: =item * C<1>  — C<$left> is later than C<$right>
  124: 
  125: =back
  126: 
  127: When either argument is C<undef> (or resolves to C<undef> after unwrapping),
  128: the function prints a diagnostic to STDERR and returns C<0> rather than dying.
  129: On a fatal parse failure it dies; the exception string begins with
  130: C<"Date parse failure: ">.
  131: 
  132: =head3 Side Effects
  133: 
  134: May print coloured diagnostics to STDERR when dates cannot be parsed, when a
  135: range is inverted, or when an argument is undefined.  The C<$complain>
  136: callback is invoked (instead of STDERR output) for selected ambiguous
  137: conditions.
  138: 
  139: =head3 EXAMPLE
  140: 
  141:   use Date::Cmp qw(datecmp);
  142: 
  143:   # Plain years
  144:   datecmp('1900', '1950');              # -1
  145: 
  146:   # Approximate prefixes are stripped
  147:   datecmp('Abt. 1850', '1850');        # 0
  148:   datecmp('ca. 1799',  '1800');        # -1
  149: 
  150:   # Year ranges — any year within the range is "equal"
  151:   datecmp('1 Jan 1831', '1830-1832');  # 0
  152:   datecmp('BET 1830 AND 1832', '1829'); # 1  (range is later)
  153: 
  154:   # Blessed object with date() method
  155:   package MyDate;
  156:   sub new  { bless { d => $_[1] }, $_[0] }
  157:   sub date { $_[0]->{d} }
  158:   package main;
  159:   datecmp(MyDate->new('1900'), '1950'); # -1
  160: 
  161:   # Hash ref with 'date' key
  162:   datecmp({ date => '1900' }, '1950'); # -1
  163: 
  164:   # Sort a list of dates
  165:   my @sorted = sort { datecmp($a, $b) } qw(1832 Abt. 1800 1756 BET 1815 AND 1820);
  166: 
  167: =head3 API SPECIFICATION
  168: 
  169: =head4 Input
  170: 
  171:   $left    : Str | Object(date) | HashRef(date => Str)   # required
  172:   $right   : Str | Object(date) | HashRef(date => Str)   # required
  173:   $complain: CodeRef | undef | false                      # optional
  174: 
  175: Valid string formats (see L</SUPPORTED FORMATS>):
  176: 
  177:   exact    => qr/^\d{4}-\d{2}-\d{2}(?:T\d{2}:\d{2}:\d{2})?$/
  178:   slash    => qr{^\d+/\d+/\d{4}$}
  179:   year     => qr/^\d{3,4}$/
  180:   approx   => qr/^(?:Abt\.?|ca?\.?)\s+.+/i  |  qr/.+\s?\?$/
  181:   range    => qr/^\d{3,4}-\d{3,4}$/  |  qr/^BET \d+ AND \d+$/i
  182:   month_rng=> qr/^[a-z\/]+\s+\d{3,4}$/i
  183:   before   => qr/^bef\b/i
  184:   after    => qr/^aft\b/i
  185: 
  186: =head4 Output
  187: 
  188:   Int: -1 | 0 | 1
  189: 
  190:   Or croaks("Date parse failure: ...") when a date cannot be parsed.
  191:   Returns 0 (after STDERR output) when either argument is undef.
  192: 
  193: =head3 MESSAGES
  194: 
  195: The following diagnostics may be emitted.  B<[STDERR]> entries print a
  196: message and stack trace then return 0.  B<[croak]> entries die (catchable
  197: with C<eval {}>).
  198: 
  199: =over 4
  200: 
  201: =item B<[STDERR]> "left not defined" / "right not defined"
  202: 
  203: C<$left> or C<$right> was C<undef> on entry.
  204: 
  205: =item B<[STDERR]> "left date is undefined after input normalisation" / "right ..."
  206: 
  207: A hashref was passed with no C<date> key, or C<date =E<gt> undef>.
  208: 
  209: =item B<[croak]> "Third argument to datecmp() must be a CODE reference"
  210: 
  211: C<$complain> was truthy but not a C<CODE> reference (e.g. a string or
  212: array-ref).
  213: 
  214: =item B<[croak]> "Date parse failure: left is an unsupported reference type (...)"
  215: 
  216: C<$left> was a reference that could not be unwrapped (not a blessed
  217: C<date()>-capable object and not a hash).
  218: 
  219: =item B<[croak]> "Date parse failure: right is an unsupported reference type (...)"
  220: 
  221: Same for C<$right>.
  222: 
  223: =item B<[croak]> "Date parse failure: left contains characters not permitted in a date string"
  224: 
  225: C<$left> contained a character outside the allowed set
  226: C<[A-Za-z0-9 .,/-?:]>.  The string is rejected before any parsing.
  227: 
  228: =item B<[croak]> "Date parse failure: right contains characters not permitted in a date string"
  229: 
  230: Same for C<$right>.
  231: 
  232: =item B<[croak]> "Date parse failure: left = ... (year must be 3-4 digits)"
  233: 
  234: C<$left> was a bare integer with 5 or more digits.
  235: 
  236: =item B<[croak]> "Date parse failure: right = ... (year must be 3-4 digits)"
  237: 
  238: Same for C<$right>.
  239: 
  240: =item B<[croak]> "Date parse failure: left = ..."
  241: 
  242: C<$left> failed the first-character semantic check or could not be parsed
  243: by DFG.
  244: 
  245: =item B<[croak]> "Date parse failure: right = ..."
  246: 
  247: C<$right> could not be parsed by DFG (and no year suffix was extractable).
  248: 
  249: =item B<[STDERR]> "... <=> ...: not handled yet"
  250: 
  251: A C<BEF>/C<AFT> qualifier on the left with a right-hand value that does not
  252: fit any handled pattern.  Returns 0.
  253: 
  254: =item B<[STDERR]> "... <=> ...: Before not handled"
  255: 
  256: A C<BEF> qualifier on the right with a left-hand value that is not a plain
  257: integer.  Returns 0.
  258: 
  259: =item B<[STDERR]> "datecmp(): N > M in daterange ..."
  260: 
  261: The right-hand year range was inverted (C<from E<gt> to>).  Returns 0.
  262: 
  263: =back
  264: 
  265: =head3 PSEUDOCODE
  266: 
  267:   1.  Validate $complain: croak if truthy but not a CODE reference.
  268:   2.  Guard undef: if either input is undef → STDERR + stack trace + return 0.
  269:   3.  Normalise: blessed date()-objects → call date(); hash refs → 'date' key.
  270:   4.  Guard post-normalise undef → STDERR + stack trace + return 0.
  271:   5.  Reject surviving reference types (croak).
  272:   6.  Identity short-circuit: return 0 if left eq right (no parsing needed).
  273:   7.  Taint-scrub: validate all characters against $DATE_CHARS;
  274:       also produces untainted copies safe for use under perl -T.
  275:   8.  First-char semantic check: first char must be [A-S0-9] (croak if not).
  276:   9.  Reject 5+ digit bare integers (croak).
  277:   10. Fast path 1: 4-digit year in both non-range strings → return if differ.
  278:   11. Fast path 2: trailing 3-4 digit year in both → return if differ.
  279:   12. Normalise LEFT (if string):
  280:       a.  Strip trailing ISO T-timestamp.
  281:       b.  Fast path 3: trailing 4-digit years in both → return if differ.
  282:       c.  BEF/AFT on left: numeric-right or BEF-with-4-digit-right handled;
  283:           otherwise STDERR + stack trace + return 0.
  284:       d.  Strip approximate prefix (Abt./ca.) or suffix (?) or month-range.
  285:       e.  Fast path 4: digit-starting years on both sides → return if differ.
  286:       f.  Fast path 5: left year vs right starting with lowercase "bet".
  287:       g.  "YEAR or YEAR" form: use first year; fire $complain if both equal.
  288:       h.  Dash / BET range on left: compare $right against [from, to].
  289:       i.  Complex date string: parse via DFG (croak if DFG returns nothing).
  290:   13. Normalise RIGHT (if string):
  291:       a.  BEF on right: numeric left → compare; otherwise STDERR + return 0.
  292:       b.  Strip approximate prefix/suffix/month-range.
  293:       c.  Bare 3-4 digit year: compare directly with left (unwrap if ref).
  294:       d.  Dash / BET range on right: compare $left against [from, to].
  295:       e.  Fast path 6: matching year in both → return if differ.
  296:       f.  Parse right via DFG (croak if DFG returns nothing).
  297:   14. Final comparison: unwrap any remaining DateTime objects via ->year(); <=>.
  298: 
  299: =head1 SUPPORTED FORMATS
  300: 
  301: =over 4
  302: 
  303: =item * Exact dates: C<1941-08-02>, C<5/27/1872>
  304: 
  305: =item * Years only: C<1828>, C<822>
  306: 
  307: =item * Approximate dates: C<Abt. 1802>, C<ca. 1802>, C<1802 ?>
  308: 
  309: =item * Date ranges: C<1802-1803>, C<BET 1830 AND 1832>
  310: 
  311: =item * Month ranges: C<Oct/Nov/Dec 1950>
  312: 
  313: =item * Qualifiers: C<BEF 1940>, C<AFT 1855>
  314: 
  315: =back
  316: 
  317: =head1 ERROR HANDLING
  318: 
  319: When a date cannot be parsed, diagnostic messages are printed to STDERR and
  320: the function either returns 0 (for recoverable conditions such as undef
  321: input) or C<croak>s with a string beginning C<"Date parse failure: ">.
  322: All C<croak> exceptions are catchable via C<eval {}>.
  323: 
  324: =head1 LIMITATIONS
  325: 
  326: =over 4
  327: 
  328: =item * B<Month-only dates>
  329: 
  330: Dates where only the month is known (no year) are not supported.
  331: 
  332: =item * B<Incomplete BEF/AFT handling>
  333: 
  334: Many C<BEF>/C<AFT> combinations—especially C<AFT> on the left or C<BEF>
  335: against a non-integer right—are not implemented and fall back to returning
  336: 0 with a STDERR diagnostic.
  337: 
  338: =item * B<Dead fast-path code>
  339: 
  340: Certain fast-path branches and a redundant C<ref($right)> guard inside the
  341: left-side range handler are unreachable at runtime (documented in
  342: C<t/extended_tests.t> subtest 10).
  343: 
  344: =item * B<Public singleton>
  345: 
  346: C<$Date::Cmp::dfg> is a package variable.  Concurrent threads replacing it
  347: with different mocks are not safe.
  348: 
  349: =item * B<No Sub::Private enforcement>
  350: 
  351: The C<_sanitize_for_diag> and C<_emit_stack_trace> private helpers rely on
  352: naming convention only.  Runtime enforcement via C<Sub::Private> is not yet
  353: declared as a dependency.
  354: 
  355: =back
  356: 
  357: =cut
  358: 
  359: sub datecmp
  360: {
●361 → 368 → 373  361: 	my ($left, $right, $complain) = @_;
  362: 
  363: 	# Reject truthy non-CODE $complain early.  A falsy value (undef, 0, "")
  364: 	# is never invoked because every call site guards with "if($complain)",
  365: 	# so skipping validation for falsy values is safe.  A truthy string would
  366: 	# call an arbitrary named sub under no strict refs, which is a security
  367: 	# risk — reject it now.
  368: 	if($complain && ref($complain) ne 'CODE') {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  369: 		croak 'Third argument to datecmp() must be a CODE reference';
  370: 	}
  371: 
  372: 	# Undef on entry: recoverable — print diagnostic and return 0.
●373 → 373 → 382  373: 	if((!defined $left) || !defined $right) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  374: 		print STDERR "\n";
  375: 		print STDERR "left not defined\n"  if !defined $left;
  376: 		print STDERR "right not defined\n" if !defined $right;
  377: 		_emit_stack_trace();
  378: 		return 0;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  379: 	}
  380: 
  381: 	# Unwrap: blessed object with date() → string; hashref → 'date' key.
●382 → 382 → 383  382: 	if(blessed($left)  && $left->can('date'))  { $left  = $left->date(); }
  Mutants (Total: 1, Killed: 1, Survived: 0)
●383 → 383 → 384  383: 	if(blessed($right) && $right->can('date')) { $right = $right->date(); }
  Mutants (Total: 1, Killed: 1, Survived: 0)
●384 → 384 → 385  384: 	if(ref($left)  eq 'HASH') { $left  = $left->{'date'}; }
  Mutants (Total: 1, Killed: 1, Survived: 0)
●385 → 385 → 389  385: 	if(ref($right) eq 'HASH') { $right = $right->{'date'}; }
  Mutants (Total: 1, Killed: 1, Survived: 0)
  386: 
  387: 	# A hashref without a 'date' key, or with date => undef, arrives here as
  388: 	# undef.  Any other surviving reference would stringify silently — reject.
●389 → 389 → 396  389: 	if(!defined $left || !defined $right) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  390: 		print STDERR "\n";
  391: 		print STDERR "left date is undefined after input normalisation\n"  if !defined $left;
  392: 		print STDERR "right date is undefined after input normalisation\n" if !defined $right;
  393: 		_emit_stack_trace();
  394: 		return 0;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  395: 	}
●396 → 396 → 399  396: 	if(ref($left)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  397: 		croak 'Date parse failure: left is an unsupported reference type (' . ref($left) . ')';
  398: 	}
●399 → 399 → 404  399: 	if(ref($right)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  400: 		croak 'Date parse failure: right is an unsupported reference type (' . ref($right) . ')';
  401: 	}
  402: 
  403: 	# Identical strings — no parsing needed at all.
●404 → 413 → 416  404: 	return 0 if $left eq $right;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  405: 
  406: 	# Taint-scrub: validate every character in both inputs.  A full-string
  407: 	# anchored capture against the allowed class (a) rejects shell
  408: 	# metacharacters, newlines, NUL bytes, and HTML characters, and (b)
  409: 	# produces an untainted copy, making datecmp safe under perl -T.
  410: 	my ($safe_left)  = ($left  =~ /^($DATE_CHARS+)$/);
  411: 	my ($safe_right) = ($right =~ /^($DATE_CHARS+)$/);
  412: 
  413: 	if(!defined $safe_left) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  414: 		croak 'Date parse failure: left contains characters not permitted in a date string';
  415: 	}
●416 → 416 → 420  416: 	if(!defined $safe_right) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  417: 		croak 'Date parse failure: right contains characters not permitted in a date string';
  418: 	}
  419: 
●420 → 427 → 431  420: 	$left  = $safe_left;
  421: 	$right = $safe_right;
  422: 
  423: 	# Semantic first-character check: all supported formats begin with a
  424: 	# letter A-S (month abbreviations Jan-Sep, Oct=O, Nov=N, Dec=D; prefixes
  425: 	# BEF/BET/AFT/Abt/ca) or a digit (year-first formats).  Letters T-Z as
  426: 	# the leading character do not appear in any supported format.
  427: 	if($left !~ /^[A-S0-9]/i) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  428: 		_emit_stack_trace();
  429: 		croak 'Date parse failure: left = ' . _sanitize_for_diag($left);
  430: 	}
●431 → 431 → 438  431: 	if($right !~ /^[A-S0-9]/i) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  432: 		_emit_stack_trace();
  433: 		croak 'Date parse failure: right = ' . _sanitize_for_diag($right);
  434: 	}
  435: 
  436: 	# Reject bare integers with 5+ digits — they are not valid year strings
  437: 	# and the fast-path regexes would silently extract the wrong substring.
●438 → 438 → 441  438: 	if($left =~ /^\d{5,}$/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  439: 		croak 'Date parse failure: left = ' . $left . ' (year must be 3-4 digits)';
  440: 	}
●441 → 441 → 448  441: 	if($right =~ /^\d{5,}$/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  442: 		croak 'Date parse failure: right = ' . $right . ' (year must be 3-4 digits)';
  443: 	}
  444: 
  445: 	# ── Fast path 1 ─────────────────────────────────────────────────────────
  446: 	# Both strings contain a 4-digit year, neither is a BET/dash-range.
  447: 	# If the years differ we can return immediately without further parsing.
●448 → 448 → 464  448: 	if((!ref($left)) && (!ref($right))
  Mutants (Total: 1, Killed: 1, Survived: 0)
  449: 		&& ($left  =~ /\d{3,4}/) && ($right =~ /\d{3,4}/)
  450: 		&& ($left  !~ /^bet/i)   && ($left  !~ /\-/)
  451: 		&& ($right !~ /^bet/i)   && ($right !~ /^\d{3,4}\-\d{3,4}$/))
  452: 	{
  453: 		if($left =~ /(\d{4})/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  454: 			my $lyear = $1;
  455: 			if($right =~ /(\d{4})/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  456: 				my $ryear = $1;
  457: 				return $lyear <=> $ryear if $lyear != $ryear;
  Mutants (Total: 3, Killed: 3, Survived: 0)
  458: 			}
  459: 		}
  460: 	}
  461: 
  462: 	# ── Fast path 2 ─────────────────────────────────────────────────────────
  463: 	# Both strings END with a 3-4 digit year, neither is a BET/dash-range.
●464 → 464 → 475  464: 	if((!ref($left)) && (!ref($right))
  Mutants (Total: 1, Killed: 1, Survived: 0)
  465: 		&& ($left  =~ /(\d{3,4})$/) && ($left  !~ /^bet/i) && ($left  !~ /\-/)
  466: 		&& ($right !~ /^bet/i)       && ($right !~ /\-/))
  467: 	{
  468: 		my $yol = $1;
  469: 		if($right =~ /(\d{3,4})$/) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_469_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  470: 			my $yor = $1;
  471: 			return $yol <=> $yor if $yol != $yor;
  Mutants (Total: 3, Killed: 3, Survived: 0)
  472: 		}
  473: 	}
  474: 
●475 → 475 → 623  475: 	if(!ref($left)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  476: 		# Strip trailing ISO T-timestamp before further checks.
  477: 		$left =~ s/T\d\d:\d\d:\d\d$//;
  478: 
  479: 		# ── Fast path 3 ─────────────────────────────────────────────────
  480: 		# Both strings end with a 4-digit year (after space or slash).
  481: 		# Note: fast-paths 1 and 2 handle all cases where the extracted
  482: 		# years differ, so the return inside this block is unreachable in
  483: 		# practice — but the outer if still serves to tie-break below.
  484: 		if((!ref($right))
  Mutants (Total: 1, Killed: 1, Survived: 0)
  485: 			&& ($left  =~ /(^|[\s\/])\d{4}$/)
  486: 			&& ($left  !~ /^bet/i) && ($left  !~ /\-/)
  487: 			&& ($right !~ /^bet/i) && ($right !~ /\-/)
  488: 			&& ($right =~ /(^|[\s\/,])(\d{4})$/))
  489: 		{
  490: 			my $ryear = $2;
  491: 			$left =~ /(^|[\s\/])(\d{4})$/;
  492: 			my $lyear = $2;
  493: 			return $lyear <=> $ryear if $lyear != $ryear;

					

					
Mutants (Total: 3, Killed: 1, Survived: 2)
					

				
BOOL_NEGATE_493_4: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_493_4: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
  494: 		}
  495: 
  496: 		# ── BEF / AFT on left side ───────────────────────────────────────
  497: 		if($left =~ /^(bef|aft)/i) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  498: 			if($right =~ /^\d+$/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  499: 				# e.g. "bef 1 Jun 1965" vs "1969"
  500: 				if($left =~ /\s(\d+)$/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  501: 					return -1 if $1 < $right;
  Mutants (Total: 5, Killed: 5, Survived: 0)
  502: 				}
  503: 			}
  504: 			if($right =~ /(\d{4})/) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_504_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  505: 				# e.g. "BEF. 1932" vs "2005-06-16"
  506: 				my $ryear = $1;
  507: 				if($left =~ /^bef/i && $left =~ /(\d{4})/) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_507_5: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  508: 					return -1 if $1 < $ryear;

					

					
Mutants (Total: 5, Killed: 0, Survived: 5)
					

				
NUM_BOUNDARY_508_22_>: Numeric boundary flip < to >
HIGH: Likely missing edge-case test (boundary value)

								

								
🧪 Suggested Test
								
# Boundary test suggestion
is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );

								
							
NUM_BOUNDARY_508_22_<=: Numeric boundary flip < to <=
HIGH: Likely missing edge-case test (boundary value)

								

								
🧪 Suggested Test
								
# Boundary test suggestion
is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );

								
							
NUM_BOUNDARY_508_22_>=: Numeric boundary flip < to >=
HIGH: Likely missing edge-case test (boundary value)

								

								
🧪 Suggested Test
								
# Boundary test suggestion
is( func(VALUE_AT_BOUNDARY), EXPECTED, 'Test boundary behaviour' );

								
							
BOOL_NEGATE_508_6: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_508_6: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
  509: 				}
  510: 			}
  511: 			print STDERR _sanitize_for_diag($left) . ' <=> ' . _sanitize_for_diag($right) . ": not handled yet\n";
  512: 			_emit_stack_trace();
  513: 			return 0;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  514: 		}
  515: 
  516: 		# ── Approximate prefix / suffix stripping ────────────────────────
  517: 		if($left =~ /^(Abt|ca?)\.?\s+(.+)/i) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  518: 			$left = $2;
  519: 		} elsif($left =~ /(.+?)\s?\?$/) {
  520: 			$left = $1;
  521: 		} elsif(($left =~ /\//) && ($left =~ /^[a-z\/]+\s+(.+)/i)) {
  522: 			# e.g. "Oct/Nov/Dec 1950" → "1950"
  523: 			$left = $1;
  524: 		}
  525: 
  526: 		# ── Fast path 4 ─────────────────────────────────────────────────
  527: 		# After stripping, both sides start with a 3-4 digit year.
  528: 		if(($left =~ /^\d{3,4}/) && ($left !~ /\-/)
  Mutants (Total: 1, Killed: 1, Survived: 0)
  529: 			&& ($right =~ /^\d{3,4}/) && ($right !~ /\-/))
  530: 		{
  531: 			$left  =~ /^(\d{3,4})/; my $start = $1;
  532: 			$right =~ /^(\d{3,4})/; my $end   = $1;
  533: 			return $start <=> $end if $start != $end;

					

					
Mutants (Total: 3, Killed: 1, Survived: 2)
					

				
BOOL_NEGATE_533_4: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_533_4: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
  534: 		}
  535: 
  536: 		# ── Fast path 5 ─────────────────────────────────────────────────
  537: 		# Left contains a year; right starts with lowercase "bet" (the
  538: 		# BET range handler below uses case-insensitive /^Bet .../i so
  539: 		# this catches the bare lowercase form first).
  540: 		if($left =~ /(\d{3,4})/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  541: 			my $start = $1;
  542: 			if(($left !~ /^bet/i) && ($right =~ /^bet/)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  543: 				if($right =~ /(\d{3,4})/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  544: 					my $end = $1;
  545: 					return $start <=> $end if $start != $end;
  Mutants (Total: 3, Killed: 3, Survived: 0)
  546: 				}
  547: 			}
  548: 		}
  549: 
  550: 		# ── "YEAR or YEAR" format ────────────────────────────────────────
  551: 		if($left =~ /^(\d{3,4})\sor\s(\d{3,4})$/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  552: 			my ($start, $end) = ($1, $2);
  553: 			$complain->("the years are the same '$left'") if $complain && $start == $end;
  Mutants (Total: 1, Killed: 1, Survived: 0)
  554: 			$left = $start;
  555: 		}
  556: 		# ── Left-side dash / BET range ───────────────────────────────────
  557: 		elsif(($left =~ /^(\d{3,4})\-(\d{3,4})$/)
  558: 			|| ($left =~ /^Bet (\d{3,4})\sand\s(\d{3,4})$/i))
  559: 		{
  560: 			my ($from, $to) = ($1, $2);
  561: 
  562: 			if($from == $to) {
  Mutants (Total: 2, Killed: 2, Survived: 0)
  563: 				# Degenerate range: collapse to single year.
  564: 				$complain->("from == to, $from") if $complain;
  565: 				$left = $from;
  566: 
  567: 			} elsif($from > $to) {
  Mutants (Total: 3, Killed: 3, Survived: 0)
  568: 				# Inverted range: fire complain and give up.
  569: 				$complain->("datecmp(): $from > $to in daterange '$left'") if $complain;
  570: 				return 0;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  571: 
  572: 			} else {
  573: 				# Parse $right to a plain year integer if it isn't already.
  574: 				if($right !~ /^\d{4}$/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  575: 					my @r = $dfg->parse_datetime({ date => $right, quiet => 1 });
  576: 					if(!defined $r[0]) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  577: 						if($right =~ /[\s\/](\d{4})$/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  578: 							# e.g. 'BET 1830 AND 1832' vs 'Oct/Nov/Dec 1821'
  579: 							# $left is the range string here; use $from/$to.
  580: 							my $year = $1;
  581: 							return $year < $from ?  1
  Mutants (Total: 5, Killed: 5, Survived: 0)
  582: 							     : $year > $to   ? -1
  Mutants (Total: 3, Killed: 3, Survived: 0)
  583: 							     :                  0;
  584: 						}
  585: 						# croak is catchable via eval{}, resolving the prior TODO.
  586: 						_emit_stack_trace();
  587: 						croak 'Date parse failure: right = ' . _sanitize_for_diag($right);
  588: 					}
  589: 					$right = $r[0]->year();
  590: 				}
  591: 
  592: 				# Compare the single right year against [from, to].
  593: 				# Any year within the interval (inclusive) is "equal".
  594: 				return  1 if $right < $from;   # right predates range: range is later
  Mutants (Total: 5, Killed: 5, Survived: 0)
  595: 				return -1 if $right > $to;      # right postdates range: range is earlier
  Mutants (Total: 5, Killed: 5, Survived: 0)
  596: 				return  0;                       # right within [from, to]
  Mutants (Total: 2, Killed: 2, Survived: 0)
  597: 			}
  598: 		}
  599: 		# ── Complex left-side date string → DFG ─────────────────────────
  600: 		elsif($left !~ /^\d{3,4}$/) {
  601: 			if($left !~ /^\d{4}\-\d{2}\-\d{2}$/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  602: 				# Not an ISO date — validate it has letters in valid positions.
  603: 				if(($left !~ /[a-z]/i) || ($left =~ /[a-z]$/)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  604: 					_emit_stack_trace();
  605: 					croak 'Date parse failure: left = ' . _sanitize_for_diag($left);
  606: 				}
  607: 			}
  608: 
  609: 			# $l[1] is preferred over $l[0]: for genealogy date ranges DFG
  610: 			# may return (start_DateTime, end_DateTime); using the end date
  611: 			# gives a consistent upper-bound for range inputs.
  612: 			my @l = $dfg->parse_datetime({ date => $left, quiet => 1 });
  613: 			my $rc = $l[1] || $l[0];
  614: 			if(!defined $rc) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  615: 				_emit_stack_trace();
  616: 				croak 'Date parse failure: left = ' . _sanitize_for_diag($left);
  617: 			}
  618: 			$left = $rc;
  619: 		}
  620: 	}
  621: 
  622: 	# ── Right side ──────────────────────────────────────────────────────────
●623 → 623 → 711  623: 	if(!ref($right)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  624: 		# ── BEF on right ────────────────────────────────────────────────
  625: 		if($right =~ /^bef/i) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  626: 			if($left =~ /^\d+$/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  627: 				# e.g. "1939" vs "bef 1 Jun 1965"
  628: 				if($right =~ /\s(\d+)$/) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_628_5: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  629: 					return $left <=> $1;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  630: 				}
  631: 			}
  632: 			print STDERR _sanitize_for_diag($left) . ' <=> ' . _sanitize_for_diag($right) . ": Before not handled\n";
  633: 			_emit_stack_trace();
  634: 			return 0;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  635: 		}
  636: 
  637: 		# ── Approximate prefix / suffix stripping ────────────────────────
  638: 		if($right =~ /^(Abt|ca?)\.?\s+(.+)/i) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  639: 			$right = $2;
  640: 		} elsif($right =~ /(.+?)\s?\?$/) {
  641: 			$right = $1;
  642: 		} elsif(($right =~ /\//) && ($right =~ /^[a-z\/]+\s+(.+)/i)) {
  643: 			$right = $1;
  644: 		}
  645: 
  646: 		# ── Bare year on right ───────────────────────────────────────────
  647: 		if($right =~ /^\d{3,4}$/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  648: 			return ref($left) ? $left->year() <=> $right : $left <=> $right;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  649: 		}
  650: 
  651: 		# ── Right-side dash / BET range ──────────────────────────────────
  652: 		if(($right =~ /^(\d{3,4})\-(\d{3,4})$/)
  Mutants (Total: 1, Killed: 1, Survived: 0)
  653: 			|| ($right =~ /^Bet (\d{3,4})\sand\s(\d{3,4})$/i))
  654: 		{
  655: 			my ($from, $to) = ($1, $2);
  656: 
  657: 			if($from == $to) {
  Mutants (Total: 2, Killed: 2, Survived: 0)
  658: 				# Degenerate range: fire complain then compare directly.
  659: 				$complain->("from == to, $from") if $complain;
  660: 				# Return immediately rather than falling through to DFG,
  661: 				# which cannot parse a bare integer.
  662: 				return ref($left) ? $left->year() <=> $from : $left <=> $from;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  663: 
  664: 			} elsif($from > $to) {
  Mutants (Total: 3, Killed: 3, Survived: 0)
  665: 				print STDERR 'datecmp(): ' . $from . ' > ' . $to . ' in daterange ' . _sanitize_for_diag($right) . "\n";
  666: 				_emit_stack_trace();
  667: 				return 0;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  668: 
  669: 			} else {
  670: 				# Unwrap any DateTime before numeric comparison.
  671: 				if(ref($left)) { $left = $left->year(); }
  Mutants (Total: 1, Killed: 1, Survived: 0)
  672: 
  673: 				# Compare left year against [from, to].
  674: 				return -1 if $left < $from;   # left predates range: left is earlier
  Mutants (Total: 5, Killed: 5, Survived: 0)
  675: 				return  1 if $left > $to;      # left postdates range: left is later
  Mutants (Total: 5, Killed: 5, Survived: 0)
  676: 				return  0;                      # left within [from, to]
  Mutants (Total: 2, Killed: 2, Survived: 0)
  677: 			}
  678: 		}
  679: 
  680: 		# ── Fast path 6 ──────────────────────────────────────────────────
  681: 		# Both sides still contain a 3-4 digit year; return if they differ.
  682: 		if($left =~ /(\d{3,4})/) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_682_3: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  683: 			my $start = $1;
  684: 			if($right =~ /(\d{3,4})/) {

					

					
Mutants (Total: 1, Killed: 0, Survived: 1)
					

				
COND_INV_684_4: Invert condition if to unless
MEDIUM: Add tests asserting both true and false outcomes

  685: 				my $end = $1;
  686: 				return $start <=> $end if $start != $end;
  Mutants (Total: 3, Killed: 3, Survived: 0)
  687: 			}
  688: 		}
  689: 
  690: 		# ── Right-side DFG parse ─────────────────────────────────────────
  691: 		my @r = $dfg->parse_datetime({ date => $right, quiet => 1 });
  692: 		if(!defined $r[0]) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  693: 			if($right =~ /[\s\/](\d{4})$/) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  694: 				# e.g. "1891" vs "Oct/Nov/Dec 1892" or "5/27/1872"
  695: 				my $year = $1;
  696: 				if(ref($left)) {
  Mutants (Total: 1, Killed: 1, Survived: 0)
  697: 					return $left->year() <=> $year if $left->year() != $year;
  Mutants (Total: 3, Killed: 3, Survived: 0)
  698: 				} else {
  699: 					return $left <=> $year if $left != $year;

					

					
Mutants (Total: 3, Killed: 1, Survived: 2)
					

				
BOOL_NEGATE_699_6: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_699_6: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
  700: 				}
  701: 			}
  702: 			# croak is catchable via eval{}, resolving the prior TODO.
  703: 			_emit_stack_trace();
  704: 			croak 'Date parse failure: right = ' . _sanitize_for_diag($right);
  705: 		}
  706: 		$right = $r[0];
  707: 	}
  708: 
  709: 	# ── Final comparison ─────────────────────────────────────────────────────
  710: 	# Unwrap any remaining DateTime objects and compare numerically.
  711: 	return $left  <=> $right->year() if !ref($left)  && ref($right);
  Mutants (Total: 2, Killed: 2, Survived: 0)
  712: 	return $left->year() <=> $right  if  ref($left)  && !ref($right);

					

					
Mutants (Total: 2, Killed: 0, Survived: 2)
					

				
BOOL_NEGATE_712_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_712_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
  713: 	return $left <=> $right;
  Mutants (Total: 2, Killed: 2, Survived: 0)
  714: }
  715: 
  716: # ─────────────────────────────────────────────────────────────────────────────
  717: # _sanitize_for_diag($val)
  718: #
  719: # Purpose:      Produce a safe printable-ASCII rendering of a user-supplied
  720: #               string for inclusion in log/error output.  Prevents log
  721: #               injection (CWE-117) via embedded newlines, NUL bytes, or ANSI
  722: #               escape sequences.
  723: # Entry:        $val — any scalar; may be undef.
  724: # Exit:         Defined printable string ≤200 chars.  '(undef)' if input is
  725: #               undef.  Non-printable bytes (outside \x20–\x7E) replaced with
  726: #               literal periods.
  727: # ─────────────────────────────────────────────────────────────────────────────
  728: sub _sanitize_for_diag {
  729: 	my ($val) = @_;
  730: 	return '(undef)' if !defined $val;

					

					
Mutants (Total: 2, Killed: 0, Survived: 2)
					

				
BOOL_NEGATE_730_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_730_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
  731: 	(my $safe = substr($val, 0, 200)) =~ s/[^\x20-\x7E]/./g;
  732: 	return $safe;

					

					
Mutants (Total: 2, Killed: 0, Survived: 2)
					

				
BOOL_NEGATE_732_2: Negate boolean return expression
MEDIUM: Add tests asserting both true and false outcomes

								

								
🧪 Suggested Test
								
# Boolean branch test suggestion
ok( !func(INPUT), 'Verify boolean branch behaviour' );

								
							
RETURN_UNDEF_732_2: Replace return expression with undef
LOW: Mutation survived, but impact may be minor

								

								
🧪 Suggested Test
								
# Return value assertion
is( func(INPUT), EXPECTED, 'Verify correct return value' );

								
							
  733: }
  734: 
  735: # ─────────────────────────────────────────────────────────────────────────────
  736: # _emit_stack_trace()
  737: #
  738: # Purpose:      Write a coloured call-stack listing to STDERR so that the
  739: #               caller can locate which line of their code triggered a
  740: #               datecmp warning or failure.
  741: # Entry:        Called at any depth inside datecmp.
  742: # Exit:         Nothing returned (void).
  743: # Side Effects: Writes tab-indented, red-coloured lines to STDERR.
  744: # ─────────────────────────────────────────────────────────────────────────────
  745: sub _emit_stack_trace {
●746 → 747 → 750  746: 	my $i = 0;
  747: 	while(my @c = caller($i++)) {
  748: 		print STDERR "\t", colored($c[2] . ' of ' . $c[1], 'red'), "\n";
  749: 	}
  750: 	return;
  751: }
  752: 
  753: =head1 AUTHOR
  754: 
  755: Nigel Horne, C<< <njh at nigelhorne.com> >>
  756: 
  757: =head1 SEE ALSO
  758: 
  759: =over 4
  760: 
  761: =item * L<Test Dashboard|https://nigelhorne.github.io/Date-Cmp/coverage/>
  762: 
  763: =item * L<Sort::Key::DateTime>
  764: 
  765: =back
  766: 
  767: =head1 SUPPORT
  768: 
  769: This module is provided as-is without any warranty.
  770: 
  771: Please report bugs to C<bug-date-cmp at rt.cpan.org> or via
  772: L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Date-Cmp>.
  773: 
  774:     perldoc Date::Cmp
  775: 
  776: =head1 FORMAL SPECIFICATION
  777: 
  778: =head2 datecmp
  779: 
  780:     [DATESTR, DIAGMSG]
  781: 
  782:     DATE ::= exact⟨year: ℕ⟩
  783:            | approx⟨year: ℕ⟩
  784:            | before⟨year: ℕ⟩
  785:            | after⟨year: ℕ⟩
  786:            | range⟨from: ℕ; to: ℕ⟩
  787:            | invalid
  788: 
  789:     COMPARISON ::= lt | eq | gt | error
  790: 
  791:     DateCmp
  792:     left?, right?: DATESTR
  793:     diagnostic!: â„™ DIAGMSG
  794:     result!: COMPARISON
  795: 
  796:     ∀d: DATESTR @ validDate(d)
  797: 
  798:     ≙
  799:     ∃ l, r: DATE •
  800:         l = parse(left?) ∧ r = parse(right?) ∧
  801:         (
  802:           (l = invalid ∨ r = invalid ⇒ result! = error) ∧
  803:           (l = r ⇒ result! = eq) ∧
  804:           (compare(l, r, diagnostic!) = -1 ⇒ result! = lt) ∧
  805:           (compare(l, r, diagnostic!) = 0  ⇒ result! = eq) ∧
  806:           (compare(l, r, diagnostic!) = 1  ⇒ result! = gt)
  807:         )
  808: 
  809: =head1 LICENCE AND COPYRIGHT
  810: 
  811: Copyright 2025-2026 Nigel Horne.
  812: 
  813: Usage is subject to the GPL2 licence terms.
  814: If you use it,
  815: please let me know.
  816: 
  817: =cut
  818: 
  819: 1;