Added a new kind of magic, poison, so @_ is deadly
authorPeter Martini <PeterCMartini@GMail.com>
Fri, 28 Sep 2012 03:51:47 +0000 (23:51 -0400)
committerPeter Martini <PeterCMartini@GMail.com>
Wed, 17 Oct 2012 20:36:12 +0000 (16:36 -0400)
inside of a sub declared with a signature

embed.fnc
embed.h
mg.c
mg_names.c
mg_raw.h
mg_vtable.h
pad.c
pod/perlguts.pod
pp_ctl.c
proto.h
regen/mg_vtable.pl

index 029eb93..31ab0c3 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -745,6 +745,7 @@ p   |int    |magic_gettaint |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_getuvar  |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_getvec   |NN SV* sv|NN MAGIC* mg
 p      |int    |magic_nextpack |NN SV *sv|NN MAGIC *mg|NN SV *key
+p      |int    |magic_poison   |NN SV *sv|NN MAGIC *mg
 p      |U32    |magic_regdata_cnt|NN SV* sv|NN MAGIC* mg
 p      |int    |magic_regdatum_get|NN SV* sv|NN MAGIC* mg
 pr     |int    |magic_regdatum_set|NN SV* sv|NN MAGIC* mg
diff --git a/embed.h b/embed.h
index deb04f8..7f91e44 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define magic_getvec(a,b)      Perl_magic_getvec(aTHX_ a,b)
 #define magic_killbackrefs(a,b)        Perl_magic_killbackrefs(aTHX_ a,b)
 #define magic_nextpack(a,b,c)  Perl_magic_nextpack(aTHX_ a,b,c)
+#define magic_poison(a,b)      Perl_magic_poison(aTHX_ a,b)
 #define magic_regdata_cnt(a,b) Perl_magic_regdata_cnt(aTHX_ a,b)
 #define magic_regdatum_get(a,b)        Perl_magic_regdatum_get(aTHX_ a,b)
 #define magic_regdatum_set(a,b)        Perl_magic_regdatum_set(aTHX_ a,b)
diff --git a/mg.c b/mg.c
index 2f8c81c..98c9262 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -3357,6 +3357,16 @@ Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
     return 1;
 }
 
+int
+Perl_magic_poison(pTHX_ SV *sv, MAGIC *mg)
+{
+    PERL_ARGS_ASSERT_MAGIC_POISON;
+    PERL_UNUSED_ARG(sv);
+    PERL_UNUSED_ARG(mg);
+    Perl_croak(aTHX_ "Cannot use @_ in a sub with a signature\n");
+    return 0;
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
index 73dc3f9..78beb55 100644 (file)
@@ -47,6 +47,7 @@
        { PERL_MAGIC_substr,         "substr(x)" },
        { PERL_MAGIC_defelem,        "defelem(y)" },
        { PERL_MAGIC_checkcall,      "checkcall(])" },
+       { PERL_MAGIC_poison,         "poison(_)" },
        { PERL_MAGIC_ext,            "ext(~)" },
 
 /* ex: set ro: */
index 487e209..ac6d31a 100644 (file)
--- a/mg_raw.h
+++ b/mg_raw.h
@@ -82,6 +82,8 @@
       "/* defelem 'y' Shadow \"foreach\" iterator variable / smart parameter vivification */" },
     { ']', "want_vtbl_checkcall | PERL_MAGIC_VALUE_MAGIC",
       "/* checkcall ']' inlining/mutation of call to this CV */" },
+    { '_', "want_vtbl_poison | PERL_MAGIC_VALUE_MAGIC",
+      "/* poison '_' Make any access to @_ croak */" },
     { '~', "magic_vtable_max",
       "/* ext '~' Available for use by extensions */" },
 
index 316c555..488145a 100644 (file)
@@ -55,6 +55,7 @@
 #define PERL_MAGIC_defelem        'y' /* Shadow "foreach" iterator variable /
                                          smart parameter vivification */
 #define PERL_MAGIC_checkcall      ']' /* inlining/mutation of call to this CV */
