perl regular expressions

use Test::More;
use Test::Deep;

my $recursion_limit = $] < 5.030
	? 32766
	: 65534
	;

my $DEFINE_ESCAPE_SEQUENCE = qr/
	(?(DEFINE)
		(?<Escape_Sequence>(?>
			\\
			(?:
				  (?<char_escape> (?: [btnrf\'\"\\] ))
				| (?<octal_escape> (?: (?= [0-7]) [0-3]? [0-7]{1,2} ))
				| (?: u+ (?<hex_escape> [[:xdigit:]]{4} ))
			)
		))
	)/x;

sub regex;

subtest "naive regex" => sub {
	note 'Naive approach to match - match single element multiple time';
	note 'limit = $recursion limit / (number of branches)';

	my $regex = qr/
		\"
		(?: [^\"\\] | (?&Escape_Sequence) )*
		\"

		$DEFINE_ESCAPE_SEQUENCE
	/sx;

	regex "should match string up to recursion limit characters" =>
		with_snippet   => 'x',
		with_size      => $recursion_limit,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 0,
		;

	regex "should match string longer than recursion limit characters but emits warning" =>
		with_snippet   => 'x',
		with_size      => $recursion_limit + 1,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 1,
		;

	regex "should match string up to recursion limit escape sequences" =>
		with_snippet   => '\\\\',
		with_size      => $recursion_limit,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 0,
		;

	regex "should match string with about recursion limit escape sequences but emits warning" =>
		with_snippet   => '\\\\',
		with_size      => $recursion_limit + 1,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 1,
		;

	regex "should match string with up to recursion limit alternatives" =>
		with_snippet   => 'x\\\\',
		with_size      => $recursion_limit / 2,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 0,
		;

	regex "should not match string above recursion limit alternatives" =>
		with_snippet   => 'x\\\\',
		with_size      => $recursion_limit / 2 + 1,
		with_regex     => $regex,
		expect_match   => 0,
		expect_warning => 1,
		;

	regex "should not timeout with 2 * max recursion (but not match)" =>
		with_snippet   => 'x\\\\',
		with_size      => 2 + $recursion_limit,
		with_regex     => $regex,
		expect_warning => 1,
		expect_timeout => 0,
		expect_match   => 0,
		;

	done_testing;
};

subtest "grouping regex" => sub {
	note 'Match multiple times sequence of chars-escapes';

	my $regex = qr/
		\"
		(?: [^\"\\]* (?&Escape_Sequence)* )*
		\"

		$DEFINE_ESCAPE_SEQUENCE
	/sx;

	regex "should match string up to recursion limit characters" =>
		with_snippet   => 'x',
		with_size      => $recursion_limit,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 0,
		;

	regex "should match string longer than recursion limit characters without warning" =>
		with_snippet   => 'x',
		with_size      => $recursion_limit + 1,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 0,
		;

	regex "should match string up to recursion limit escape sequences" =>
		with_snippet   => '\\\\',
		with_size      => $recursion_limit,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 0,
		;

	regex "should match string with about recursion limit escape sequences but emits warning" =>
		with_snippet   => '\\\\',
		with_size      => $recursion_limit + 1,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 1,
		;

	regex "should match string with up to recursion limit alternatives" =>
		with_snippet   => 'x\\\\',
		with_size      => $recursion_limit / 2,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 0,
		;

	regex "should match string above recursion limit alternatives" =>
		with_snippet   => 'x\\\\',
		with_size      => $recursion_limit / 2 + 1,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 0,
		;

	regex "should match string shorter that max recursion without timeout" =>
		with_snippet   => 'x\\\\',
		with_size      => 1 + $recursion_limit,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 1,
		expect_timeout => 0,
		;

	regex "should timeout with 2 * max recursion" =>
		with_snippet   => 'x\\\\',
		with_size      => 2 + $recursion_limit,
		with_regex     => $regex,
		expect_warning => 1,
		expect_timeout => 1,
		;

	done_testing;
};

subtest "grouping regex with branch reset" => sub {
	note 'Match multiple times sequence of chars-escapes';

	my $regex = qr/
		\"
		(?> (?: (?> [^\"\\] )* (?> (?&Escape_Sequence) )* )* )
		\"

		$DEFINE_ESCAPE_SEQUENCE
	/sx;

	regex "should match string up to recursion limit characters" =>
		with_snippet   => 'x',
		with_size      => $recursion_limit,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 0,
		;

	regex "should match string longer than recursion limit characters without warning" =>
		with_snippet   => 'x',
		with_size      => $recursion_limit + 1,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 0,
		;

	regex "should match string up to recursion limit escape sequences" =>
		with_snippet   => '\\\\',
		with_size      => $recursion_limit,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 0,
		;

	regex "should match string with about recursion limit escape sequences but emits warning" =>
		with_snippet   => '\\\\',
		with_size      => $recursion_limit + 1,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 1,
		;

	regex "should match string with up to recursion limit alternatives" =>
		with_snippet   => 'x\\\\',
		with_size      => $recursion_limit / 2,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 0,
		;

	regex "should match string above recursion limit alternatives" =>
		with_snippet   => 'x\\\\',
		with_size      => $recursion_limit / 2 + 1,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 0,
		;

	regex "should match string shorter that max recursion without timeout" =>
		with_snippet   => 'x\\\\',
		with_size      => 1 + $recursion_limit,
		with_regex     => $regex,
		expect_match   => 1,
		expect_warning => 1,
		expect_timeout => 0,
		;

	regex "should not timeout with 2 * max recursion (but no match)" =>
		with_snippet   => 'x\\\\',
		with_size      => 2 + $recursion_limit,
		with_regex     => $regex,
		expect_match   => 0,
		expect_warning => 1,
		expect_timeout => 0,
		;

	done_testing;
};

done_testing;

sub regex {
	my ($title, %params) = @_;

	my @warnings;
	local $SIG{__WARN__} = sub { push @warnings, @_; diag @_ };

	my $snippet = $params{with_snippet};
	my $string = join '', '"', ($snippet) x $params{with_size}, '"';
	my $regex  = $params{with_regex};
	my $expect = $params{expect_match};

	my $had_timeout;
	my $got;

	eval {
		local $SIG{ALRM} = sub { $had_timeout = 1; die };
		alarm 5;

		$got = $string =~ m/^$regex/;
	};

	if ($params{expect_timeout}) {
		ok $had_timeout, $title
			or diag "expected timeout but got ${\ ($got ? 'match' : 'no match') }";
	} elsif ($had_timeout) {
		fail "unexpected timeout ($title)";
	} else {
		$expect
			? ok   $got, $title
			: ok ! $got, $title
			;
	}

	if ($params{expect_warning}) {
		# Unrelated - perl warnings and exceptions should be objects or contain warning/error code
		# Current test may not be valid
		#   grep "French locale warning" =~ ...
		# Imagine possibility of having one of following tests instead
		#   grep $_->isa ('CORE::W::Regex::Complex')
		#   grep $_ =~ m/^PERL5-W-123:/
		#   grep $_ == PERL5-W-123
		#   grep $_ == -123
		my $got = grep $_ =~ m/Complex regular subexpression recursion limit/, @warnings;
		ok $got, "recursion limit warning should appear ($title)";
	} else {
		ok ! @warnings, "no warning should appear";
	}
}