perldelta for smartmatch tainting fix

diff --git a/embed.fnc b/embed.fnc
index c23c020..de0e81e 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1741,7 +1741,8 @@ sR        |I32    |run_user_filter|int idx|NN SV *buf_sv|int maxlen
 sR     |PMOP*  |make_matcher   |NN REGEXP* re
 sR     |bool   |matcher_matches_sv|NN PMOP* matcher|NN SV* sv
 s      |void   |destroy_matcher|NN PMOP* matcher
-s      |OP*    |do_smartmatch  |NULLOK HV* seen_this|NULLOK HV* seen_other
+s      |OP*    |do_smartmatch  |NULLOK HV* seen_this \
+                               |NULLOK HV* seen_other|const bool copied
 #endif
 
 #if defined(PERL_IN_PP_HOT_C)

diff --git a/embed.h b/embed.h
index 675ab74..8f7d1c7 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -1383,7 +1383,7 @@
 #  if defined(PERL_IN_PP_CTL_C)
 #define check_type_and_open(a) S_check_type_and_open(aTHX_ a)
 #define destroy_matcher(a)     S_destroy_matcher(aTHX_ a)
-#define do_smartmatch(a,b)     S_do_smartmatch(aTHX_ a,b)
+#define do_smartmatch(a,b,c)   S_do_smartmatch(aTHX_ a,b,c)
 #define docatch(a)             S_docatch(aTHX_ a)
 #define doeval(a,b,c,d)                S_doeval(aTHX_ a,b,c,d)
 #define dofindlabel(a,b,c,d)   S_dofindlabel(aTHX_ a,b,c,d)

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index 69aa0b1..c4edddd 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -307,7 +307,10 @@ L</Modules and Pragmata>.
 
 =item *
 
-XXX
+In Perl 5.14.0, C<$tainted ~~ @array> stopped working properly.  Sometimes
+it would erroneously fail (when C<$tainted> contained a string that occurs
+in the array I<after> the first element) or erroneously succeed (when
+C<undef> occurred after the first element) [perl #93590].
 
 =back
 

diff --git a/pp_ctl.c b/pp_ctl.c
index 06d9124..cbeeeee 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4339,14 +4339,14 @@ S_destroy_matcher(pTHX_ PMOP *matcher)
 PP(pp_smartmatch)
 {
     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
-    return do_smartmatch(NULL, NULL);
+    return do_smartmatch(NULL, NULL, 0);
 }
 
 /* This version of do_smartmatch() implements the
  * table of smart matches that is found in perlsyn.
  */
 STATIC OP *
-S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
+S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
 {
     dVAR;
     dSP;
@@ -4358,7 +4358,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
     /* Take care only to invoke mg_get() once for each argument.
      * Currently we do this by copying the SV if it's magical. */
     if (d) {
-       if (SvGMAGICAL(d))
+       if (!copied && SvGMAGICAL(d))
            d = sv_mortalcopy(d);
     }
     else
@@ -4669,7 +4669,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
                        
                        PUTBACK;
                        DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
-                       (void) do_smartmatch(seen_this, seen_other);
+                       (void) do_smartmatch(seen_this, seen_other, 0);
                        SPAGAIN;
                        DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
                        
@@ -4731,7 +4731,7 @@ S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
                    PUTBACK;
                    /* infinite recursion isn't supposed to happen here */
                    DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
-                   (void) do_smartmatch(NULL, NULL);
+                   (void) do_smartmatch(NULL, NULL, 1);
                    SPAGAIN;
                    DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
                    if (SvTRUEx(POPs))

diff --git a/proto.h b/proto.h
index cc001e6..c46124d 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -5701,7 +5701,7 @@ STATIC void       S_destroy_matcher(pTHX_ PMOP* matcher)
 #define PERL_ARGS_ASSERT_DESTROY_MATCHER       \
        assert(matcher)
 
-STATIC OP*     S_do_smartmatch(pTHX_ HV* seen_this, HV* seen_other);
+STATIC OP*     S_do_smartmatch(pTHX_ HV* seen_this, HV* seen_other, const bool copied);
 STATIC OP*     S_docatch(pTHX_ OP *o)
                        __attribute__warn_unused_result__;
 

diff --git a/t/op/taint.t b/t/op/taint.t
index 3a2b5d9..3929f58 100644 (file)
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -17,7 +17,7 @@ BEGIN {
 use strict;
 use Config;
 
-plan tests => 779;
+plan tests => 781;
 
 $| = 1;
 
@@ -2156,6 +2156,11 @@ end
     ok(!tainted "", "tainting still works after index() of the constant");
 }
 
+# Tainted values with smartmatch
+# [perl #93590] S_do_smartmatch stealing its own string buffers
+ok "M$TAINT" ~~ ['m', 'M'], '$tainted ~~ ["whatever", "match"]';
+ok !("M$TAINT" ~~ ['m', undef]), '$tainted ~~ ["whatever", undef]';
+
 { # 111654
   eval {
     eval { die "Test\n".substr($ENV{PATH}, 0, 0); };