fix(regex): advance native Joni diagnostics and strict policy

src/main/java/org/perlonjava/frontend/parser/StringParser.java

@@ -25,6 +25,7 @@
 import static org.perlonjava.runtime.perlmodule.Strict.HINT_RE_TAINT;
 import static org.perlonjava.runtime.perlmodule.Strict.HINT_RE_DEBUG;
 import static org.perlonjava.runtime.perlmodule.Strict.HINT_RE_DEBUGCOLOR;
+import static org.perlonjava.runtime.perlmodule.Strict.HINT_RE_STRICT;
 import static org.perlonjava.runtime.perlmodule.Strict.HINT_LOCALE;
 import static org.perlonjava.runtime.runtimetypes.NameNormalizer.normalizeVariableName;
 import static org.perlonjava.runtime.runtimetypes.ScalarUtils.printable;
@@ -710,6 +711,9 @@ static String addLexicalRegexContext(EmitterContext ctx, String modifiers) {
         if (ctx.symbolTable.isStrictOptionEnabled(HINT_RE_TAINT) && !result.contains("T")) {
             result = "T" + result;
         }
+        if (ctx.symbolTable.isStrictOptionEnabled(HINT_RE_STRICT)) {
+            result += RuntimeRegex.INTERNAL_RE_STRICT_MARKER;
+        }
         return addLexicalRegexDebugMarker(ctx, result);
     }
 

src/main/java/org/perlonjava/runtime/perlmodule/Re.java