+#define PERL_MAGIC_poison         '_' /* Make any access to @_ croak */
 #define PERL_MAGIC_ext            '~' /* Available for use by extensions */
 
 enum {         /* pass one of these to get_vtbl */
@@ -76,6 +77,7 @@ enum {                /* pass one of these to get_vtbl */
     want_vtbl_ovrld,
     want_vtbl_pack,
     want_vtbl_packelem,
+    want_vtbl_poison,
     want_vtbl_pos,
     want_vtbl_regdata,
     want_vtbl_regdatum,
@@ -110,6 +112,7 @@ EXTCONST char *PL_magic_vtable_names[magic_vtable_max] = {
     "ovrld",
     "pack",
     "packelem",
+    "poison",
     "pos",
     "regdata",
     "regdatum",
@@ -167,6 +170,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max] = {
   { 0, 0, 0, 0, Perl_magic_freeovrld, 0, 0, 0 },
   { 0, 0, Perl_magic_sizepack, Perl_magic_wipepack, 0, 0, 0, 0 },
   { Perl_magic_getpack, Perl_magic_setpack, 0, Perl_magic_clearpack, 0, 0, 0, 0 },
+  { Perl_magic_poison, Perl_magic_poison, Perl_magic_poison, Perl_magic_poison, 0, 0, 0, 0 },
   { Perl_magic_getpos, Perl_magic_setpos, 0, 0, 0, 0, 0, 0 },
   { 0, 0, Perl_magic_regdata_cnt, 0, 0, 0, 0, 0 },
   { Perl_magic_regdatum_get, Perl_magic_regdatum_set, 0, 0, 0, 0, 0, 0 },
@@ -210,6 +214,7 @@ EXT_MGVTBL PL_magic_vtables[magic_vtable_max];
 #define PL_vtbl_ovrld PL_magic_vtables[want_vtbl_ovrld]
 #define PL_vtbl_pack PL_magic_vtables[want_vtbl_pack]
 #define PL_vtbl_packelem PL_magic_vtables[want_vtbl_packelem]
+#define PL_vtbl_poison PL_magic_vtables[want_vtbl_poison]
 #define PL_vtbl_pos PL_magic_vtables[want_vtbl_pos]
 #define PL_vtbl_regdata PL_magic_vtables[want_vtbl_regdata]
 #define PL_vtbl_regdatum PL_magic_vtables[want_vtbl_regdatum]
diff --git a/pad.c b/pad.c
index 1c04818..76512b3 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1763,6 +1763,10 @@ Perl_pad_tidy(pTHX_ padtidy_type type)
     else if (type == padtidy_SUB) {
        /* XXX DAPM this same bit of code keeps appearing !!! Rationalise? */
        AV * const av = newAV();                        /* Will be @_ */
+       /* This bit ought to go in scan_named_proto, if it weren't for the av being trashed */
+       if (PadlistNAMECNT(CvPADLIST(PL_compcv))) {
+           sv_magic((SV *)av, NULL, PERL_MAGIC_poison, NULL, 0);
+       }
        av_store(PL_comppad, 0, MUTABLE_SV(av));
        AvREIFY_only(av);
     }
index d1e179a..a992bf2 100644 (file)
@@ -1111,6 +1111,7 @@ will be lost.
                                              vivification
  ]  PERL_MAGIC_checkcall      vtbl_checkcall inlining/mutation of call
                                              to this CV
+ _  PERL_MAGIC_poison         vtbl_poison    Make any access to @_ croak
  ~  PERL_MAGIC_ext            (none)         Available for use by
                                              extensions
 
index 6e5c9e7..5c94d40 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1385,7 +1385,8 @@ bool
 Perl_is_sub_with_sig(pTHX)
 {
     dVAR;
-    const CV * const cv = CvEVAL(PL_compcv) ? CvOUTSIDE(PL_compcv) : PL_compcv;
+    const CV * const cv = (CvEVAL(PL_compcv) && CvOUTSIDE(PL_compcv)) ?
+       CvOUTSIDE(PL_compcv) : PL_compcv;
 
     if (PadlistNAMECNT(CvPADLIST(cv)))
        return TRUE;
diff --git a/proto.h b/proto.h
index 209f8d8..fda5aaa 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -2169,6 +2169,12 @@ PERL_CALLCONV int        Perl_magic_nextpack(pTHX_ SV *sv, MAGIC *mg, SV *key)
 #define PERL_ARGS_ASSERT_MAGIC_NEXTPACK        \
        assert(sv); assert(mg); assert(key)
 
+PERL_CALLCONV int      Perl_magic_poison(pTHX_ SV *sv, MAGIC *mg)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
+#define PERL_ARGS_ASSERT_MAGIC_POISON  \
+       assert(sv); assert(mg)
+
 PERL_CALLCONV U32      Perl_magic_regdata_cnt(pTHX_ SV* sv, MAGIC* mg)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2);
index e095614..f1f2560 100644 (file)
@@ -108,6 +108,8 @@ my %mg =
      ext => { char => '~', desc => 'Available for use by extensions' },
      checkcall => { char => ']', value_magic => 1, vtable => 'checkcall',
                    desc => 'inlining/mutation of call to this CV'},
+     poison => { char => '_', value_magic => 1, vtable => 'poison',
+                   desc => 'Make any access to @_ croak' },
 );
 
 # These have a subtly different "namespace" from the magic types.
@@ -144,6 +146,7 @@ my %sig =
      'hintselem' => {set => 'sethint', clear => 'clearhint'},
      'hints' => {clear => 'clearhints'},
      'checkcall' => {copy => 'copycallchecker'},
+     'poison' => {get => 'poison', set => 'poison', len => 'poison', clear => 'poison'},
 );
 
 my ($vt, $raw, $names) = map {