Allow [array names -regexp] to use backreferences. This capability was broken by [71270e9141]. See also bug [1366683].

2 files changed, 17 insertions, 3 deletions

diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index ea25d4b..eb23f72 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -502,9 +502,16 @@ Tcl_RegExpMatchObj(
 {
     Tcl_RegExp re;
 
-    re = Tcl_GetRegExpFromObj(interp, patternObj,
-	    TCL_REG_ADVANCED | TCL_REG_NOSUB);
-    if (re == NULL) {
+    /*
+     * For performance reasons, first try compiling the RE without support for
+     * subexpressions. On failure, try again without TCL_REG_NOSUB in case the
+     * RE has backreferences in it. Closely related to [Bug 1366683]. If this
+     * still fails, an error message will be left in the interpreter.
+     */
+
+    if (!(re = Tcl_GetRegExpFromObj(interp, patternObj,
+	    TCL_REG_ADVANCED | TCL_REG_NOSUB))
+     && !(re = Tcl_GetRegExpFromObj(interp, patternObj, TCL_REG_ADVANCED))) {
 	return -1;
     }
     return Tcl_RegExpExecObj(interp, re, textObj, 0 /* offset */,
diff --git a/tests/set-old.test b/tests/set-old.test
index 93169f1..309abaf 100644
--- a/tests/set-old.test
+++ b/tests/set-old.test
@@ -652,6 +652,13 @@ test set-old-8.52 {array command, array names -regexp on regexp pattern} {
     set a(11) 1
     list [catch {lsort [array names a -regexp ^1]} msg] $msg
 } {0 {1*2 11 12}}
+test set-old-8.52.1 {array command, array names -regexp, backrefs} {
+    catch {unset a}
+    set a(1*2) 1
+    set a(12) 1
+    set a(11) 1
+    list [catch {lsort [array names a -regexp {^(.)\1}]} msg] $msg
+} {0 11}
 test set-old-8.53 {array command, array names -regexp} {
     catch {unset a}
     set a(-glob) 1