$^E is not Win32::GetLastError under Cygwin

[p5sagit/p5-mst-13.2.git] / mro.c

diff --git a/mro.c b/mro.c
index 01461b1..4f850f4 100644 (file)
--- a/mro.c
+++ b/mro.c
@@ -21,6 +21,7 @@ These functions are related to the method resolution order of perl classes
 */
 
 #include "EXTERN.h"
+#define PERL_IN_MRO_C
 #include "perl.h"
 
 struct mro_meta*
@@ -83,8 +84,8 @@ invalidated).
 
 =cut
 */
-AV*
-Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
+static AV*
+S_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
 {
     AV* retval;
     GV** gvp;
@@ -113,7 +114,7 @@ Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
 
     /* not in cache, make a new one */
 
-    retval = newAV();
+    retval = (AV*)sv_2mortal((SV *)newAV());
     av_push(retval, newSVpv(stashname, 0)); /* add ourselves at the top */
 
     /* fetch our @ISA */
@@ -146,7 +147,10 @@ Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
             }
             else {
                 /* otherwise, recurse into ourselves for the MRO
-                   of this @ISA member, and append their MRO to ours */
+                   of this @ISA member, and append their MRO to ours.
+                  The recursive call could throw an exception, which
+                  has memory management implications here, hence the use of
+                  the mortal.  */
                const AV *const subrv
                    = mro_get_linear_isa_dfs(basestash, level + 1);
 
@@ -156,13 +160,19 @@ Perl_mro_get_linear_isa_dfs(pTHX_ HV *stash, I32 level)
            while(subrv_items--) {
                SV *const subsv = *subrv_p++;
                if(!hv_exists_ent(stored, subsv, 0)) {
-                   hv_store_ent(stored, subsv, &PL_sv_undef, 0);
+                   (void)hv_store_ent(stored, subsv, &PL_sv_undef, 0);
                    av_push(retval, newSVsv(subsv));
                }
             }
         }
     }
 
+    /* now that we're past the exception dangers, grab our own reference to
+       the AV we're about to use for the result. The reference owned by the
+       mortals' stack will be released soon, so everything will balance.  */
+    SvREFCNT_inc_simple_void_NN(retval);
+    SvTEMP_off(retval);
+
     /* we don't want anyone modifying the cache entry but us,
        and we do so by replacing it completely */
     SvREADONLY_on(retval);
@@ -188,8 +198,8 @@ invalidated).
 =cut
 */
 
-AV*
-Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
+static AV*
+S_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
 {
     AV* retval;
     GV** gvp;
@@ -281,7 +291,7 @@ Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level)
                     SV* const seqitem = *seq_ptr++;
                     HE* const he = hv_fetch_ent(tails, seqitem, 0, 0);
                     if(!he) {
-                        hv_store_ent(tails, seqitem, newSViv(1), 0);
+                        (void)hv_store_ent(tails, seqitem, newSViv(1), 0);
                     }
                     else {
                         SV* const val = HeVAL(he);
@@ -448,10 +458,8 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
     bool is_universal;
     struct mro_meta * meta;
 
-    const char * const stashname = stash ? HvNAME_get(stash) : NULL;
-    const STRLEN stashname_len = stash ? HvNAMELEN_get(stash) : 0;
-
-    if(!stash) return;
+    const char * const stashname = HvNAME_get(stash);
+    const STRLEN stashname_len = HvNAMELEN_get(stash);
 
     if(!stashname)
         Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
@@ -533,14 +541,14 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash)
           save time by not making two calls to the common HV code for the
           case where it doesn't exist.  */
           
-       hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
+       (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
 
         if(isarev) {
             hv_iterinit(isarev);
             while((iter = hv_iternext(isarev))) {
                 I32 revkeylen;
                 char* const revkey = hv_iterkey(iter, &revkeylen);
-               hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
+               (void)hv_store(mroisarev, revkey, revkeylen, &PL_sv_yes, 0);
             }
         }
     }
@@ -771,10 +779,8 @@ XS(XS_mro_get_isarev)
     dVAR;
     dXSARGS;
     SV* classname;
-    SV** svp;
+    HE* he;
     HV* isarev;
-    char* classname_pv;
-    STRLEN classname_len;
     AV* ret_array;
 
     PERL_UNUSED_ARG(cv);
@@ -787,10 +793,8 @@ XS(XS_mro_get_isarev)
     SP -= items;
 
     
-    classname_pv = SvPV_nolen(classname);
-    classname_len = strlen(classname_pv);
-    svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
-    isarev = svp ? (HV*)*svp : NULL;
+    he = hv_fetch_ent(PL_isarev, classname, 0, 0);
+    isarev = he ? (HV*)HeVAL(he) : NULL;
 
     ret_array = newAV();
     if(isarev) {
@@ -813,7 +817,7 @@ XS(XS_mro_is_universal)
     HV* isarev;
     char* classname_pv;
     STRLEN classname_len;
-    SV** svp;
+    HE* he;
 
     PERL_UNUSED_ARG(cv);
 
@@ -825,8 +829,8 @@ XS(XS_mro_is_universal)
     classname_pv = SvPV_nolen(classname);
     classname_len = strlen(classname_pv);
 
-    svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
-    isarev = svp ? (HV*)*svp : NULL;
+    he = hv_fetch_ent(PL_isarev, classname, 0, 0);
+    isarev = he ? (HV*)HeVAL(he) : NULL;
 
     if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
         || (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
@@ -1079,14 +1083,14 @@ XS(XS_mro_nextcan)
                valid for the child */
             if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) {
                 SvREFCNT_inc_simple_void_NN((SV*)cand_cv);
-                hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
+                (void)hv_store_ent(nmcache, newSVsv(sv), (SV*)cand_cv, 0);
                 XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv)));
                 XSRETURN(1);
             }
         }
     }
 
-    hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
+    (void)hv_store_ent(nmcache, newSVsv(sv), &PL_sv_undef, 0);
     if(throw_nomethod)
         Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname);
     XSRETURN_EMPTY;