From: gfx <gfuji@cpan.org>
Date: Sat, 19 Jun 2010 06:31:26 +0000 (+0900)
Subject: Fix the Perl_call_sv() problem again, and tests for it
X-Git-Tag: 0.61~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=f0e1969bc2752f79154513a6df9b46571ee3e8ba;hp=37008311d2f225f62af2d3f3f1603740bcbdb81c;p=gitmo%2FMouse.git

Fix the Perl_call_sv() problem again, and tests for it
---

diff --git a/t/900_mouse_bugs/006_RT69939.t b/t/900_mouse_bugs/006_RT69939.t
index c211a2c..e2cb03e 100644
--- a/t/900_mouse_bugs/006_RT69939.t
+++ b/t/900_mouse_bugs/006_RT69939.t
@@ -34,13 +34,36 @@ sub BUILD {
 
 package main;
 
-use Test::More tests => 3;
+use Test::More tests => 3 * 3;
 
 $@ = '(ERRSV)';
 
-my $foo = Foo->new;
-isa_ok $foo, 'Foo';
-is $foo->bar, 42;
-$foo->bar(100);
-is $foo->bar, 100;
-note("\$@=$@");
+note 'do {}';
+do {
+    my $foo = Foo->new;
+    isa_ok $foo, 'Foo';
+    is $foo->bar, 42;
+    $foo->bar(100);
+    is $foo->bar, 100;
+    note("\$@=$@");
+};
+
+note 'eval {}';
+eval {
+    my $foo = Foo->new;
+    isa_ok $foo, 'Foo';
+    is $foo->bar, 42;
+    $foo->bar(100);
+    is $foo->bar, 100;
+    note("\$@=$@");
+};
+
+note 'eval ""';
+eval q{
+    my $foo = Foo->new;
+    isa_ok $foo, 'Foo';
+    is $foo->bar, 42;
+    $foo->bar(100);
+    is $foo->bar, 100;
+    note("\$@=$@");
+};
diff --git a/xs-src/MouseUtil.xs b/xs-src/MouseUtil.xs
index 94000f5..ae5fb39 100644
--- a/xs-src/MouseUtil.xs
+++ b/xs-src/MouseUtil.xs
@@ -120,55 +120,28 @@ mouse_throw_error(SV* const metaobject, SV* const data /* not used */, const cha
     }
 }
 
-static I32
-S_dopoptosub(pTHX_ I32 const startingblock)
-{
-    const PERL_CONTEXT* const cxstk = cxstack;
-    I32 i;
-    for (i = startingblock; i >= 0; i--) {
-        const PERL_CONTEXT* const cx = &cxstk[i];
-
-        switch (CxTYPE(cx)) {
-        case CXt_EVAL:
-        case CXt_SUB:
-        case CXt_FORMAT:
-            return i;
-        }
-    }
-    return i;
-}
-
 /* workaround Perl-RT #69939 */
 I32
 mouse_call_sv_safe(pTHX_ SV* const sv, I32 const flags) {
-    const PERL_CONTEXT* const cx = &cxstack[S_dopoptosub(aTHX_ cxstack_ix)];
-    assert( (flags & G_EVAL) == 0 );
-
-    //warn("cx_type=0x%02x PL_eval=0x%02x (%"SVf")", (unsigned)cx->cx_type, (unsigned)PL_in_eval, sv);
-    if(cx->cx_type & CXp_TRYBLOCK) {
-        return Perl_call_sv(aTHX_ sv, flags);
-    }
-    else {
-        I32 count;
-        ENTER;
-        /* Don't do SAVETMPS */
+    I32 count;
+    ENTER;
+    /* Don't do SAVETMPS */
 
-        SAVESPTR(ERRSV);
-        ERRSV = sv_newmortal();
+    SAVESPTR(ERRSV);
+    ERRSV = sv_newmortal();
 
-        count = Perl_call_sv(aTHX_ sv, flags | G_EVAL);
-
-        if(sv_true(ERRSV)){
-            SV* const err = sv_mortalcopy(ERRSV);
-            LEAVE;
-            sv_setsv(ERRSV, err);
-            croak(NULL); /* rethrow */
-        }
+    count = Perl_call_sv(aTHX_ sv, flags | G_EVAL);
 
+    if(sv_true(ERRSV)){
+        SV* const err = sv_mortalcopy(ERRSV);
         LEAVE;
-
-        return count;
+        sv_setsv(ERRSV, err);
+        croak(NULL); /* rethrow */
     }
+
+    LEAVE;
+
+    return count;
 }
 
 void