Add find_rundefsv2 function
authorFather Chrysostomos <sprout@cpan.org>
Thu, 18 Aug 2011 22:55:59 +0000 (15:55 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Thu, 25 Aug 2011 06:25:35 +0000 (23:25 -0700)
Subs in the CORE package with a (_) prototype will use this.

This accepts a CV and a sequence number, so that one can
use it to find the $_ in the caller’s scope.  It only uses
the topmost call of a subroutine that is being called recur-
sively, so it’s not really a general-purpose function.  But
it suffices for &CORE::abs and friends.

embed.fnc
embed.h
pad.c
proto.h

index 636361b..efbca48 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -2152,6 +2152,8 @@ ApdR      |PADOFFSET|pad_findmy_pv|NN const char* name|U32 flags
 ApdR   |PADOFFSET|pad_findmy_sv|NN SV* name|U32 flags
 ApdD   |PADOFFSET|find_rundefsvoffset  |
 Apd    |SV*    |find_rundefsv  |
+: Used in pp.c
+p      |SV*    |find_rundefsv2 |NN CV *cv|U32 seq
 #if defined(PERL_IN_PAD_C)
 sd     |PADOFFSET|pad_findlex  |NN const char *namepv|STRLEN namelen|U32 flags \
                                |NN const CV* cv|U32 seq|int warn \
diff --git a/embed.h b/embed.h
index c20e2b4..a4602af 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define dump_packsubs_perl(a,b)        Perl_dump_packsubs_perl(aTHX_ a,b)
 #define dump_sub_perl(a,b)     Perl_dump_sub_perl(aTHX_ a,b)
 #define finalize_optree(a)     Perl_finalize_optree(aTHX_ a)
+#define find_rundefsv2(a,b)    Perl_find_rundefsv2(aTHX_ a,b)
 #define find_script(a,b,c,d)   Perl_find_script(aTHX_ a,b,c,d)
 #define free_tied_hv_pool()    Perl_free_tied_hv_pool(aTHX)
 #define get_hash_seed()                Perl_get_hash_seed(aTHX)
diff --git a/pad.c b/pad.c
index 4036ddf..e7522eb 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -994,6 +994,24 @@ Perl_find_rundefsv(pTHX)
     return PAD_SVl(po);
 }
 
+SV *
+Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
+{
+    SV *namesv;
+    int flags;
+    PADOFFSET po;
+
+    PERL_ARGS_ASSERT_FIND_RUNDEFSV2;
+
+    po = pad_findlex("$_", 2, 0, cv, seq, 1,
+           NULL, &namesv, &flags);
+
+    if (po == NOT_IN_PAD || SvPAD_OUR(namesv))
+       return DEFSV;
+
+    return AvARRAY((PAD*) (AvARRAY(CvPADLIST(cv))[CvDEPTH(cv)]))[po];
+}
+
 /*
 =for apidoc m|PADOFFSET|pad_findlex|const char *namepv|STRLEN namelen|U32 flags|const CV* cv|U32 seq|int warn|SV** out_capture|SV** out_name_sv|int *out_flags
 
diff --git a/proto.h b/proto.h
index 73a322d..ea83f25 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -975,6 +975,11 @@ PERL_CALLCONV CV*  Perl_find_runcv(pTHX_ U32 *db_seqp)
                        __attribute__warn_unused_result__;
 
 PERL_CALLCONV SV*      Perl_find_rundefsv(pTHX);
+PERL_CALLCONV SV*      Perl_find_rundefsv2(pTHX_ CV *cv, U32 seq)
+                       __attribute__nonnull__(pTHX_1);
+#define PERL_ARGS_ASSERT_FIND_RUNDEFSV2        \
+       assert(cv)
+
 PERL_CALLCONV PADOFFSET        Perl_find_rundefsvoffset(pTHX)
                        __attribute__deprecated__;