Skip another file in the VERSION comparison program

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

diff --git a/universal.c b/universal.c
index c835286..19fb608 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -45,6 +45,8 @@ S_isa_lookup(pTHX_ HV *stash, const char * const name, const HV* const name_stas
     const char *hvname;
     I32 items;
 
+    PERL_ARGS_ASSERT_ISA_LOOKUP;
+
     /* A stash/class can go by many names (ie. User == main::User), so 
        we compare the stash itself just in case */
     if (name_stash && ((const HV *)stash == name_stash))
@@ -65,6 +67,7 @@ S_isa_lookup(pTHX_ HV *stash, const char * const name, const HV* const name_stas
        SV* const basename_sv = *svp++;
         HV* const basestash = gv_stashsv(basename_sv, 0);
        if (!basestash) {
+           /* We have no test coverage for this block, as of 2008/08.  */
            if (ckWARN(WARN_SYNTAX))
                Perl_warner(aTHX_ packWARN(WARN_SYNTAX),
                            "Can't locate package %"SVf" for the parents of %s",
@@ -91,11 +94,13 @@ normal Perl method.
 */
 
 bool
-Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
+Perl_sv_derived_from(pTHX_ SV *sv, const char *const name)
 {
     dVAR;
     HV *stash;
 
+    PERL_ARGS_ASSERT_SV_DERIVED_FROM;
+
     SvGETMAGIC(sv);
 
     if (SvROK(sv)) {
@@ -131,13 +136,15 @@ The SV can be a Perl object or the name of a Perl class.
 #include "XSUB.h"
 
 bool
-Perl_sv_does(pTHX_ SV *sv, const char *name)
+Perl_sv_does(pTHX_ SV *sv, const char *const name)
 {
     const char *classname;
     bool does_it;
     SV *methodname;
-
     dSP;
+
+    PERL_ARGS_ASSERT_SV_DOES;
+
     ENTER;
     SAVETMPS;
 
@@ -290,15 +297,50 @@ Perl_boot_core_UNIVERSAL(pTHX)
     newXS("Tie::Hash::NamedCapture::flags", XS_Tie_Hash_NamedCapture_flags, file);
 }
 
+/*
+=for apidoc croak_xs_usage
+
+A specialised variant of C<croak()> for emitting the usage message for xsubs
+
+    croak_xs_usage(cv, "eee_yow");
+
+works out the package name and subroutine name from C<cv>, and then calls
+C<croak()>. Hence if C<cv> is C<&ouch::awk>, it would call C<croak> as:
+
+    Perl_croak(aTHX_ "Usage %s::%s(%s)", "ouch" "awk", "eee_yow");
+
+=cut
+*/
+
+void
+Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params)
+{
+    const GV *const gv = CvGV(cv);
+
+    PERL_ARGS_ASSERT_CROAK_XS_USAGE;
+
+    if (gv) {
+       const char *const gvname = GvNAME(gv);
+       const HV *const stash = GvSTASH(gv);
+       const char *const hvname = stash ? HvNAME_get(stash) : NULL;
+
+       if (hvname)
+           Perl_croak(aTHX_ "Usage: %s::%s(%s)", hvname, gvname, params);
+       else
+           Perl_croak(aTHX_ "Usage: %s(%s)", gvname, params);
+    } else {
+       /* Pants. I don't think that it should be possible to get here. */
+       Perl_croak(aTHX_ "Usage: CODE(0x%"UVxf")(%s)", PTR2UV(cv), params);
+    }
+}
 
 XS(XS_UNIVERSAL_isa)
 {
     dVAR;
     dXSARGS;
-    PERL_UNUSED_ARG(cv);
 
     if (items != 2)
-       Perl_croak(aTHX_ "Usage: UNIVERSAL::isa(reference, kind)");
+       croak_xs_usage(cv, "reference, kind");
     else {
        SV * const sv = ST(0);
        const char *name;
@@ -324,10 +366,9 @@ XS(XS_UNIVERSAL_can)
     const char *name;
     SV   *rv;
     HV   *pkg = NULL;
-    PERL_UNUSED_ARG(cv);
 
     if (items != 2)
-       Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)");
+       croak_xs_usage(cv, "object-ref, method");
 
     sv = ST(0);
 
@@ -465,9 +506,8 @@ XS(XS_version_new)
 {
     dVAR;
     dXSARGS;
-    PERL_UNUSED_ARG(cv);
     if (items > 3)
-       Perl_croak(aTHX_ "Usage: version::new(class, version)");
+       croak_xs_usage(cv, "class, version");
     SP -= items;
     {
         SV *vs = ST(1);
@@ -501,9 +541,8 @@ XS(XS_version_stringify)
 {
      dVAR;
      dXSARGS;
-     PERL_UNUSED_ARG(cv);
      if (items < 1)
-         Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)");
+        croak_xs_usage(cv, "lobj, ...");
      SP -= items;
      {
          SV *  lobj;
@@ -525,9 +564,8 @@ XS(XS_version_numify)
 {
      dVAR;
      dXSARGS;
-     PERL_UNUSED_ARG(cv);
      if (items < 1)
-         Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)");
+        croak_xs_usage(cv, "lobj, ...");
      SP -= items;
      {
          SV *  lobj;
@@ -549,9 +587,8 @@ XS(XS_version_normal)
 {
      dVAR;
      dXSARGS;
-     PERL_UNUSED_ARG(cv);
      if (items < 1)
-         Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)");
+        croak_xs_usage(cv, "lobj, ...");
      SP -= items;
      {
          SV *  lobj;
@@ -573,9 +610,8 @@ XS(XS_version_vcmp)
 {
      dVAR;
      dXSARGS;
-     PERL_UNUSED_ARG(cv);
      if (items < 1)
-         Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)");
+        croak_xs_usage(cv, "lobj, ...");
      SP -= items;
      {
          SV *  lobj;
@@ -619,9 +655,8 @@ XS(XS_version_boolean)
 {
     dVAR;
     dXSARGS;
-    PERL_UNUSED_ARG(cv);
     if (items < 1)
-       Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)");
+       croak_xs_usage(cv, "lobj, ...");
     SP -= items;
     if (sv_derived_from(ST(0), "version")) {
        SV * const lobj = SvRV(ST(0));
@@ -638,9 +673,8 @@ XS(XS_version_noop)
 {
     dVAR;
     dXSARGS;
-    PERL_UNUSED_ARG(cv);
     if (items < 1)
-       Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)");
+       croak_xs_usage(cv, "lobj, ...");
     if (sv_derived_from(ST(0), "version"))
        Perl_croak(aTHX_ "operation not supported with version object");
     else
@@ -654,9 +688,8 @@ XS(XS_version_is_alpha)
 {
     dVAR;
     dXSARGS;
-    PERL_UNUSED_ARG(cv);
     if (items != 1)
-       Perl_croak(aTHX_ "Usage: version::is_alpha(lobj)");
+       croak_xs_usage(cv, "lobj");
     SP -= items;
     if (sv_derived_from(ST(0), "version")) {
        SV * const lobj = ST(0);
@@ -675,9 +708,8 @@ XS(XS_version_qv)
 {
     dVAR;
     dXSARGS;
-    PERL_UNUSED_ARG(cv);
     if (items != 1)
-       Perl_croak(aTHX_ "Usage: version::qv(ver)");
+       croak_xs_usage(cv, "ver");
     SP -= items;
     {
        SV *    ver = ST(0);
@@ -701,9 +733,8 @@ XS(XS_utf8_is_utf8)
 {
      dVAR;
      dXSARGS;
-     PERL_UNUSED_ARG(cv);
      if (items != 1)
-         Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)");
+        croak_xs_usage(cv, "sv");
      else {
        const SV * const sv = ST(0);
            if (SvUTF8(sv))
@@ -718,9 +749,8 @@ XS(XS_utf8_valid)
 {
      dVAR;
      dXSARGS;
-     PERL_UNUSED_ARG(cv);
      if (items != 1)
-         Perl_croak(aTHX_ "Usage: utf8::valid(sv)");
+        croak_xs_usage(cv, "sv");
     else {
        SV * const sv = ST(0);
        STRLEN len;
@@ -737,9 +767,8 @@ XS(XS_utf8_encode)
 {
     dVAR;
     dXSARGS;
-    PERL_UNUSED_ARG(cv);
     if (items != 1)
-       Perl_croak(aTHX_ "Usage: utf8::encode(sv)");
+       croak_xs_usage(cv, "sv");
     sv_utf8_encode(ST(0));
     XSRETURN_EMPTY;
 }
@@ -748,9 +777,8 @@ XS(XS_utf8_decode)
 {
     dVAR;
     dXSARGS;
-    PERL_UNUSED_ARG(cv);
     if (items != 1)
-       Perl_croak(aTHX_ "Usage: utf8::decode(sv)");
+       croak_xs_usage(cv, "sv");
     else {
        SV * const sv = ST(0);
        const bool RETVAL = sv_utf8_decode(sv);
@@ -764,9 +792,8 @@ XS(XS_utf8_upgrade)
 {
     dVAR;
     dXSARGS;
-    PERL_UNUSED_ARG(cv);
     if (items != 1)
-       Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)");
+       croak_xs_usage(cv, "sv");
     else {
        SV * const sv = ST(0);
        STRLEN  RETVAL;
@@ -782,9 +809,8 @@ XS(XS_utf8_downgrade)
 {
     dVAR;
     dXSARGS;
-    PERL_UNUSED_ARG(cv);
     if (items < 1 || items > 2)
-       Perl_croak(aTHX_ "Usage: utf8::downgrade(sv, failok=0)");
+       croak_xs_usage(cv, "sv, failok=0");
     else {
        SV * const sv = ST(0);
         const bool failok = (items < 2) ? 0 : (int)SvIV(ST(1));
@@ -801,10 +827,9 @@ XS(XS_utf8_native_to_unicode)
  dVAR;
  dXSARGS;
  const UV uv = SvUV(ST(0));
- PERL_UNUSED_ARG(cv);
 
  if (items > 1)
-     Perl_croak(aTHX_ "Usage: utf8::native_to_unicode(sv)");
+     croak_xs_usage(cv, "sv");
 
  ST(0) = sv_2mortal(newSViv(NATIVE_TO_UNI(uv)));
  XSRETURN(1);
@@ -815,10 +840,9 @@ XS(XS_utf8_unicode_to_native)
  dVAR;
  dXSARGS;
  const UV uv = SvUV(ST(0));
- PERL_UNUSED_ARG(cv);
 
  if (items > 1)
-     Perl_croak(aTHX_ "Usage: utf8::unicode_to_native(sv)");
+     croak_xs_usage(cv, "sv");
 
  ST(0) = sv_2mortal(newSViv(UNI_TO_NATIVE(uv)));
  XSRETURN(1);
@@ -872,10 +896,9 @@ XS(XS_Internals_hv_clear_placehold)
 {
     dVAR;
     dXSARGS;
-    PERL_UNUSED_ARG(cv);
 
     if (items != 1)
-       Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)");
+       croak_xs_usage(cv, "hv");
     else {
        HV * const hv = (HV *) SvRV(ST(0));
        hv_clear_placeholders(hv);
@@ -893,9 +916,8 @@ XS(XS_PerlIO_get_layers)
 {
     dVAR;
     dXSARGS;
-    PERL_UNUSED_ARG(cv);
     if (items < 1 || items % 2 == 0)
-       Perl_croak(aTHX_ "Usage: PerlIO_get_layers(filehandle[,args])");
+       croak_xs_usage(cv, "filehandle[,args]");
 #ifdef USE_PERLIO
     {
        SV *    sv;
@@ -969,16 +991,22 @@ XS(XS_PerlIO_get_layers)
                  const bool flgok = flgsvp && *flgsvp && SvIOK(*flgsvp);
 
                  if (details) {
+                     /* Indents of 5? Yuck.  */
+                     /* We know that PerlIO_get_layers creates a new SV for
+                        the name and flags, so we can just take a reference
+                        and "steal" it when we free the AV below.  */
                       XPUSHs(namok
-                             ? sv_2mortal(newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp)))
+                             ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))
                              : &PL_sv_undef);
                       XPUSHs(argok
-                             ? sv_2mortal(newSVpvn(SvPVX_const(*argsvp), SvCUR(*argsvp)))
+                             ? newSVpvn_flags(SvPVX_const(*argsvp),
+                                              SvCUR(*argsvp),
+                                              (SvUTF8(*argsvp) ? SVf_UTF8 : 0)
+                                              | SVs_TEMP)
+                             : &PL_sv_undef);
+                      XPUSHs(namok
+                             ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp))
                              : &PL_sv_undef);
-                      if (flgok)
-                           mXPUSHi(SvIVX(*flgsvp));
-                      else
-                           XPUSHs(&PL_sv_undef);
                       nitem += 3;
                  }
                  else {
@@ -987,8 +1015,7 @@ XS(XS_PerlIO_get_layers)
                                                 SVfARG(*namsvp),
                                                 SVfARG(*argsvp))));
                       else if (namok)
-                           XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf,
-                                                SVfARG(*namsvp))));
+                          XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)));
                       else
                            XPUSHs(&PL_sv_undef);
                       nitem++;
@@ -1059,7 +1086,7 @@ XS(XS_re_is_regexp)
     PERL_UNUSED_VAR(cv);
 
     if (items != 1)
-       Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv");
+       croak_xs_usage(cv, "sv");
 
     SP -= items;
 
@@ -1076,10 +1103,9 @@ XS(XS_re_regnames_count)
     SV * ret;
     dVAR; 
     dXSARGS;
-    PERL_UNUSED_ARG(cv);
 
     if (items != 0)
-       Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "");
+       croak_xs_usage(cv, "");
 
     SP -= items;
 
@@ -1091,7 +1117,7 @@ XS(XS_re_regnames_count)
     SPAGAIN;
 
     if (ret) {
-        XPUSHs(ret);
+        mXPUSHs(ret);
         PUTBACK;
         return;
     } else {
@@ -1106,10 +1132,9 @@ XS(XS_re_regname)
     REGEXP * rx;
     U32 flags;
     SV * ret;
-    PERL_UNUSED_ARG(cv);
 
     if (items < 1 || items > 2)
-        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "name[, all ]");
+       croak_xs_usage(cv, "name[, all ]");
 
     SP -= items;
 
@@ -1126,10 +1151,7 @@ XS(XS_re_regname)
     ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME));
 
     if (ret) {
-        if (SvROK(ret))
-            XPUSHs(ret);
-        else
-            XPUSHs(SvREFCNT_inc(ret));
+        mXPUSHs(ret);
         XSRETURN(1);
     }
     XSRETURN_UNDEF;    
@@ -1147,10 +1169,9 @@ XS(XS_re_regnames)
     I32 length;
     I32 i;
     SV **entry;
-    PERL_UNUSED_ARG(cv);
 
     if (items > 1)
-        Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "[all]");
+       croak_xs_usage(cv, "[all]");
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
@@ -1183,8 +1204,11 @@ XS(XS_re_regnames)
         if (!entry)
             Perl_croak(aTHX_ "NULL array element in re::regnames()");
 
-        XPUSHs(*entry);
+        mXPUSHs(SvREFCNT_inc_simple_NN(*entry));
     }
+
+    SvREFCNT_dec(ret);
+
     PUTBACK;
     return;
 }
@@ -1194,10 +1218,9 @@ XS(XS_re_regexp_pattern)
     dVAR;
     dXSARGS;
     REGEXP *re;
-    PERL_UNUSED_ARG(cv);
 
     if (items != 1)
-       Perl_croak(aTHX_ "Usage: %s(%s)", "re::regexp_pattern", "sv");
+       croak_xs_usage(cv, "sv");
 
     SP -= items;
 
@@ -1238,13 +1261,12 @@ XS(XS_re_regexp_pattern)
                 match_flags >>= 1;
             }
 
-            pattern = sv_2mortal(newSVpvn(RX_PRECOMP(re),RX_PRELEN(re)));
-            if (RX_UTF8(re))
-                SvUTF8_on(pattern);
+            pattern = newSVpvn_flags(RX_PRECOMP(re),RX_PRELEN(re),
+                                    (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
 
             /* return the pattern and the modifiers */
             XPUSHs(pattern);
-            XPUSHs(sv_2mortal(newSVpvn(reflags,left)));
+            XPUSHs(newSVpvn_flags(reflags, left, SVs_TEMP));
             XSRETURN(2);
         } else {
             /* Scalar, so use the string that Perl would return */
@@ -1252,9 +1274,8 @@ XS(XS_re_regexp_pattern)
 #if PERL_VERSION >= 11
             pattern = sv_2mortal(newSVsv((SV*)re));
 #else
-            pattern = sv_2mortal(newSVpvn(RX_WRAPPED(re),RX_WRAPLEN(re)));
-            if (RX_UTF8(re))
-                SvUTF8_on(pattern);
+            pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
+                                    (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
 #endif
             XPUSHs(pattern);
             XSRETURN(1);
@@ -1289,10 +1310,9 @@ XS(XS_Tie_Hash_NamedCapture_FETCH)
     REGEXP * rx;
     U32 flags;
     SV * ret;
-    PERL_UNUSED_ARG(cv);
 
     if (items != 2)
-        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $flags)");
+       croak_xs_usage(cv, "$key, $flags");
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
@@ -1307,10 +1327,7 @@ XS(XS_Tie_Hash_NamedCapture_FETCH)
     SPAGAIN;
 
     if (ret) {
-        if (SvROK(ret))
-            XPUSHs(ret);
-        else
-            XPUSHs(SvREFCNT_inc(ret));
+        mXPUSHs(ret);
         PUTBACK;
         return;
     }
@@ -1323,10 +1340,9 @@ XS(XS_Tie_Hash_NamedCapture_STORE)
     dXSARGS;
     REGEXP * rx;
     U32 flags;
-    PERL_UNUSED_ARG(cv);
 
     if (items != 3)
-        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::STORE($key, $value, $flags)");
+       croak_xs_usage(cv, "$key, $value, $flags");
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
@@ -1349,10 +1365,9 @@ XS(XS_Tie_Hash_NamedCapture_DELETE)
     dXSARGS;
     REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
     U32 flags;
-    PERL_UNUSED_ARG(cv);
 
     if (items != 2)
-        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::DELETE($key, $flags)");
+       croak_xs_usage(cv, "$key, $flags");
 
     if (!rx)
         Perl_croak(aTHX_ PL_no_modify);
@@ -1369,10 +1384,9 @@ XS(XS_Tie_Hash_NamedCapture_CLEAR)
     dXSARGS;
     REGEXP * rx;
     U32 flags;
-    PERL_UNUSED_ARG(cv);
 
     if (items != 1)
-        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::CLEAR($flags)");
+       croak_xs_usage(cv, "$flags");
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
@@ -1392,10 +1406,9 @@ XS(XS_Tie_Hash_NamedCapture_EXISTS)
     REGEXP * rx;
     U32 flags;
     SV * ret;
-    PERL_UNUSED_ARG(cv);
 
     if (items != 2)
-        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::EXISTS($key, $flags)");
+       croak_xs_usage(cv, "$key, $flags");
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
@@ -1421,10 +1434,9 @@ XS(XS_Tie_Hash_NamedCapture_FIRSTK)
     REGEXP * rx;
     U32 flags;
     SV * ret;
-    PERL_UNUSED_ARG(cv);
 
     if (items != 1)
-        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::FIRSTKEY()");
+       croak_xs_usage(cv, "");
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
@@ -1439,7 +1451,7 @@ XS(XS_Tie_Hash_NamedCapture_FIRSTK)
     SPAGAIN;
 
     if (ret) {
-        XPUSHs(SvREFCNT_inc(ret));
+        mXPUSHs(ret);
         PUTBACK;
     } else {
         XSRETURN_UNDEF;
@@ -1454,10 +1466,9 @@ XS(XS_Tie_Hash_NamedCapture_NEXTK)
     REGEXP * rx;
     U32 flags;
     SV * ret;
-    PERL_UNUSED_ARG(cv);
 
     if (items != 2)
-        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::NEXTKEY($lastkey)");
+       croak_xs_usage(cv, "$lastkey");
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
@@ -1472,7 +1483,7 @@ XS(XS_Tie_Hash_NamedCapture_NEXTK)
     SPAGAIN;
 
     if (ret) {
-        XPUSHs(ret);
+        mXPUSHs(ret);
     } else {
         XSRETURN_UNDEF;
     }  
@@ -1486,10 +1497,9 @@ XS(XS_Tie_Hash_NamedCapture_SCALAR)
     REGEXP * rx;
     U32 flags;
     SV * ret;
-    PERL_UNUSED_ARG(cv);
 
     if (items != 1)
-        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::SCALAR()");
+       croak_xs_usage(cv, "");
 
     rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL;
 
@@ -1504,7 +1514,7 @@ XS(XS_Tie_Hash_NamedCapture_SCALAR)
     SPAGAIN;
 
     if (ret) {
-        XPUSHs(ret);
+        mXPUSHs(ret);
         PUTBACK;
         return;
     } else {
@@ -1516,10 +1526,9 @@ XS(XS_Tie_Hash_NamedCapture_flags)
 {
     dVAR;
     dXSARGS;
-    PERL_UNUSED_ARG(cv);
 
     if (items != 0)
-        Perl_croak(aTHX_ "Usage: Tie::Hash::NamedCapture::flags()");
+       croak_xs_usage(cv, "");
 
        mXPUSHu(RXapif_ONE);
        mXPUSHu(RXapif_ALL);