Make pp_reverse fetch the lexical $_ from the correct pad

This is achieved by introducing a new find_rundefsv() function in pad.c

This fixes [perl #75436].

diff --git a/embed.fnc b/embed.fnc
index 8e463c1..6400f3e 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -856,6 +856,8 @@ p   |PADOFFSET|allocmy      |NN const char *const name|const STRLEN len\
 : Used in op.c and toke.c
 AMpdR  |PADOFFSET|pad_findmy   |NN const char* name|STRLEN len|U32 flags
 Ap     |PADOFFSET|find_rundefsvoffset  |
+: Used in pp.c
+Ap     |SV*    |find_rundefsv  |
 : Used in perly.y
 pR     |OP*    |oopsAV         |NN OP* o
 : Used in perly.y

diff --git a/embed.h b/embed.h
index 90e8045..588c50a 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -673,6 +673,7 @@
 #endif
 #define pad_findmy             Perl_pad_findmy
 #define find_rundefsvoffset    Perl_find_rundefsvoffset
+#define find_rundefsv          Perl_find_rundefsv
 #ifdef PERL_CORE
 #define oopsAV                 Perl_oopsAV
 #define oopsHV                 Perl_oopsHV
@@ -3106,6 +3107,7 @@
 #endif
 #define pad_findmy(a,b,c)      Perl_pad_findmy(aTHX_ a,b,c)
 #define find_rundefsvoffset()  Perl_find_rundefsvoffset(aTHX)
+#define find_rundefsv()                Perl_find_rundefsv(aTHX)
 #ifdef PERL_CORE
 #define oopsAV(a)              Perl_oopsAV(aTHX_ a)
 #define oopsHV(a)              Perl_oopsHV(aTHX_ a)

diff --git a/global.sym b/global.sym
index 8861fca..5ab0090 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -396,6 +396,7 @@ Perl_ninstr
 Perl_op_free
 Perl_pad_findmy
 Perl_find_rundefsvoffset
+Perl_find_rundefsv
 Perl_pad_sv
 Perl_reentrant_size
 Perl_reentrant_init

diff --git a/pad.c b/pad.c
index 477ee0f..e8ba139 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -704,6 +704,28 @@ Perl_find_rundefsvoffset(pTHX)
 }
 
 /*
+ * Returns a lexical $_, if there is one, at run time ; or the global one
+ * otherwise.
+ */
+
+SV *
+Perl_find_rundefsv(pTHX)
+{
+    SV *namesv;
+    int flags;
+    PADOFFSET po;
+
+    po = pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
+           NULL, &namesv, &flags);
+
+    if (po == NOT_IN_PAD
+       || (SvFLAGS(namesv) & (SVpad_NAME|SVpad_OUR)) == (SVpad_NAME|SVpad_OUR))
+       return DEFSV;
+
+    return PAD_SVl(po);
+}
+
+/*
 =for apidoc pad_findlex
 
 Find a named lexical anywhere in a chain of nested pads. Add fake entries

diff --git a/pod/perl5132delta.pod b/pod/perl5132delta.pod
index fe45773..613f814 100644 (file)
--- a/pod/perl5132delta.pod
+++ b/pod/perl5132delta.pod
@@ -182,7 +182,7 @@ XXX Changes which affect the interface available to C<XS> code go here.
 =item *
 
 The following new functions or macros have been added to the public API:
-C<SvNV_nomg>,  C<sv_2nv_flags>.
+C<SvNV_nomg>,  C<sv_2nv_flags>, C<find_rundefsv>.
 
 =back
 

diff --git a/pp.c b/pp.c
index 937fdfd..2649c7e 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -5489,19 +5489,12 @@ PP(pp_reverse)
        register I32 tmp;
        dTARGET;
        STRLEN len;
-       PADOFFSET padoff_du;
 
        SvUTF8_off(TARG);                               /* decontaminate */
        if (SP - MARK > 1)
            do_join(TARG, &PL_sv_no, MARK, SP);
        else {
-           sv_setsv(TARG, (SP > MARK)
-                   ? *SP
-                   : (padoff_du = find_rundefsvoffset(),
-                       (padoff_du == NOT_IN_PAD
-                        || PAD_COMPNAME_FLAGS_isOUR(padoff_du))
-                       ? DEFSV : PAD_SVl(padoff_du)));
-
+           sv_setsv(TARG, SP > MARK ? *SP : find_rundefsv());
            if (! SvOK(TARG) && ckWARN(WARN_UNINITIALIZED))
                report_uninit(TARG);
        }

diff --git a/proto.h b/proto.h
index 6ccf19c..c27313c 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2510,6 +2510,7 @@ PERL_CALLCONV PADOFFSET   Perl_pad_findmy(pTHX_ const char* name, STRLEN len, U32
        assert(name)
 
 PERL_CALLCONV PADOFFSET        Perl_find_rundefsvoffset(pTHX);
+PERL_CALLCONV SV*      Perl_find_rundefsv(pTHX);
 PERL_CALLCONV OP*      Perl_oopsAV(pTHX_ OP* o)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1);

diff --git a/t/op/reverse.t b/t/op/reverse.t
index 2fa0877..916724c 100644 (file)
--- a/t/op/reverse.t
+++ b/t/op/reverse.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 23;
+plan tests => 26;
 
 is(reverse("abc"), "cba");
 
@@ -91,3 +91,15 @@ use Tie::Array;
     my $c = scalar reverse($b);
     is($a, $c);
 }
+
+{
+    # Lexical $_.
+    sub blurp { my $_ = shift; reverse }
+
+    is(blurp("foo"), "oof");
+    is(sub { my $_ = shift; reverse }->("bar"), "rab");
+    {
+        local $_ = "XXX";
+        is(blurp("paz"), "zap");
+    }
+}