view release on metacpan or  search on metacpan

t/edge_cases.t  view on Meta::CPAN

	my $long_result;
	lives_ok(
		sub { $long_result = $obj->parse_datetime("\@#D${long_type}\@ 25 Dec 2022") },
		'Extremely long calendar type does not crash',
	);
	diag("Long calendar type result: " . (defined $long_result ? $long_result->dmy : 'undef'))
		if $ENV{TEST_VERBOSE};
};

subtest 'parse_datetime - lowercase GEDCOM escape is not recognised' => sub {
	# The regex @#D([A-Z ]+?)@ requires uppercase letters; lowercase should
	# not be treated as a calendar escape and falls through to normal parsing.
	my $obj = $PKG->new(quiet => 1);

	my $result = $obj->parse_datetime('@#djulian@ 25 Dec 2022');
	ok(!defined $result,
		'Lowercase GEDCOM escape not recognised: date cannot be parsed normally');
};

subtest 'parse_datetime - GEDCOM Julian offset for each century tier' => sub {
	# Verify all four offset tiers (<1700=>10, <1800=>11, <1900=>12, >=1900=>13)
	# are applied correctly end-to-end.
	my $obj = $PKG->new();

	Readonly my @TIER_CASES => (
		# [ julian_date,      expected_day, expected_offset ]
		['@#DJULIAN@ 1 Mar 1620',  11, 10],
		['@#DJULIAN@ 1 Mar 1750',  12, 11],
		['@#DJULIAN@ 1 Mar 1850',  13, 12],
		['@#DJULIAN@ 1 Mar 1920',  14, 13],
	);

	for my $case (@TIER_CASES) {
		my ($input, $expected_day, $offset) = @{$case};
		my $dt = $obj->parse_datetime($input);
		isa_ok($dt, 'DateTime', "$input parses to DateTime");
		is($dt->day, $expected_day, "$input: day advanced by $offset") if defined $dt;
	}
};

# ===========================================================================
# SECTION 7: Date range edge cases and list/scalar context abuse
# ===========================================================================

subtest 'parse_datetime - range in scalar context always returns undef' => sub {
	my $obj = $PKG->new();

	# These must NOT return a DateTime or throw; scalar context must give undef.
	Readonly my @RANGE_STRINGS => (
		'bet 1 Jan 2000 and 31 Dec 2000',
		'from 1 Jan 2000 to 31 Dec 2000',
		'1 Jan 2000 - 31 Dec 2000',
	);

	for my $range (@RANGE_STRINGS) {
		my $scalar = $obj->parse_datetime($range);
		ok(!defined $scalar, "'$range' in scalar context returns undef");
	}
};

subtest 'parse_datetime - range with invalid first endpoint' => sub {
	# When one endpoint of a bet...and... range is itself invalid (31 Nov),
	# the recursive parse_datetime call returns the empty list.  In list
	# context that causes the outer return to have fewer than 2 elements.
	# This is a known limitation: callers must check scalar(@result) == 2.
	my $obj = $PKG->new(quiet => 1);

	my @range;
	lives_ok(
		sub { @range = $obj->parse_datetime('bet 31 Nov 2000 and 31 Dec 2000') },
		'bet range with invalid first endpoint does not crash',
	);
	# Verify the caller gets back something that is at least not a full 2-DT list.
	ok(scalar(@range) != 2 || !defined $range[0],
		'invalid first endpoint: result is not a clean 2-element range');

	diag("Range with bad first endpoint: " . scalar(@range) . " elements")
		if $ENV{TEST_VERBOSE};
};

subtest 'parse_datetime - deeply nested bet...and... does not crash' => sub {
	# "bet bet A and B and C" is nonsensical but must not crash or loop forever.
	my $obj = $PKG->new(quiet => 1);

	my @result;
	lives_ok(
		sub { @result = $obj->parse_datetime('bet bet 1 Jan 2000 and 31 Dec 2000 and 1 Jan 2001') },
		'nested bet...and... does not crash',
	);
	diag("nested bet result: " . scalar(@result) . " elements") if $ENV{TEST_VERBOSE};
};

subtest 'parse_datetime - from...to... rejected by strict flag' => sub {
	my $obj = $PKG->new(strict => 1, quiet => 1);

	my @result = $obj->parse_datetime('from 1 Jan 2000 to 31 Dec 2000');
	is(scalar @result, 0, 'from...to... returns empty list when strict is set');
};

# ===========================================================================
# SECTION 8: Extremely long and malformed strings
# ===========================================================================

subtest 'parse_datetime - extremely long date strings do not crash or hang' => sub {
	my $obj = $PKG->new(quiet => 1);

	Readonly my $LONG_GARBAGE => 'X' x 10_000;
	Readonly my $LONG_DASH    => ('A' x 100) . ' - ' . ('B' x 100);
	Readonly my $LONG_BET     => 'bet ' . ('A ' x 500) . 'and ' . ('B ' x 500);

	my $t0 = [gettimeofday];
	lives_ok(sub { $obj->parse_datetime($LONG_GARBAGE) }, '10k garbage string: no crash');
	lives_ok(sub { $obj->parse_datetime($LONG_DASH)    }, 'long dash-range string: no crash');
	lives_ok(sub { $obj->parse_datetime($LONG_BET)     }, 'long bet...and... string: no crash');
	my $elapsed = tv_interval($t0);

	# Pathological regex backtracking would make this take many seconds.
	# Allow 30 s to accommodate slow CI / Windows runners while still catching
	# catastrophic backtracking (which would take minutes, not seconds).
	cmp_ok($elapsed, '<', 30, 'all long-string tests complete within 30 seconds');

	diag(sprintf('Long-string subtests took %.3fs', $elapsed)) if $ENV{TEST_VERBOSE};
};

subtest 'parse_datetime - shell-injection strings are inert' => sub {
	# The module must not execute shell commands.  These strings must return
	# undef without doing anything dangerous.
	my $obj = $PKG->new(quiet => 1);

	Readonly my @SHELL_STRINGS => (
		'25 Dec 2022; rm -rf /',
		'25 Dec 202`date`',
		'25 Dec 202$(cat /etc/passwd)',
		"25 Dec 2022\nrm -rf /",
		'25 Dec 202|cat /etc/passwd',
		'25 Dec 202 && id',
	);