From: Vincent Pit <vince@profvince.com>
Date: Sun, 1 Mar 2009 18:06:18 +0000 (+0100)
Subject: Store a placeholder in the wizards set for every manually generated signature.
X-Git-Tag: v0.33~22
X-Git-Url: http://git.vpit.fr/?p=perl%2Fmodules%2FVariable-Magic.git;a=commitdiff_plain;h=ef0ca84c466fb43ed99555a0a662135a9913b5fe

Store a placeholder in the wizards set for every manually generated signature.

Before that, it was possible to generate the same signature twice before actually defining the wizards.

As a result of this, casting from an obsolete signature now croaks.
---

diff --git a/Magic.xs b/Magic.xs
index e9d9deb..14a33f4 100644
--- a/Magic.xs
+++ b/Magic.xs
@@ -1088,7 +1088,6 @@ STATIC U16 vmg_sv2sig(pTHX_ SV *sv) {
 
 STATIC U16 vmg_wizard_sig(pTHX_ SV *wiz) {
 #define vmg_wizard_sig(W) vmg_wizard_sig(aTHX_ (W))
- char buf[8];
  U16 sig;
 
  if (SvROK(wiz)) {
@@ -1101,7 +1100,9 @@ STATIC U16 vmg_wizard_sig(pTHX_ SV *wiz) {
 
  {
   dMY_CXT;
-  if (!hv_exists(MY_CXT.wizards, buf, sprintf(buf, "%u", sig)))
+  char buf[8];
+  SV **old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0);
+  if (!(old && SV2MGWIZ(*old)))
    croak(vmg_invalid_wiz);
  }
 
@@ -1110,8 +1111,6 @@ STATIC U16 vmg_wizard_sig(pTHX_ SV *wiz) {
 
 STATIC SV *vmg_wizard_wiz(pTHX_ SV *wiz) {
 #define vmg_wizard_wiz(W) vmg_wizard_wiz(aTHX_ (W))
- char buf[8];
- SV **old;
  U16 sig;
 
  if (SvROK(wiz)) {
@@ -1129,8 +1128,12 @@ STATIC SV *vmg_wizard_wiz(pTHX_ SV *wiz) {
 
  {
   dMY_CXT;
-  return (old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0))
-          ? *old : NULL;
+  char buf[8];
+  SV **old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0);
+  if (!(old && SV2MGWIZ(*old)))
+   croak(vmg_invalid_wiz);
+
+  return *old;
  }
 }
 
@@ -1255,13 +1258,16 @@ CODE:
    STRLEN len;
    char *sig = HePV(key, len);
    SV *sv;
-   const MGWIZ *w;
-   MAGIC *mg;
-   w  = SV2MGWIZ(HeVAL(key));
-   w  = vmg_wizard_clone(w);
-   sv = MGWIZ2SV(w);
-   mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);
-   mg->mg_private = SIG_WZO;
+   const MGWIZ *w = SV2MGWIZ(HeVAL(key));
+   if (w) {
+    MAGIC *mg;
+    w  = vmg_wizard_clone(w);
+    sv = MGWIZ2SV(w);
+    mg = sv_magicext(sv, NULL, PERL_MAGIC_ext, &vmg_wizard_vtbl, NULL, 0);
+    mg->mg_private = SIG_WZO;
+   } else {
+    sv = MGWIZ2SV(NULL);
+   }
    SvREADONLY_on(sv);
    if (!hv_store(hv, sig, len, sv, HeHASH(key))) croak("%s during CLONE", vmg_globstorefail);
   }
@@ -1315,7 +1321,8 @@ CODE:
  if (SvOK(svsig)) {
   SV **old;
   sig = vmg_sv2sig(svsig);
-  if ((old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0))) {
+  old = hv_fetch(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), 0);
+  if (old && SV2MGWIZ(*old)) {
    ST(0) = sv_2mortal(newRV_inc(*old));
    XSRETURN(1);
   }
@@ -1378,8 +1385,14 @@ OUTPUT:
 
 SV *gensig()
 PROTOTYPE:
+PREINIT:
+ U16 sig;
+ char buf[8];
 CODE:
- RETVAL = newSVuv(vmg_gensig());
+ dMY_CXT;
+ sig = vmg_gensig();
+ if (!hv_store(MY_CXT.wizards, buf, sprintf(buf, "%u", sig), MGWIZ2SV(NULL), 0)) croak(vmg_globstorefail);
+ RETVAL = newSVuv(sig);
 OUTPUT:
  RETVAL
 
@@ -1398,8 +1411,6 @@ PREINIT:
  SV *ret;
 CODE:
  wiz = vmg_wizard_wiz(wiz);
- if (!wiz)
-  XSRETURN_UNDEF;
  if (items > 2) {
   I32 i;
   args = newAV();
diff --git a/t/10-simple.t b/t/10-simple.t
index 0b17fde..1617fdc 100644
--- a/t/10-simple.t
+++ b/t/10-simple.t
@@ -3,10 +3,12 @@
 use strict;
 use warnings;
 
-use Test::More tests => 46;
+use Test::More tests => 48;
 
 use Variable::Magic qw/wizard gensig getsig cast dispell MGf_COPY MGf_DUP MGf_LOCAL VMG_UVAR/;
 
+my $inv_wiz_obj = qr/Invalid\s+wizard\s+object\s+at\s+\Q$0\E/;
+
 my $args = 8;
 ++$args if MGf_COPY;
 ++$args if MGf_DUP;
@@ -25,14 +27,18 @@ for (0 .. 3) {
 
 my $sig = gensig;
 
+my $a = 1;
+my $res = eval { cast $a, $sig };
+like($@, $inv_wiz_obj, 'cast from wrong sig croaks');
+is($res, undef,        'cast from wrong sig doesn\'t return anything');
+
 my $wiz = eval { wizard sig => $sig };
 is($@, '',             'wizard doesn\'t croak');
 ok(defined $wiz,       'wizard is defined');
 is(ref $wiz, 'SCALAR', 'wizard is a scalar ref');
 is($sig, getsig $wiz,  'wizard signature is correct');
 
-my $a = 1;
-my $res = eval { cast $a, $wiz };
+$res = eval { cast $a, $wiz };
 is($@, '', 'cast doesn\'t croak');
 ok($res,   'cast is valid');
 
@@ -45,12 +51,12 @@ is($@, '', 're-cast doesn\'t croak');
 ok($res,   're-cast is valid');
 
 $res = eval { dispell $a, gensig };
-like($@, qr/Invalid\s+wizard\s+object\s+at\s+\Q$0\E/, 're-dispell from wrong sig croaks');
-is($res, undef, 're-dispell from wrong sig doesn\'t return anything');
+like($@, $inv_wiz_obj, 're-dispell from wrong sig croaks');
+is($res, undef,        're-dispell from wrong sig doesn\'t return anything');
 
 $res = eval { dispell $a, undef };
-like($@, qr/Invalid\s+wizard\s+object\s+at\s+\Q$0\E/, 're-dispell from undef croaks');
-is($res, undef, 're-dispell from undef doesn\'t return anything');
+like($@, $inv_wiz_obj, 're-dispell from undef croaks');
+is($res, undef,        're-dispell from undef doesn\'t return anything');
 
 $res = eval { dispell $a, $sig };
 is($@, '', 're-dispell from good sig doesn\'t croak');
@@ -68,9 +74,9 @@ $sig = gensig;
 }
 my $c = 3;
 $res = eval { cast $c, $sig };
-is($@, '',      'cast from obsolete signature doesn\'t croak');
-is($res, undef, 'cast from obsolete signature returns undef');
+like($@, $inv_wiz_obj, 'cast from obsolete signature croaks');
+is($res, undef,        'cast from obsolete signature returns undef');
 
 $res = eval { cast $c, undef };
-like($@, qr/Invalid\s+wizard\s+object\s+at\s+\Q$0\E/, 'cast from undef croaks');
-is($res, undef, 'cast from undef doesn\'t return anything');
+like($@, $inv_wiz_obj, 'cast from undef croaks');
+is($res, undef,        'cast from undef doesn\'t return anything');