Make the dUNDERBAR/UNDERBAR macros work as advertised.

While we're at it, use the same trick to make reverse()
work correctly with lexical $_.

p4raw-id: //depot/perl@22889

diff --git a/XSUB.h b/XSUB.h
index a1e48dd..563d331 100644 (file)
--- a/XSUB.h
+++ b/XSUB.h
@@ -114,7 +114,7 @@ is a lexical $_ in scope.
 #define XSINTERFACE_FUNC_SET(cv,f)     \
                CvXSUBANY(cv).any_dxptr = (void (*) (pTHX_ void*))(f)
 
-#define dUNDERBAR I32 padoff_du = pad_findmy("$_")
+#define dUNDERBAR I32 padoff_du = Perl_find_rundefsvoffset()
 #define UNDERBAR ((padoff_du == NOT_IN_PAD \
            || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR) \
        ? DEFSV : PAD_SVl(padoff_du))

diff --git a/embed.fnc b/embed.fnc
index 1ee63c3..b69b792 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -551,6 +551,7 @@ p   |void   |package        |OP* o
 pd     |PADOFFSET|pad_alloc    |I32 optype|U32 tmptype
 p      |PADOFFSET|allocmy      |char* name
 pd     |PADOFFSET|pad_findmy   |char* name
+Ap     |PADOFFSET|find_rundefsvoffset  |
 p      |OP*    |oopsAV         |OP* o
 p      |OP*    |oopsHV         |OP* o
 pd     |void   |pad_leavemy

diff --git a/embed.h b/embed.h
index 4eef0bf..96b6d7c 100644 (file)
--- a/embed.h
+++ b/embed.h
@@ -761,6 +761,7 @@
 #ifdef PERL_CORE
 #define pad_findmy             Perl_pad_findmy
 #endif
+#define find_rundefsvoffset    Perl_find_rundefsvoffset
 #ifdef PERL_CORE
 #define oopsAV                 Perl_oopsAV
 #endif
@@ -3387,6 +3388,7 @@
 #ifdef PERL_CORE
 #define pad_findmy(a)          Perl_pad_findmy(aTHX_ a)
 #endif
+#define find_rundefsvoffset()  Perl_find_rundefsvoffset(aTHX)
 #ifdef PERL_CORE
 #define oopsAV(a)              Perl_oopsAV(aTHX_ a)
 #endif

diff --git a/global.sym b/global.sym
index 46b6458..d97151e 100644 (file)
--- a/global.sym
+++ b/global.sym
@@ -329,6 +329,7 @@ Perl_vstringify
 Perl_vcmp
 Perl_ninstr
 Perl_op_free
+Perl_find_rundefsvoffset
 Perl_pad_sv
 Perl_reentrant_size
 Perl_reentrant_init

diff --git a/pad.c b/pad.c
index d7799c9..0b0491c 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -582,6 +582,19 @@ Perl_pad_findmy(pTHX_ char *name)
     return NOT_IN_PAD;
 }
 
+/*
+ * Returns the offset of a lexical $_, if there is one, at run time.
+ * Used by the UNDERBAR XS macro.
+ */
+
+PADOFFSET
+Perl_find_rundefsvoffset()
+{
+    SV *out_sv;
+    int out_flags;
+    return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
+           Null(SV**), &out_sv, &out_flags);
+}
 
 /*
 =for apidoc pad_findlex

diff --git a/pp.c b/pp.c
index 60eaf28..c0c7420 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -4334,12 +4334,17 @@ PP(pp_reverse)
        register I32 tmp;
        dTARGET;
        STRLEN len;
+       I32 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 : DEFSV);
+           sv_setsv(TARG, (SP > MARK)
+                   ? *SP
+                   : (padoff_du = Perl_find_rundefsvoffset(),
+                       (padoff_du == NOT_IN_PAD || PAD_COMPNAME_FLAGS(padoff_du) & SVpad_OUR)
+                       ? DEFSV : PAD_SVl(padoff_du)));
        up = SvPV_force(TARG, len);
        if (len > 1) {
            if (DO_UTF8(TARG)) {        /* first reverse each character */

diff --git a/proto.h b/proto.h
index 9dcf1c8..39a5e20 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -529,6 +529,7 @@ PERL_CALLCONV void  Perl_package(pTHX_ OP* o);
 PERL_CALLCONV PADOFFSET        Perl_pad_alloc(pTHX_ I32 optype, U32 tmptype);
 PERL_CALLCONV PADOFFSET        Perl_allocmy(pTHX_ char* name);
 PERL_CALLCONV PADOFFSET        Perl_pad_findmy(pTHX_ char* name);
+PERL_CALLCONV PADOFFSET        Perl_find_rundefsvoffset(pTHX);
 PERL_CALLCONV OP*      Perl_oopsAV(pTHX_ OP* o);
 PERL_CALLCONV OP*      Perl_oopsHV(pTHX_ OP* o);
 PERL_CALLCONV void     Perl_pad_leavemy(pTHX);

diff --git a/t/op/mydef.t b/t/op/mydef.t
index 485f843..f089c31 100644 (file)
--- a/t/op/mydef.t
+++ b/t/op/mydef.t
@@ -164,7 +164,7 @@ $_ = "global";
 {
     my $_ = "abc";
     my $x = reverse;
-    ok( $x eq "cba", 'reverse without arguments picks up $_ # TODO' );
+    ok( $x eq "cba", 'reverse without arguments picks up $_' );
 }
 
 {