@@ -181,6 +181,7 @@ public static RuntimeList importRe(RuntimeArray args, int ctx) {
                 RuntimeScalar targetCode = getGlobalCodeRef(caller + "::regexp_pattern");
                 targetCode.set(sourceCode);
             } else if (opt.equalsIgnoreCase("strict")) {
+                symbolTable.enableStrictOption(Strict.HINT_RE_STRICT);
                 // Enable categories used by our preprocessor warnings
                 Warnings.warningManager.enableWarning("experimental::re_strict");
                 Warnings.warningManager.enableWarning("experimental::uniprop_wildcards");
@@ -227,6 +228,7 @@ public static RuntimeList unimportRe(RuntimeArray args, int ctx) {
             opt = opt.replace("\"", "").replace("'", "").trim();
 
             if (opt.equalsIgnoreCase("strict")) {
+                symbolTable.disableStrictOption(Strict.HINT_RE_STRICT);
                 Warnings.warningManager.disableWarning("experimental::re_strict");
                 Warnings.warningManager.disableWarning("experimental::uniprop_wildcards");
                 Warnings.warningManager.disableWarning("experimental::vlb");

src/main/java/org/perlonjava/runtime/perlmodule/Strict.java

@@ -51,6 +51,7 @@ private static void propagatePragmaFlags(ScopedSymbolTable source) {
     public static final int HINT_RE_TAINT = 0x00002000;      // use re 'taint'
     public static final int HINT_RE_DEBUG = 0x00004000;      // use re 'debug'
     public static final int HINT_RE_DEBUGCOLOR = 0x00008000; // use re 'debugcolor'
+    public static final int HINT_RE_STRICT = 0x00010000;     // use re 'strict'
 
     /**
      * Constructor for Strict.

src/main/java/org/perlonjava/runtime/regex/JoniRegexPattern.java

@@ -525,9 +525,26 @@ static boolean requiresJoniBackend(String pattern, RegexFlags flags) {
                 || pattern.contains("(*COMMIT")
                 || pattern.contains("(*MARK")
                 || pattern.contains("(*:")
+                || containsPerlEmptyCharacterClass(pattern)
                 || hasSubroutineCall;
     }
 
+    private static boolean containsPerlEmptyCharacterClass(String pattern) {
+        boolean quoted = false;
+        for (int i = 0; i + 1 < pattern.length(); i++) {
+            char ch = pattern.charAt(i);
+            if (ch == '\\') {
+                char next = pattern.charAt(i + 1);
+                if (quoted && next == 'E') quoted = false;
+                else if (!quoted && next == 'Q') quoted = true;
+                i++;
+                continue;
+            }
+            if (!quoted && ch == '[' && pattern.charAt(i + 1) == ']') return true;
+        }
+        return false;
+    }
+
     static boolean containsNamedCharacterEscape(String pattern) {
         if (pattern == null) return false;
         for (int i = 0; i + 2 < pattern.length(); i++) {

src/test/java/org/perlonjava/runtime/regex/NativeEmptyClassRoutingTest.java

@@ -0,0 +1,22 @@
+package org.perlonjava.runtime.regex;
+
+import static org.junit.jupiter.api.Assertions.assertFalse;
+import static org.junit.jupiter.api.Assertions.assertTrue;
+
+import org.junit.jupiter.api.Tag;
+import org.junit.jupiter.api.Test;
+
+@Tag("unit")
+class NativeEmptyClassRoutingTest {
+    @Test
+    void routesPerlEmptyClassToJoni() {
+        assertTrue(JoniRegexPattern.requiresJoniBackend("a[]b"));
+        assertTrue(JoniRegexPattern.requiresJoniBackend("(?i:a[]b)"));
+    }
+
+    @Test
+    void ignoresEscapedAndQuotedBracketPairs() {
+        assertFalse(JoniRegexPattern.requiresJoniBackend("a\\[]b"));
+        assertFalse(JoniRegexPattern.requiresJoniBackend("\\Q[]\\E"));
+    }
+}

src/test/resources/unit/regex/boundary_empty_whitespace.t

@@ -0,0 +1,17 @@
+use strict;
+use warnings;
+use Test::More;
+
+for my $name (qw(gcb sb wb lb)) {
+    my $positive = qr/\b{$name}/;
+    my $negative = qr/\B{$name}/;
+    my $spaced_positive = qr/\b{ $name }/;
+    my $spaced_negative = qr/\B{ $name }/;
+
+    unlike('', $positive, "empty text has no $name boundary");
+    like('', $negative, "empty text satisfies negated $name boundary");
+    unlike('', $spaced_positive, "whitespace is accepted around $name");
+    like('', $spaced_negative, "spaced negated $name retains empty semantics");
+}
+
+done_testing;

src/test/resources/unit/regex/character_class_closing_bracket.t

@@ -0,0 +1,26 @@
+use strict;
+use warnings;
+use Test::More;
+
+my @cases = (
+    [ 'a]',       'a]',  1, 'closing bracket outside a class is literal' ],
+    [ 'a[]]b',    'a]b', 1, 'leading closing bracket in a class is literal' ],
+    [ 'a[^]b]c',  'a]c', 0, 'negated class excludes its leading bracket' ],
+    [ 'a[^]b]c',  'adc', 1, 'negated class retains its ordinary members' ],
+    [ '2(]*)?$\\1', '2', 1, 'closing bracket class composes with backreference' ],
+);
+
+for my $case (@cases) {
+    my ($pattern, $subject, $expected, $name) = @$case;
+    my @warnings;
+    my $regex;
+    {
+        local $SIG{__WARN__} = sub { push @warnings, @_ };
+        $regex = eval { qr/$pattern/ };
+    }
+    is($@, '', "$name compiles");
+    is(scalar @warnings, 0, "$name has no warning");
+    is(($subject =~ $regex) ? 1 : 0, $expected, $name);
+}
+
+done_testing;

src/test/resources/unit/regex/character_class_range_diagnostic.t

@@ -0,0 +1,11 @@
+use strict;
+use warnings;
+use Test::More;
+
+for my $pattern ('[b-a]', '(?i:a[b-a])', '[\x{100}-\x{ff}]') {
+    my $regex = eval { qr/$pattern/ };
+    ok(!defined($regex), "$pattern is rejected");
+    like($@, qr/^Invalid \[\] range/, "$pattern uses Perl range diagnostic");
+}
+
+done_testing;

src/test/resources/unit/regex/empty_character_class_diagnostic.t

@@ -0,0 +1,11 @@
+use strict;
+use warnings;
+use Test::More;
+
+for my $pattern ('a[]b', '(?i:a[]b)') {
+    my $regex = eval { qr/$pattern/ };
+    ok(!defined($regex), "$pattern is rejected");
+    like($@, qr/^Unmatched \[/, "$pattern uses Perl unmatched-class diagnostic");
+}
+
+done_testing;

src/test/resources/unit/regex/posix_class_unknown_diagnostic.t

@@ -0,0 +1,13 @@
+use strict;
+use warnings;
+use Test::More;
+
+for my $name ('foo', '^foo', 'xyz') {
+    my $pattern = "[[:$name:]]";
+    my $regex = eval { qr/$pattern/ };
+    ok(!defined($regex), "$pattern is rejected");
+    like($@, qr/^POSIX class \[:\Q$name\E:\] unknown/,
+        "$pattern uses Perl POSIX-class diagnostic");
+}
+
+done_testing;

src/test/resources/unit/regex/quantifier_follows_nothing_diagnostic.t

@@ -0,0 +1,12 @@
+use strict;
+use warnings;
+use Test::More;
+
+for my $pattern ('*a', '(|*)b', '(?i:*a)', '(?i:(|*)b)') {
+    my $regex = eval { qr/$pattern/ };
+    ok(!defined($regex), "$pattern is rejected");
+    like($@, qr/^Quantifier follows nothing/,
+        "$pattern uses Perl leading-quantifier diagnostic");
+}
+
+done_testing;

src/test/resources/unit/regex/quantifier_omitted_lower_bound.t

@@ -0,0 +1,38 @@
+use strict;
+use warnings;
+use Test::More;
+
+sub compile_pattern {
+    my ($pattern, $strict) = @_;
+    my (@warnings, $regex, $error);
+    {
+        local $SIG{__WARN__} = sub { push @warnings, @_ };
+        if ($strict) {
+            no warnings 'experimental::re_strict';
+            use re 'strict';
+            $regex = eval { qr/$pattern/ };
+        }
+        else {
+            $regex = eval { qr/$pattern/ };
+        }
+        $error = $@;
+    }
+    return ($regex, $error, \@warnings);
+}
+
+for my $case (
+    [ 'a{,2}',          'aa' ],
+    [ 'a{, 2 }',        'aa' ],
+    [ 'a{ , 2 }',       'aa' ],
+    [ '[x]{, 2}',       'xx' ],
+    [ '\p{Latin}{ , 2 }', 'a' ],
+) {
+    my ($pattern, $subject) = @$case;
+    for my $strict (0, 1) {
+        my ($regex, $error, $warnings) = compile_pattern($pattern, $strict);
+        ok(defined($regex) && $error eq '' && !@$warnings && $subject =~ /\A$regex\z/,
+            "$pattern is a quiet quantifier" . ($strict ? ' under re strict' : ''));
+    }
+}
+
+done_testing;

src/test/resources/unit/regex/regex_re_strict_left_brace_policy.t

@@ -0,0 +1,80 @@
+use strict;
+use warnings;
+use Test::More;
+
+sub capture_eval_string {
+    my ($source) = @_;
+    my @warnings;
+    local $SIG{__WARN__} = sub { push @warnings, @_ };
+    my $value = eval $source;
+    return ($value, $@, \@warnings);
+}
+
+sub compile_default {
+    my ($pattern) = @_;
+    my @warnings;
+    local $SIG{__WARN__} = sub { push @warnings, @_ };
+    my $value = eval { qr/$pattern/ };
+    return ($value, $@, \@warnings);
+}
+
+{
+    no warnings 'experimental::re_strict';
+    use re 'strict';
+
+    sub compile_strict {
+        my ($pattern) = @_;
+        my @warnings;
+        local $SIG{__WARN__} = sub { push @warnings, @_ };
+        my $value = eval { qr/$pattern/ };
+        return ($value, $@, \@warnings);
+    }
+}
+
+my ($value, $error, $warnings) = compile_default('\\w{');
+ok(!defined($value), 'ambiguous brace after escape is fatal by default');
+like($error, qr/^Unescaped left brace in regex is illegal here in regex; marked by <-- HERE in m\/\\w\{ <-- HERE \/ at /,
+    'default fatal marker follows brace');
+is(scalar(@$warnings), 0, 'default fatal emits no warning');
+
+($value, $error, $warnings) = compile_default(':{4,a}');
+ok(defined($value) && $error eq '', 'malformed quantifier-like brace passes by default');
+like($warnings->[0] // '', qr/^Unescaped left brace in regex is passed through in regex; marked by <-- HERE in m\/:\{ <-- HERE 4,a\}\/ at /,
+    'default warning marker follows brace');
+
+($value, $error, $warnings) = compile_strict(':{4,a}');
+ok(!defined($value), 'malformed quantifier-like brace is fatal under lexical strict');
+like($error, qr/^Unescaped left brace in regex is illegal here in regex; marked by <-- HERE in m\/:\{ <-- HERE 4,a\}\/ at /,
+    'strict fatal marker follows brace');
+is(scalar(@$warnings), 0, 'strict fatal emits no warning');
+
+($value, $error, $warnings) = capture_eval_string(q{qr/:{4,a}/});
+ok(defined($value) && $error eq '' && @$warnings == 1,
+    'literal malformed brace warns outside strict');
+
+($value, $error, $warnings) = capture_eval_string(
+    q{no warnings 'experimental::re_strict'; use re 'strict'; qr/:{4,a}/});
+ok(!defined($value) && $error =~ /^Unescaped left brace in regex is illegal here/,
+    'literal malformed brace is fatal inside strict');
+
+for my $pattern ('^{', 'foo|{', '\\s*{', 'a{3,4}{', 'foo(:?{bar)') {
+    ($value, $error, $warnings) = compile_strict($pattern);
+    ok(defined($value) && $error eq '' && @$warnings == 0,
+        "allowed brace context remains quiet: $pattern");
+}
+
+my @boundary_cases = (
+    ['\\B{gc}', qr/^'gc' is an unknown bound type in regex/],
+    ['\\B{}', qr/^Empty \\B\{\} in regex/],
+    ['a\\B{cde', qr/^Missing right brace on \\B\{\} in regex/],
+);
+for my $case (@boundary_cases) {
+    my ($pattern, $expected) = @$case;
+    for my $compiler (\&compile_default, \&compile_strict) {
+        ($value, $error, $warnings) = $compiler->($pattern);
+        ok(!defined($value) && $error =~ $expected && @$warnings == 0,
+            "boundary brace keeps its dedicated diagnostic: $pattern");
+    }
+}
+
+done_testing;

src/test/resources/unit/regex/regex_re_strict_nonhex_policy.t

@@ -0,0 +1,63 @@
+use strict;
+use warnings;
+use Test::More;
+
+sub capture_eval_string {
+    my ($source) = @_;
+    my @warnings;
+    local $SIG{__WARN__} = sub { push @warnings, @_ };
+    my $value = eval $source;
+    return ($value, $@, \@warnings);
+}
+
+sub compile_default {
+    my ($pattern) = @_;
+    my @warnings;
+    local $SIG{__WARN__} = sub { push @warnings, @_ };
+    my $value = eval { qr/$pattern/ };
+    return ($value, $@, \@warnings);
+}
+
+{
+    no warnings 'experimental::re_strict';
+    use re 'strict';
+
+    sub compile_strict {
+        my ($pattern) = @_;
+        my @warnings;
+        local $SIG{__WARN__} = sub { push @warnings, @_ };
+        my $value = eval { qr/$pattern/ };
+        return ($value, $@, \@warnings);
+    }
+}
+
+my @cases = (
+    ['\\xAG',            'm/\\xAG <-- HERE /'],
+    ['[\\xAG]',          'm/[\\xAG <-- HERE ]/'],
+    ['\\x{ABCDEFG}',     'm/\\x{ABCDEFG <-- HERE }/'],
+    ['[\\x{ABCDEFG}]',   'm/[\\x{ABCDEFG <-- HERE }]/'],
+    ['\\x{ 5 0 }',       'm/\\x{ 5  <-- HERE 0 }/'],
+);
+
+for my $case (@cases) {
+    my ($pattern, $marked_pattern) = @$case;
+    my ($value, $error, $warnings) = compile_default($pattern);
+    ok(defined($value) && $error eq '', "non-hex escape passes by default: $pattern");
+    is(scalar(@$warnings), 1, "default non-hex escape warns exactly once: $pattern");
+    like($warnings->[0] // '', qr/^Non-hex character '.+' terminates \\x early\.  Resolved as /,
+        "default non-hex warning retained: $pattern");
+
+    ($value, $error, $warnings) = compile_strict($pattern);
+    ok(!defined($value), "non-hex escape is fatal under lexical strict: $pattern");
+    like($error, qr/^Non-hex character in regex; marked by <-- HERE in \Q$marked_pattern\E at /,
+        "strict non-hex marker: $pattern");
+    is(scalar(@$warnings), 0, "strict non-hex fatal emits no warning: $pattern");
+}
+
+my ($literal, $literal_error, $literal_warnings) = capture_eval_string(q!qr/\xAG/!);
+ok(defined($literal) && $literal_error eq '', 'literal unbraced non-hex escape compiles');
+is(scalar(@$literal_warnings), 1, 'literal unbraced non-hex escape warns exactly once');
+like($literal_warnings->[0], qr/^Non-hex character 'G' terminates \\x early/,
+    'literal unbraced non-hex warning keeps Perl text');
+
+done_testing;

third_party/joni/src/org/joni/ByteCodeMachine.java

@@ -1399,6 +1399,7 @@ private void opWordBreakBoundary(boolean negated) {
     }
 
     private boolean isWordBreakBoundary() {
+        if (str == end) return false;
         if (s <= str || s >= end) return true; // WB1, WB2
 
         int leftPosition = enc.prevCharHead(bytes, str, s, end);
@@ -1858,6 +1859,7 @@ private int precedingLineRun(int position, short value) {
     }
 
     private boolean isSentenceBoundary() {
+        if (str == end) return false;
         if (s <= str || s >= end) return true; // SB1, SB2
 
         int leftPosition = enc.prevCharHead(bytes, str, s, end);
@@ -1981,6 +1983,7 @@ private boolean isSentenceTerminal(byte property) {
     }
 
     private boolean isGraphemeBoundary() {
+        if (str == end) return false;
         if (s <= str || s >= end) return true; // GB1, GB2
 
         int leftPosition = enc.prevCharHead(bytes, str, s, end);