TER1 (Statement): 98.64%
TER2 (Branch): 94.44%
TER3 (LCSAJ): 100.0% (8/8)
Approximate LCSAJ segments: 91
● Covered — this LCSAJ path was executed during testing.
● Not covered — this LCSAJ path was never executed. These are the paths to focus on.
Multiple dots on a line indicate that multiple control-flow paths begin at that line. Hovering over any dot shows:
start → end → jump
Uncovered paths show [NOT COVERED] in the tooltip.
1: package DateTime::Format::Genealogy; 2: 3: # Author Nigel Horne: njh@nigelhorne.com 4: # Copyright (C) 2018-2026, Nigel Horne 5: 6: # Usage is subject to licence terms. 7: 8: use strict; 9: use warnings; 10: use autodie qw(:all); 11: use 5.010; 12: 13: # Sub::Private in 'enforce' mode makes calling private subs from outside the 14: # package a runtime error. HARNESS_ACTIVE (set by prove/make test) or 15: # $Sub::Private::BYPASS suppress enforcement so white-box tests can still 16: # reach private helpers directly. 17: BEGIN { $Sub::Private::config{mode} = 'enforce' } 18: use Sub::Private; 19: use Sub::Protected; 20: 21: # Explicit () -- we use Carp::carp / Carp::croak throughout; importing the 22: # short names into the namespace only to have namespace::clean remove them 23: # is unnecessary noise. 24: use Carp (); 25: use DateTime::Format::Natural; 26: use Genealogy::Gedcom::Date 2.01; 27: use Object::Configure 0.19; 28: use Params::Get 0.13; 29: use Params::Validate::Strict qw(validate_strict); 30: use Readonly; 31: use Readonly::Values::Months 0.02 qw(@short_month_names); 32: use Scalar::Util (); 33: 34: # namespace::clean placed last so the import list above is self-documenting: 35: # every 'use' that precedes it has its imported symbols removed from the 36: # public namespace at the end of compilation. 37: use namespace::clean; 38: 39: # --------------------------------------------------------------------------- 40: # Compile-time constants 41: # --------------------------------------------------------------------------- 42: 43: # Map non-standard (long, abbreviated, or French/German) month names to the 44: # 3-letter GEDCOM abbreviation. Not exported; callers must use parse_datetime. 45: Readonly my %MONTH_ALIAS => ( 46: 'January' => 'Jan', 47: 'February' => 'Feb', 48: 'March' => 'Mar', 49: 'April' => 'Apr', 50: 'June' => 'Jun', 51: 'July' => 'Jul', 52: 'August' => 'Aug', 53: 'September' => 'Sep', 54: 'October' => 'Oct', 55: 'November' => 'Nov', 56: 'December' => 'Dec', 57: # Common non-standard abbreviations for September 58: 'Sept' => 'Sep', 59: # French and German month variants found in real genealogical trees. 60: # 'Janv' = French abbreviation for janvier (January). 61: # 'Juli' = German July / occasional French variant. 62: # 'Mai' = French for May (3 letters, handled here to avoid a separate branch). 63: 'Janv' => 'Jan', 64: 'Juli' => 'Jul', 65: 'Mai' => 'May', 66: ); 67: 68: # Julian-to-Gregorian day offset tiers. Each pair is [boundary_year, offset]. 69: # The gap widened by 1 day at each century mark after 1582: 70: # 10 days: 5 Oct 1582 to 28 Feb 1700 71: # 11 days: 1 Mar 1700 to 28 Feb 1800 72: # 12 days: 1 Mar 1800 to 28 Feb 1900 73: # 13 days: 1 Mar 1900 onwards (catch-all, coded as literal 13 in the helper) 74: Readonly my @JULIAN_OFFSET_TIERS => ([1700, 10], [1800, 11], [1900, 12]); 75: 76: # Maximum unique date strings cached per object before the cache is discarded. 77: # Prevents adversarial callers from exhausting process memory by feeding an 78: # unbounded stream of unique-but-invalid strings to parse_datetime. 79: Readonly my $MAX_CACHE_SIZE => 10_000; 80: 81: # Legitimate recursion depth for parse_datetime is exactly 1: a range ("bet X 82: # and Y") calls itself once for each half. Anything deeper means either a 83: # mutant or a malformed string that tricks the range regex into re-matching its 84: # own output. The limit is generous so valid edge cases never trip it. 85: Readonly my $MAX_PARSE_DEPTH => 10; 86: our $_parse_depth = 0; 87: 88: # Accepted parameter schema for parse_datetime, used by Params::Validate::Strict 89: # to reject unknown keys (typos, stale callers) at runtime. 90: Readonly my %PARSE_DATETIME_SCHEMA => ( 91: date => { type => 'scalar', optional => 1 }, 92: quiet => { type => 'scalar', optional => 1 }, 93: strict => { type => 'scalar', optional => 1 }, 94: ); 95: 96: =head1 NAME 97: 98: DateTime::Format::Genealogy - Create a DateTime object from a genealogy date string 99: 100: =head1 VERSION 101: 102: Version 0.12 103: 104: =cut 105: 106: our $VERSION = '0.12'; 107: 108: =head1 SYNOPSIS 109: 110: C<DateTime::Format::Genealogy> is a Perl module designed to parse genealogy-style 111: date strings (primarily GEDCOM format) and convert them into L<DateTime> objects. 112: It wraps L<Genealogy::Gedcom::Date> and L<DateTime::Format::Natural>, adds GEDCOM 113: calendar-escape handling, and accepts common non-standard month names found in 114: exported genealogical trees. 115: 116: use DateTime::Format::Genealogy; 117: my $dtg = DateTime::Format::Genealogy->new(); 118: my $dt = $dtg->parse_datetime('25 Dec 2022'); 119: print $dt->dmy; # 25-12-2022 120: 121: =head1 SUBROUTINES/METHODS 122: 123: =head2 new 124: 125: Creates or clones a C<DateTime::Format::Genealogy> object. 126: 127: =head3 EXAMPLE 128: 129: # Bare construction 130: my $dtg = DateTime::Format::Genealogy->new(); 131: 132: # Construction with flags stored on the object 133: my $dtg_quiet = DateTime::Format::Genealogy->new(quiet => 1, strict => 1); 134: 135: # Clone with an override (inherits quiet => 1, overrides strict) 136: my $clone = $dtg_quiet->new(strict => 0); 137: 138: =head3 API SPECIFICATION 139: 140: # Input (hash or hashref, all keys optional): 141: { 142: quiet => $bool, # suppress carp in internal helpers 143: strict => $bool, # enforce 3-letter GEDCOM month abbreviations 144: # Any extra keys from Object::Configure are also accepted. 145: } 146: 147: # Output: blessed DateTime::Format::Genealogy object 148: 149: =head3 MESSAGES 150: 151: This method does not emit any diagnostics directly. 152: 153: =head3 PSEUDOCODE 154: 155: FUNCTION new(class, *args): 156: params = get_params(undef, args) 157: IF class is not defined: 158: class = __PACKAGE__ 159: ELSE IF class is already an object (blessed): 160: RETURN bless( merge(class.attrs, params), ref(class) ) 161: params = configure(class, params) # merge any config-file settings 162: RETURN bless(params, class) 163: END FUNCTION 164: 165: =cut 166: 167: sub new 168: { ●169 → 173 → 182 169: my $class = shift; 170: 171: my $params = Params::Get::get_params(undef, \@_); 172: 173: if(!defined($class)) {Mutants (Total: 1, Killed: 1, Survived: 0)
174: # Called as DateTime::Format::Genealogy::new() with no invocant; 175: # default to the package name so bless still works. 176: $class = __PACKAGE__; 177: } elsif(Scalar::Util::blessed($class)) { 178: # Invocant is an existing object: clone it and overlay any new params. 179: return bless { %{$class}, ($params ? %{$params} : ()) }, ref($class);
Mutants (Total: 2, Killed: 2, Survived: 0)
180: } 181: 182: $params = Object::Configure::configure($class, $params); 183: return bless $params, $class;
Mutants (Total: 2, Killed: 2, Survived: 0)
184: } 185: 186: =head2 parse_datetime 187: 188: Parses a genealogy-style date string and returns a L<DateTime> object. 189: 190: Recognises GEDCOM calendar escapes (C<@#DJULIAN@>, C<@#DHEBREW@>, 191: C<@#DFRENCH R@>) and converts them via the appropriate calendar module when 192: available. 193: 194: Can be called as a class method, an object method, or a bare function. 195: 196: Returns: 197: 198: =over 4 199: 200: =item * 201: 202: A single L<DateTime> object for exact, parseable dates. 203: 204: =item * 205: 206: A two-element list of L<DateTime> objects in I<list> context when the date 207: string is a range (C<bet X and Y> / C<from X to Y>). 208: 209: =item * 210: 211: C<undef> (scalar) or the empty list (list context) when the date cannot be 212: parsed, is a year-only string, is prefixed with an approximation keyword 213: (C<bef>, C<aft>, C<abt>), or represents a date before AD 100. 214: 215: =back 216: 217: Mandatory argument: 218: 219: =over 4 220: 221: =item * C<date> 222: 223: The date string to parse. 224: 225: =back 226: 227: Optional arguments (may be set at construction time and/or overridden 228: per-call; per-call values take precedence): 229: 230: =over 4 231: 232: =item * C<quiet> 233: 234: Suppress L<Carp> warnings on unparseable or approximate dates. 235: 236: =item * C<strict> 237: 238: Enforce the GEDCOM standard: only 3-letter month abbreviations (C<Jan>, 239: C<Feb>, ...) are accepted. Long English names and French/German variants 240: are rejected. 241: 242: =back 243: 244: =head3 EXAMPLE 245: 246: my $dtg = DateTime::Format::Genealogy->new(); 247: 248: # Simple exact date 249: my $dt = $dtg->parse_datetime('25 Dec 2022'); 250: print $dt->dmy; # 25-12-2022 251: 252: # Date range (list context) 253: my ($start, $end) = $dtg->parse_datetime('bet 1 Sep 1939 and 2 Sep 1945'); 254: 255: # GEDCOM calendar escape 256: my $julian = $dtg->parse_datetime('@#DJULIAN@ 15 Mar 1620'); 257: 258: # Class-method form (no constructor required) 259: my $dt2 = DateTime::Format::Genealogy->parse_datetime('1 Jan 2000'); 260: 261: # Long month name (non-strict only) 262: my $dt3 = $dtg->parse_datetime('12 June 2020'); 263: 264: # French month variant (non-strict only) 265: my $dt4 = $dtg->parse_datetime('21 Mai 1681'); 266: 267: =head3 API SPECIFICATION 268: 269: # Input (hash or hashref): 270: { 271: date => $string, # required (non-ref, non-empty) 272: quiet => $bool, # optional; falls back to $self->{'quiet'} 273: strict => $bool, # optional; falls back to $self->{'strict'} 274: } 275: 276: # Return values: 277: # DateTime exact parseable date 278: # (DateTime, DateTime) date range (list context only) 279: # undef / () unparseable, approximate, or year-only 280: 281: =head3 MESSAGES 282: 283: =over 4 284: 285: =item C<< Usage: DateTime::Format::Genealogy::parse_datetime(date => $date) >> 286: 287: Thrown (croak) when no arguments are supplied or when the C<date> value is 288: undef or a reference. 289: 290: =item C<< Invalid parse_datetime parameters: ... >> 291: 292: Thrown (croak) when an unknown parameter key is passed (e.g. a typo). 293: 294: =item C<< $date is invalid, need an exact date to create a DateTime >> 295: 296: Warned (carp) when the date begins with an approximation prefix (C<bef>, 297: C<aft>, C<abt>). Silenced by C<quiet>. 298: 299: =item C<< $date is invalid, there are only 30 days in November >> 300: 301: Warned (carp) for the impossible date C<31 Nov>. Always emitted; not 302: silenced by C<quiet>. 303: 304: =item C<< Changing date '$original' to '$new' >> 305: 306: Warned (carp) when a date is automatically rewritten (ISO dash format or 307: dash-separated range). Silenced by C<quiet>. 308: 309: =item C<< Unparseable date $date - often because the month name isn't 3 letters >> 310: 311: Warned (carp) in strict mode for non-3-letter months, or in non-strict mode 312: for unrecognised long month names. Silenced by C<quiet>. 313: 314: =item C<< $dfn_error_string >> 315: 316: Warned (carp) when L<DateTime::Format::Natural> rejects the date string. 317: Silenced by C<quiet>. 318: 319: =item C<< Hebrew calendar conversion failed: ... >> 320: 321: Warned (carp) when L<DateTime::Calendar::Hebrew> is unavailable or throws. 322: Silenced by C<quiet>. 323: 324: =item C<< French Republican calendar conversion failed: ... >> 325: 326: Warned (carp) when L<DateTime::Calendar::FrenchRevolutionary> is unavailable 327: or throws. Silenced by C<quiet>. 328: 329: =item C<< Calendar type $type not supported >> 330: 331: Warned (carp) for GEDCOM calendar escapes other than GREGORIAN, JULIAN, 332: HEBREW, and FRENCH R. Silenced by C<quiet>. 333: 334: =back 335: 336: =head3 PSEUDOCODE 337: 338: FUNCTION parse_datetime(self, *args): 339: -- Dispatch class/function/hash-invocant calls to an object instance 340: IF self is not a reference: 341: RETURN new()->parse_datetime(args or self) 342: IF ref(self) == 'HASH': 343: RETURN new()->parse_datetime(self) 344: 345: ABORT unless args non-empty 346: params = get_params('date', args) 347: ABORT on unknown keys (validate_strict) 348: 349: date = params.date 350: quiet = params.quiet // self.quiet 351: strict = params.strict // self.strict 352: 353: ABORT unless date is defined, non-empty, and not a reference 354: 355: -- Strip GEDCOM calendar escape if present 356: IF date =~ s/^@#D([A-Z ]+?)@\s*//: calendar_type = 'D' + uc(match) 357: 358: -- Reject approximate/relative dates 359: IF date =~ /^(bef|aft|abt)\s/i: CARP and RETURN undef 360: 361: -- Reject calendar impossibilities 362: IF date =~ /^31\s+Nov/: CARP and RETURN undef 363: 364: -- Rewrite dash-separated ranges and ISO dates 365: IF date =~ /X - Y/: 366: IF date =~ /YYYY-MM-DD/: REFORMAT to "DD Mon YYYY" (carp) 367: ELSE: REFORMAT to "bet X and Y" (carp) 368: 369: -- Dispatch ranges to recursive calls 370: IF date =~ /^bet X and Y/i: 371: RETURN (parse_datetime(X), parse_datetime(Y)) IF wantarray 372: RETURN undef 373: 374: IF !strict AND date =~ /^from X to Y/i: 375: RETURN (parse_datetime(X), parse_datetime(Y)) IF wantarray 376: RETURN undef 377: 378: -- Normalise non-standard month names (non-strict mode only) 379: IF !strict: 380: IF date =~ DD + Aout + YYYY (French non-ASCII August): 381: REWRITE month to 'Aug' 382: ELSE IF date =~ /DD LONG_OR_VARIANT YYYY/: 383: lookup = MONTH_ALIAS{ucfirst(lc(month))} 384: IF lookup: REWRITE month to lookup 385: ELSE IF month is more than 3 letters: CARP and RETURN undef 386: -- 3-letter unknown months fall through unchanged to the parser 387: 388: -- Parse with Genealogy::Gedcom::Date (cached) then DateTime::Format::Natural 389: IF date starts with digit: 390: d = _date_parser_cached(date) 391: IF d defined: 392: RETURN undef if date ends with year-only (< AD100 guard) 393: rc = DateTime::Format::Natural->parse_datetime(d.canonical) 394: IF calendar_type != DGREGORIAN: 395: rc = _convert_calendar(rc, calendar_type, quiet) 396: RETURN rc 397: 398: -- Fallback: try DateTime::Format::Natural directly on the raw string 399: IF date not ~= /^(Abt|ca?)/i AND date =~ /^[\w\s,]+$/: 400: rc = DateTime::Format::Natural->parse_datetime(date) 401: IF rc AND success: RETURN rc 402: ELSE: CARP error 403: 404: RETURN undef 405: END FUNCTION 406: 407: =cut 408: 409: sub parse_datetime 410: { 411: # Guard against unbounded recursion at every entry point, including the 412: # class-method normalisation branches below. 'local' restores the counter 413: # automatically on any return path. Legitimate use bottoms out at depth 1 414: # (range-split recursive call); anything deeper is a mutant or a bug. ●415 → 421 → 431 415: local $_parse_depth = $_parse_depth + 1; 416: return if $_parse_depth > $MAX_PARSE_DEPTH;
Mutants (Total: 3, Killed: 3, Survived: 0)
417: 418: my $self = shift; 419: 420: # Normalise class-method and bare-function call styles into an object call. 421: if(!ref($self)) {
Mutants (Total: 1, Killed: 1, Survived: 0)
422: if(@_) {
Mutants (Total: 1, Killed: 1, Survived: 0)
423: return(__PACKAGE__->new()->parse_datetime(@_)); 424: } 425: return(__PACKAGE__->new()->parse_datetime($self)); 426: } elsif(ref($self) eq 'HASH') { 427: return(__PACKAGE__->new()->parse_datetime($self)); 428: } 429: 430: # Guard before Params::Get so *our* croak message is what Test::Carp sees. ●431 → 446 → 604 431: Carp::croak('Usage: ', __PACKAGE__, '::parse_datetime(date => $date)') unless @_; 432: 433: my $params = Params::Get::get_params('date', @_); 434: 435: # Catch unknown parameter keys early so callers get a clear error rather 436: # than silent misbehaviour from a typo like 'quet' instead of 'quiet'. 437: # validate_strict uses a compile-time-imported croak, so we wrap in eval 438: # and re-throw via Carp::croak (which IS interceptable by Test::Carp). 439: # Capture $@ into a lexical immediately: a DESTROY method firing between 440: # the eval and the check would otherwise silently clear the global $@. 441: my $validate_err; 442: eval { validate_strict(schema => \%PARSE_DATETIME_SCHEMA, input => $params); 1 } 443: or $validate_err = $@; 444: Carp::croak("Invalid parse_datetime parameters: $validate_err") if $validate_err; 445: 446: if((!ref($params->{'date'})) && (my $date = $params->{'date'})) {
Mutants (Total: 1, Killed: 1, Survived: 0)
447: # Per-call flags shadow object-level defaults, enabling per-call overrides 448: # without losing the convenience of constructor-level configuration. 449: my $quiet = $params->{'quiet'} // $self->{'quiet'}; 450: my $strict = $params->{'strict'} // $self->{'strict'}; 451: 452: # Detect and strip any GEDCOM calendar escape at the front of the string. 453: # Pattern: @#D<NAME>@ where NAME is uppercase letters/spaces (lazy match 454: # so it stops at the first closing '@' rather than a later one). 455: my $calendar_type = 'DGREGORIAN'; 456: if($date =~ s/^@#D([A-Z ]+?)@\s*//) {
Mutants (Total: 1, Killed: 1, Survived: 0)
457: $calendar_type = 'D' . uc($1); 458: } 459: 460: # Approximate-date prefixes (bef/aft/abt) signal "no exact date known", 461: # so a DateTime object would be misleading. 462: if($date =~ /^(?:bef|aft|abt)\s/i) {
Mutants (Total: 1, Killed: 1, Survived: 0)
463: Carp::carp(_safe_str($date) . ' is invalid, need an exact date to create a DateTime') 464: unless($quiet); 465: return; 466: } 467: 468: # 31 November does not exist; catch it before any parser attempt. 469: if($date =~ /^31\s+Nov/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
470: Carp::carp(_safe_str($date) . ' is invalid, there are only 30 days in November'); 471: return; 472: } 473: 474: # Rewrite dash-separated constructs. 475: # ISO "YYYY-MM-DD" is checked first -- the pattern is fully anchored with 476: # fixed-width fields so there is zero backtracking. 477: # A spaced range "X - Y" (spaces required on both sides of the hyphen) 478: # is converted to "bet X and Y". The \s+ discriminator ensures that a 479: # bare ISO date (no spaces around the hyphen) never matches this branch, 480: # eliminating the need for a combined pre-filter. 481: if($date =~ /^(\d{4})-(\d{2})-(\d{2})$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
482: my ($y, $m, $d) = ($1, $2, $3); 483: my $month_idx = $m - 1; 484: # @short_month_names is a 12-element array (indices 0-11). 485: # Month 00 would yield index -1 (wrapping silently to Dec in Perl). 486: # Month 13-99 yields undef and a runtime warning. Reject both. 487: if($month_idx < 0 || $month_idx > 11) {
Mutants (Total: 7, Killed: 7, Survived: 0)
488: Carp::carp("Invalid month '$m' in date '$date'") unless $quiet; 489: return; 490: } 491: my $month = ucfirst($short_month_names[$month_idx]); 492: my $rewritten = "$d $month $y"; 493: Carp::carp("Changing date '" . _safe_str($date) . "' to '$rewritten'") unless($quiet); 494: $date = $rewritten; 495: } elsif($date =~ /^(.+\d)\s+-\s+(.+\d)$/) { 496: my ($lhs, $rhs) = ($1, $2); 497: Carp::carp("Changing date '" . _safe_str($date) . "' to 'bet $lhs and $rhs'") unless($quiet); 498: $date = "bet $lhs and $rhs"; 499: } 500: 501: # Date ranges return two DateTimes in list context; undef in scalar. 502: # Lazy .+? on the first group ensures we split at the FIRST "and"/"to" 503: # keyword, not the last, which matters when a sub-date contains the word. 504: if($date =~ /^bet (.+?) and (.+)/i) {
Mutants (Total: 1, Killed: 1, Survived: 0)
505: if(wantarray) {
Mutants (Total: 1, Killed: 1, Survived: 0)
506: return $self->parse_datetime($1), $self->parse_datetime($2);
Mutants (Total: 2, Killed: 2, Survived: 0)
507: } 508: return; 509: } 510: 511: if((!$strict) && ($date =~ /^from (.+?) to (.+)/i)) {
Mutants (Total: 1, Killed: 1, Survived: 0)
512: if(wantarray) {
Mutants (Total: 1, Killed: 1, Survived: 0)
513: return $self->parse_datetime($1), $self->parse_datetime($2);
Mutants (Total: 2, Killed: 2, Survived: 0)
514: } 515: return; 516: } 517: 518: if($date !~ /^\d{3,4}$/) {
Mutants (Total: 1, Killed: 1, Survived: 0)
519: # Strict mode: only 3-letter GEDCOM abbreviations are valid. 520: if($strict) {
Mutants (Total: 1, Killed: 1, Survived: 0)
521: if($date !~ /^\d{1,2}\s+[A-Z]{3}\s+\d{3,4}$/i) {
Mutants (Total: 1, Killed: 1, Survived: 0)
522: Carp::carp('Unparseable date ' . _safe_str($date) . " - often because the month name isn't 3 letters") unless($quiet); 523: return; 524: } 525: } else { 526: # Aout with circumflex-u (Ao\x{FB}t) must be matched explicitly 527: # because the standard \w character class is ASCII-only and will 528: # not match the non-ASCII 'u with circumflex'. 529: if($date =~ /^(\d{1,2})\s+Ao\x{FB}t\s+(\d{3,4})$/i) {
Mutants (Total: 1, Killed: 1, Survived: 0)
530: $date = "$1 Aug $2"; 531: } elsif($date =~ /^(\d{1,2})\s+([A-Z]{3,}+)\.?\s+(\d{3,4})$/i) { 532: # Look up the month in the alias table. 533: # Unknown 3-letter tokens are passed through unchanged so that 534: # standard GEDCOM abbreviations (Sep, Dec, ...) that did not 535: # trigger the earlier cache path still reach the parser. 536: if(my $abbrev = $MONTH_ALIAS{ucfirst(lc($2))}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
537: $date = "$1 $abbrev $3"; 538: } elsif(length($2) > 3) {
Mutants (Total: 3, Killed: 3, Survived: 0)
539: # Longer-than-3-letter names not in the alias table are 540: # truly unrecognised; there is nothing useful we can do. 541: Carp::carp('Unparseable date ' . _safe_str($date) . " - often because the month name isn't 3 letters") unless($quiet); 542: return; 543: } 544: } elsif($date =~ /^(\d{1,2})\-([A-Z]{3})\-(\d{3,4})$/i) { 545: # Accept the 29-Aug-1938 dash-separated single-date format. 546: $date = "$1 $2 $3"; 547: } 548: } 549: 550: # Lazily initialise DateTime::Format::Natural on first use. 551: my $dfn = $self->{'dfn'} //= DateTime::Format::Natural->new(); 552: 553: if(($date =~ /^\d/) && (my $d = $self->_date_parser_cached($date))) {
Mutants (Total: 1, Killed: 1, Survived: 0)
554: # DateTime::Format::Natural cannot handle dates before AD 100; 555: # a date ending in a 1-or-2-digit year is that old. 556: return if($date =~ /\s\d{1,2}$/); 557: 558: # Guard against a malformed GGD result with an undef canonical 559: # field; passing undef to DFN causes a Params::Validate croak. 560: return unless defined $d->{'canonical'}; 561: 562: my $rc = $dfn->parse_datetime($d->{'canonical'}); 563: 564: # DFN silently returns today's date when it cannot parse the 565: # canonical string (e.g. 3-digit years 100-999, very large 566: # years). We must check success() here just as we do in the 567: # DFN fallback path below, otherwise the caller receives a 568: # completely wrong DateTime. 569: unless($dfn->success) {
Mutants (Total: 1, Killed: 1, Survived: 0)
570: Carp::carp($dfn->error) unless $quiet; 571: return; 572: } 573: 574: if($rc && $calendar_type ne 'DGREGORIAN') {
Mutants (Total: 1, Killed: 1, Survived: 0)
575: return _convert_calendar($rc, $calendar_type, $quiet);
Mutants (Total: 2, Killed: 2, Survived: 0)
576: } 577: 578: return $rc;
Mutants (Total: 2, Killed: 2, Survived: 0)
579: } 580: 581: # Last resort: try DateTime::Format::Natural on the raw string. 582: # Approximate-prefix forms are excluded here because they already 583: # returned undef above; the pattern here guards against 'Abt'/'ca' 584: # leaking through when quiet is enabled (e.g. "Abt1Jan2000" has no 585: # space so it was not caught by the /^abt\s/i check above). 586: if(($date !~ /^(?:Abt|ca?)/i) && ($date =~ /^[\w\s,]+$/)) {
Mutants (Total: 1, Killed: 1, Survived: 0)
587: if(my $rc = $dfn->parse_datetime($date)) {
Mutants (Total: 1, Killed: 1, Survived: 0)
588: if($dfn->success()) {
Mutants (Total: 1, Killed: 1, Survived: 0)
589: return $rc;
Mutants (Total: 2, Killed: 2, Survived: 0)
590: } 591: Carp::carp($dfn->error()) unless($quiet); 592: } 593: # NOTE: DateTime::Format::Natural->parse_datetime always returns 594: # a DateTime object (today's date on failure), never undef. The 595: # else branch that would carp "Can't parse date" is therefore 596: # dead code and has been removed. If a future DFN version can 597: # return undef, this else must be reinstated: 598: # else { Carp::carp("Can't parse date '$date'") unless $quiet } 599: } 600: } 601: return; 602: } 603: 604: Carp::croak('Usage: ', __PACKAGE__, '::parse_datetime(date => $date)'); 605: } 606: 607: # --------------------------------------------------------------------------- 608: # _date_parser_cached 609: # 610: # Purpose: Wrap Genealogy::Gedcom::Date->parse() with a per-object 611: # memoisation layer to avoid re-parsing identical strings. 612: # Entry: $self - blessed object (must carry ->{'date_parser'} slot) 613: # $date - non-empty, non-undef date string (positional) 614: # Exit: Hashref on success ({canonical, day, month, year, ...}), 615: # undef on parse failure or error. 616: # Side Effects: Populates $self->{'all_dates'}{$date} on BOTH success and 617: # failure. Failure is stored as undef so repeated lookups of 618: # the same invalid string are O(1) and carp fires only once. 619: # Carps on parser error unless $self->{'quiet'} is set. 620: # --------------------------------------------------------------------------- 621: 622: sub _date_parser_cached :Protected 623: { 624: # Accept the date as a plain positional arg -- this is a hot-path internal 625: # method called only from parse_datetime. Routing through Params::Get adds 626: # measurable dispatch overhead for no external-API benefit. ●627 → 634 → 640 627: my ($self, $date) = @_; 628: 629: Carp::croak('Usage: _date_parser_cached($date)') unless defined $date; 630: 631: # Evict the whole cache when it reaches the size limit. A full clear is 632: # used instead of LRU because genealogy datasets have bounded unique-date 633: # counts in normal use; LRU overhead is not justified. 634: if(defined($self->{'all_dates'}) && scalar(keys %{$self->{'all_dates'}}) >= $MAX_CACHE_SIZE) {
635: $self->{'all_dates'} = {}; 636: } 637: 638: # Short-circuit on any prior result (success OR cached failure). 639: # 'exists' correctly handles undef values stored for invalid dates. ●640 → 649 → 656 640: return $self->{'all_dates'}{$date} if exists $self->{'all_dates'}{$date};Mutants (Total: 4, Killed: 1, Survived: 3)
- NUM_BOUNDARY_634_75_>: 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_634_75_<: 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_634_75_<=: 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' );Mutants (Total: 2, Killed: 2, Survived: 0)
641: 642: my $date_parser = $self->{'date_parser'} //= Genealogy::Gedcom::Date->new(); 643: 644: my $parsed_date; 645: eval { 646: $parsed_date = $date_parser->parse(date => $date); 647: }; 648: 649: if(my $error = $date_parser->error()) {
Mutants (Total: 1, Killed: 1, Survived: 0)
650: Carp::carp(_safe_str($date) . ": '$error'") unless $self->{'quiet'}; 651: # Cache the failure so subsequent calls for the same string skip GGD 652: # entirely and do not carp again. 653: return ($self->{'all_dates'}{$date} = undef); 654: } 655: ●656 → 656 → 661 656: if((ref($parsed_date) eq 'ARRAY') && @{$parsed_date}) {
Mutants (Total: 1, Killed: 1, Survived: 0)
657: return $self->{'all_dates'}{$date} = $parsed_date->[0];
Mutants (Total: 2, Killed: 2, Survived: 0)
658: } 659: 660: # Empty or unexpected result -- also cache to prevent repeated GGD calls. 661: return ($self->{'all_dates'}{$date} = undef); 662: } 663: 664: # --------------------------------------------------------------------------- 665: # _convert_calendar 666: # 667: # Purpose: Convert a Gregorian DateTime produced by 668: # Genealogy::Gedcom::Date/DateTime::Format::Natural to the 669: # calendar indicated by the GEDCOM escape that preceded the date. 670: # Entry: $dt - DateTime object in Gregorian coordinates 671: # $calendar_type - normalised escape string (e.g. 'DJULIAN') 672: # $quiet - truthy to suppress carp on failure 673: # Exit: Converted DateTime, or the original $dt for unknown types. 674: # Side Effects: May carp on conversion failure (unless $quiet). 675: # --------------------------------------------------------------------------- 676: 677: sub _convert_calendar :Private 678: { ●679 → 681 → 730 679: my ($dt, $calendar_type, $quiet) = @_; 680: 681: if($calendar_type eq 'DJULIAN') {
Mutants (Total: 1, Killed: 1, Survived: 0)
682: # Add the historical Julian-to-Gregorian day offset. 683: my $offset_days = _julian_to_gregorian_offset($dt->year); 684: return $dt->clone->add(days => $offset_days);
Mutants (Total: 2, Killed: 2, Survived: 0)
685: } elsif($calendar_type eq 'DHEBREW') { 686: # "return" inside eval{} exits the eval block, NOT the enclosing sub, 687: # so we capture the result in $result and return it afterwards. 688: # $@ is captured into a lexical immediately after the eval to prevent 689: # a DESTROY method from clearing the global before we can read it. 690: my $result; 691: my $convert_err; 692: eval { 693: require DateTime::Calendar::Hebrew; 694: my $h = DateTime::Calendar::Hebrew->new( 695: year => $dt->year, 696: month => $dt->month, 697: day => $dt->day 698: ); 699: $result = DateTime->from_object(object => $h); 700: 1; 701: } or $convert_err = $@; 702: Carp::carp("Hebrew calendar conversion failed: $convert_err") 703: if $convert_err && !$quiet; 704: # Return the converted DateTime on success, undef on failure. 705: # The POD (LIMITATIONS) documents that undef is returned when the 706: # optional module is unavailable rather than passing back the 707: # unconverted Gregorian DateTime. 708: return $result;
Mutants (Total: 2, Killed: 2, Survived: 0)
709: } elsif($calendar_type eq 'DFRENCH R') { 710: my $result; 711: my $convert_err; 712: eval { 713: require DateTime::Calendar::FrenchRevolutionary; 714: my $f = DateTime::Calendar::FrenchRevolutionary->new( 715: year => $dt->year, 716: month => $dt->month, 717: day => $dt->day 718: ); 719: $result = DateTime->from_object(object => $f); 720: 1; 721: } or $convert_err = $@; 722: Carp::carp("French Republican calendar conversion failed: $convert_err") 723: if $convert_err && !$quiet; 724: return $result;
Mutants (Total: 2, Killed: 2, Survived: 0)
725: } else { 726: # DROMAN and any other future escape types are not yet supported. 727: Carp::carp("Calendar type $calendar_type not supported") unless $quiet; 728: } 729: 730: return $dt;
Mutants (Total: 2, Killed: 2, Survived: 0)
731: } 732: 733: # --------------------------------------------------------------------------- 734: # _safe_str 735: # 736: # Purpose: Sanitise a user-supplied string for inclusion in diagnostic 737: # messages (Carp::carp/croak). Removes ASCII control characters 738: # that could be used for log injection (fake log lines, ANSI 739: # escape sequences) and truncates to a safe display length. 740: # Entry: $s - string to sanitise (may be undef) 741: # $max - optional maximum length (default 120) 742: # Exit: Sanitised, length-bounded string safe for embedding in messages. 743: # --------------------------------------------------------------------------- 744: 745: sub _safe_str :Private 746: { 747: my ($s, $max) = @_; 748: return '(undef)' unless defined $s;
749: $max //= 120; 750: # Replace every ASCII control character (0x00-0x1F, 0x7F) with '?'. 751: # This neutralises CR/LF log injection and ANSI escape sequences. 752: (my $clean = $s) =~ s/[[:cntrl:]]/?/g; 753: return length($clean) <= $max ? $clean : substr($clean, 0, $max - 3) . '...';Mutants (Total: 2, Killed: 0, Survived: 2)
- BOOL_NEGATE_748_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_748_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' );754: } 755: 756: # --------------------------------------------------------------------------- 757: # _julian_to_gregorian_offset 758: # 759: # Purpose: Return the number of days to add to a Julian date to obtain 760: # the Gregorian equivalent, based on the year. 761: # Entry: $year - integer calendar year 762: # Exit: Integer day offset (10, 11, 12, or 13) 763: # --------------------------------------------------------------------------- 764: 765: sub _julian_to_gregorian_offset :Private 766: { ●767 → 772 → 775 767: my $year = $_[0]; 768: 769: # Iterate once with early exit; avoids the temporary list that grep would 770: # build before we discard all but the first match. 771: # @JULIAN_OFFSET_TIERS is ordered ascending, so the first hit is correct. 772: for my $tier (@JULIAN_OFFSET_TIERS) { 773: return $tier->[1] if $year < $tier->[0];Mutants (Total: 5, Killed: 2, Survived: 3)
- NUM_BOUNDARY_753_24_<: 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_753_24_>: 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_753_24_>=: 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' );Mutants (Total: 5, Killed: 5, Survived: 0)
774: } 775: return 13; # catch-all: 1 Mar 1900 onwards
Mutants (Total: 2, Killed: 2, Survived: 0)
776: } 777: 778: =head1 LIMITATIONS 779: 780: =over 4 781: 782: =item * 783: 784: Dates before AD 100 are rejected because L<DateTime::Format::Natural> cannot 785: parse them reliably (it returns today's date instead of an error). 786: 787: =item * 788: 789: The C<Aout> (French August with circumflex-u) entry in the month-alias table 790: uses a non-ASCII Unicode escape (C<\x{FB}>). The module file must be read as 791: UTF-8; this is satisfied by the standard C<perl -Ilib> invocation but may 792: require C<use utf8> or C<open ':encoding(UTF-8)'> in unusual environments. 793: 794: =item * 795: 796: Hebrew and French Republican calendar conversions require 797: L<DateTime::Calendar::Hebrew> and L<DateTime::Calendar::FrenchRevolutionary> 798: respectively. These are optional and not listed as hard dependencies. When 799: absent, the GEDCOM escape is silently discarded and undef is returned unless 800: the C<quiet> flag is off, in which case a carp is emitted. 801: 802: =item * 803: 804: L<Genealogy::Gedcom::Date> cannot parse native Hebrew or French Revolutionary 805: month names (e.g. C<Tishri>, C<Vendemiaire>). Only dates written in 806: Gregorian form with the C<@#DHEBREW@> escape are converted. 807: 808: =item * 809: 810: The C<quiet> and C<strict> flags may be set at construction time 811: (C<< ->new(quiet => 1) >>) and will be respected by all subsequent calls to 812: C<parse_datetime> unless overridden on a per-call basis. The per-call value 813: always takes precedence. 814: 815: =back 816: 817: =head1 AUTHOR 818: 819: Nigel Horne, C<< <njh at nigelhorne.com> >> 820: 821: =head1 BUGS 822: 823: Please report any bugs or feature requests to the author. 824: This module is provided as-is without any warranty. 825: 826: =head1 SEE ALSO 827: 828: =over 4 829: 830: =item * L<Genealogy::Gedcom::Date> 831: 832: =item * L<DateTime> 833: 834: =item * L<DateTime::Format::Natural> 835: 836: =item * L<Configure an Object at Runtime|Object::Configure> 837: 838: =item * L<Test Dashboard|https://nigelhorne.github.io/DateTime-Format-Genealogy/coverage/> 839: 840: =back 841: 842: =head1 SUPPORT 843: 844: You can find documentation for this module with the perldoc command. 845: 846: perldoc DateTime::Format::Genealogy 847: 848: =over 4 849: 850: =item * RT: CPAN's request tracker 851: 852: L<http://rt.cpan.org/NoAuth/Bugs.html?Dist=DateTime-Format-Genealogy> 853: 854: =item * GitHub Issues 855: 856: L<https://github.com/nigelhorne/DateTime-Format-Genealogy/issues> 857: 858: =back 859: 860: =head1 FORMAL SPECIFICATION 861: 862: =head2 new 863: 864: State S ::= [ attrs : Name -> Value ] 865: 866: new(class, params) = bless(params U configure(class)) when !blessed(class) 867: new(obj, params) = bless(obj.attrs (+) params) when blessed(obj) 868: 869: where (+) denotes right-biased union (params values take precedence). 870: 871: =head2 parse_datetime 872: 873: Let D be the set of genealogical date strings and DT the co-domain of 874: L<DateTime> objects. 875: 876: parse_datetime : D -> DT | bot | (DT x DT) 877: 878: YearOnly ::= { s in D | s ~ /^\d{3,4}$/ } 879: Approx ::= { s in D | s ~ /^(bef|aft|abt)\s/i } 880: Ranges ::= { s in D | s ~ /^bet\s.+\sand\s.+/i 881: | s ~ /^from\s.+\sto\s.+/i } 882: 883: Pre: date != bot 884: 885: Post: 886: date in YearOnly => result = bot 887: date in Approx => result = bot (carp unless quiet) 888: date in Ranges /\ wantarray => result in DT x DT 889: date in Ranges /\ !wantarray => result = bot 890: date in Parseable \ 891: (YearOnly u Approx u Ranges) => result in DT 892: date not in Parseable => result = bot (carp unless quiet) 893: 894: =head1 LICENSE AND COPYRIGHT 895: 896: Copyright 2018-2026 Nigel Horne. 897: 898: Usage is subject to the GPL2 licence terms. 899: If you use it, 900: please let me know. 901: 902: =cut 903: 904: 1;