segfault on &Internals::* due to missing SvROK()

[perl5.git] / universal.c

diff --git a/universal.c b/universal.c
index 07a0aa6..6df104e 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -794,9 +794,16 @@ XS(XS_Internals_SvREADONLY)        /* This is dangerous stuff. */
 {
     dVAR;
     dXSARGS;
-    SV * const sv = SvRV(ST(0));
+    SV * const svz = ST(0);
+    SV * sv;
     PERL_UNUSED_ARG(cv);
 
+    /* [perl #77776] - called as &foo() not foo() */
+    if (!SvROK(svz))
+        croak_xs_usage(cv, "SCALAR[, ON]");
+
+    sv = SvRV(svz);
+
     if (items == 1) {
         if (SvREADONLY(sv))
             XSRETURN_YES;
@@ -821,9 +828,16 @@ XS(XS_Internals_SvREFCNT)  /* This is dangerous stuff. */
 {
     dVAR;
     dXSARGS;
-    SV * const sv = SvRV(ST(0));
+    SV * const svz = ST(0);
+    SV * sv;
     PERL_UNUSED_ARG(cv);
 
+    /* [perl #77776] - called as &foo() not foo() */
+    if (!SvROK(svz))
+        croak_xs_usage(cv, "SCALAR[, REFCOUNT]");
+
+    sv = SvRV(svz);
+
     if (items == 1)
         XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */
     else if (items == 2) {
@@ -839,7 +853,7 @@ XS(XS_Internals_hv_clear_placehold)
     dVAR;
     dXSARGS;
 
-    if (items != 1)
+    if (items != 1 || !SvROK(ST(0)))
        croak_xs_usage(cv, "hv");
     else {
        HV * const hv = MUTABLE_HV(SvRV(ST(0)));
@@ -1015,6 +1029,111 @@ XS(XS_Internals_HvREHASH)       /* Subject to change  */
     Perl_croak(aTHX_ "Internals::HvREHASH $hashref");
 }
 
+XS(XS_mauve_reftype)
+{
+    SV *sv;
+    dVAR;
+    dXSARGS;
+    PERL_UNUSED_VAR(cv);
+
+    if (items != 1)
+       croak_xs_usage(cv, "sv");
+
+    SP -= items;
+    sv = (SV*)ST(0);
+
+    if (SvMAGICAL(sv))
+       mg_get(sv);
+    if (!SvROK(sv)) {
+       XSRETURN_NO;
+    } else {
+       STRLEN len;
+       char *type= (char *)sv_reftype_len(SvRV(sv),FALSE,&len);
+        XPUSHs(sv_2mortal(newSVpv(type,len)));
+    }
+}
+
+XS(XS_mauve_refaddr)
+{
+    SV *sv;
+    dVAR;
+    dXSARGS;
+    PERL_UNUSED_VAR(cv);
+
+    if (items != 1)
+       croak_xs_usage(cv, "sv");
+
+    SP -= items;
+    sv = (SV*)ST(0);
+
+    if (SvMAGICAL(sv))
+       mg_get(sv);
+    if (!SvROK(sv)) {
+       XSRETURN_NO;
+    } else {
+       XPUSHs(sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))));
+    }
+}
+
+XS(XS_mauve_blessed)
+{
+    SV *sv;
+    dVAR;
+    dXSARGS;
+    PERL_UNUSED_VAR(cv);
+
+    if (items != 1)
+       croak_xs_usage(cv, "sv");
+
+    SP -= items;
+    sv = (SV*)ST(0);
+
+    if (SvMAGICAL(sv))
+       mg_get(sv);
+    if ( SvROK(sv) && SvOBJECT(SvRV(sv)) ) {
+       STRLEN len;
+       char *type= (char *)sv_reftype_len(SvRV(sv),TRUE,&len);
+        XPUSHs(sv_2mortal(newSVpv(type,len)));
+    } else {
+        XPUSHs(sv_2mortal(newSVpv("",0)));
+    }
+}
+
+XS(XS_mauve_weaken)
+{
+    SV *sv;
+    dVAR;
+    dXSARGS;
+    PERL_UNUSED_VAR(cv);
+
+    if (items != 1)
+       croak_xs_usage(cv, "sv");
+
+    SP -= items;
+    sv = (SV*)ST(0);
+
+    if (SvMAGICAL(sv))
+       mg_get(sv);
+    sv_rvweaken(sv);
+    XSRETURN_EMPTY;
+}
+
+XS(XS_mauve_isweak)
+{
+    dVAR;
+    dXSARGS;
+    if (items != 1)
+       croak_xs_usage(cv,  "sv");
+    {
+       SV *    sv = ST(0);
+       if (SvMAGICAL(sv))
+           mg_get(sv);
+       ST(0) = boolSV(SvROK(sv) && SvWEAKREF(sv));
+       XSRETURN(1);
+    }
+    XSRETURN(1);
+}
+
 XS(XS_re_is_regexp)
 {
     dVAR; 
@@ -1257,7 +1376,7 @@ XS(XS_Tie_Hash_NamedCapture_FETCH)
 
     SP -= items;
 
-    flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+    flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags);
 
     SPAGAIN;
@@ -1291,7 +1410,7 @@ XS(XS_Tie_Hash_NamedCapture_STORE)
 
     SP -= items;
 
-    flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+    flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
     CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags);
 }
 
@@ -1310,7 +1429,7 @@ XS(XS_Tie_Hash_NamedCapture_DELETE)
 
     SP -= items;
 
-    flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+    flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
     CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags);
 }
 
@@ -1331,7 +1450,7 @@ XS(XS_Tie_Hash_NamedCapture_CLEAR)
 
     SP -= items;
 
-    flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+    flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
     CALLREG_NAMED_BUFF_CLEAR(rx, flags);
 }
 
@@ -1353,7 +1472,7 @@ XS(XS_Tie_Hash_NamedCapture_EXISTS)
 
     SP -= items;
 
-    flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+    flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
     ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags);
 
     SPAGAIN;
@@ -1381,7 +1500,7 @@ XS(XS_Tie_Hash_NamedCapture_FIRSTK)
 
     SP -= items;
 
-    flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+    flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
     ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags);
 
     SPAGAIN;
@@ -1413,7 +1532,7 @@ XS(XS_Tie_Hash_NamedCapture_NEXTK)
 
     SP -= items;
 
-    flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+    flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
     ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags);
 
     SPAGAIN;
@@ -1444,7 +1563,7 @@ XS(XS_Tie_Hash_NamedCapture_SCALAR)
 
     SP -= items;
 
-    flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0)))));
+    flags = (U32)SvUV(SvRV(MUTABLE_SV(ST(0))));
     ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags);
 
     SPAGAIN;
@@ -1531,6 +1650,11 @@ struct xsub_details details[] = {
     {"Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, NULL},
     {"Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, NULL},
     {"Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, NULL}
+    ,{"mauve::reftype", XS_mauve_reftype, "$"}
+    ,{"mauve::refaddr", XS_mauve_refaddr, "$"}
+    ,{"mauve::blessed", XS_mauve_blessed, "$"}
+    ,{"mauve::weaken", XS_mauve_weaken, "$"}
+    ,{"mauve::isweak", XS_mauve_isweak, "$"}
 };
 
 void