Stop ck_index from flattening other people’s SVs

By passing to fbm_compile the SV that is the second argument to
index(), ck_index causes it to be stringified.

That means, for example, that dualvars will lose their numeric
representation and regexps will be flattened (affecting regexp
code blocks).

This patch allows POK-only SVs to be compiled into BMs in place, as
it just adds magic and does not otherwise affect them.  Other SVs get
copied first.

Also, I avoided a compile-time uninitialized warning by not running
fbm_compile on undef SVs.

2 files changed, 30 insertions, 2 deletions

diff --git a/op.c b/op.c
index 3c113ac3d2..fcc476066a 100644
--- a/op.c
+++ b/op.c
@@ -9146,7 +9146,14 @@ Perl_ck_index(pTHX_ OP *o)
 	    kid = kid->op_sibling;			/* get past "big" */
 	if (kid && kid->op_type == OP_CONST) {
 	    const bool save_taint = TAINT_get;
-	    fbm_compile(((SVOP*)kid)->op_sv, 0);
+	    SV *sv = kSVOP->op_sv;
+	    if ((!SvPOK(sv) || SvNIOKp(sv)) && SvOK(sv) && !SvROK(sv)) {
+		sv = newSV(0);
+		sv_copypv(sv, kSVOP->op_sv);
+		SvREFCNT_dec_NN(kSVOP->op_sv);
+		kSVOP->op_sv = sv;
+	    }
+	    if (SvOK(sv)) fbm_compile(sv, 0);
 	    TAINT_set(save_taint);
 #ifdef NO_TAINT_SUPPORT
             PERL_UNUSED_VAR(save_taint);
diff --git a/t/op/index.t b/t/op/index.t
index ad014085f8..d53405383e 100644
--- a/t/op/index.t
+++ b/t/op/index.t
@@ -7,7 +7,7 @@ BEGIN {
 }
 
 use strict;
-plan( tests => 116 );
+plan( tests => 120 );
 
 run_tests() unless caller;
 
@@ -227,4 +227,25 @@ bless \our $referent, o::;
 is index("foo", riffraff), 0,
     'index respects changes in ref stringification';
 
+use constant quire => ${qr/(?{})/}; # A REGEXP, not a reference to one
+index "foo", quire;
+eval ' "" =~ quire ';
+is $@, "", 'regexp constants containing code blocks are not flattened';
+
+use constant bang => $! = 8;
+index "foo", bang;
+cmp_ok bang, '==', 8, 'dualvar constants are not flattened';
+
+use constant u => undef;
+{
+    my $w;
+    local $SIG{__WARN__} = sub { $w .= shift };
+    eval '
+        use warnings;
+        sub { () = index "foo", u; }
+    ';
+    is $w, undef, 'no warnings from compiling index($foo, undef_constant)';
+}
+is u, undef, 'undef constant is still undef';
+
 } # end of sub run_tests