This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
Small typo fix
[perl5.git] / universal.c
diff --git a/universal.c b/universal.c
index d03596c..be58760 100644 (file)
--- a/universal.c
+++ b/universal.c
@@ -296,15 +296,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;
@@ -330,10 +365,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);
 
@@ -471,9 +505,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);
@@ -507,9 +540,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;
@@ -531,9 +563,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;
@@ -555,9 +586,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;
@@ -579,9 +609,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;
@@ -625,9 +654,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));
@@ -644,9 +672,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
@@ -660,9 +687,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);
@@ -681,9 +707,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);
@@ -707,9 +732,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))
@@ -724,9 +748,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;
@@ -743,9 +766,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;
 }
@@ -754,9 +776,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);
@@ -770,9 +791,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;
@@ -788,9 +808,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));
@@ -807,10 +826,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);
@@ -821,10 +839,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);
@@ -878,10 +895,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);
@@ -899,9 +915,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;
@@ -1070,7 +1085,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;
 
@@ -1087,10 +1102,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;
 
@@ -1102,7 +1116,7 @@ XS(XS_re_regnames_count)
     SPAGAIN;
 
     if (ret) {
-        XPUSHs(ret);
+        mXPUSHs(ret);
         PUTBACK;
         return;
     } else {
@@ -1117,10 +1131,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;
 
@@ -1137,10 +1150,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;    
@@ -1158,10 +1168,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;
 
@@ -1194,8 +1203,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;
 }
@@ -1205,10 +1217,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;
 
@@ -1298,10 +1309,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;
 
@@ -1316,10 +1326,7 @@ XS(XS_Tie_Hash_NamedCapture_FETCH)
     SPAGAIN;
 
     if (ret) {
-        if (SvROK(ret))
-            XPUSHs(ret);
-        else
-            XPUSHs(SvREFCNT_inc(ret));
+        mXPUSHs(ret);
         PUTBACK;
         return;
     }
@@ -1332,10 +1339,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;
 
@@ -1358,10 +1364,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);
@@ -1378,10 +1383,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;
 
@@ -1401,10 +1405,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;
 
@@ -1430,10 +1433,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;
 
@@ -1448,7 +1450,7 @@ XS(XS_Tie_Hash_NamedCapture_FIRSTK)
     SPAGAIN;
 
     if (ret) {
-        XPUSHs(SvREFCNT_inc(ret));
+        mXPUSHs(ret);
         PUTBACK;
     } else {
         XSRETURN_UNDEF;
@@ -1463,10 +1465,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;
 
@@ -1481,7 +1482,7 @@ XS(XS_Tie_Hash_NamedCapture_NEXTK)
     SPAGAIN;
 
     if (ret) {
-        XPUSHs(ret);
+        mXPUSHs(ret);
     } else {
         XSRETURN_UNDEF;
     }  
@@ -1495,10 +1496,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;
 
@@ -1513,7 +1513,7 @@ XS(XS_Tie_Hash_NamedCapture_SCALAR)
     SPAGAIN;
 
     if (ret) {
-        XPUSHs(ret);
+        mXPUSHs(ret);
         PUTBACK;
         return;
     } else {
@@ -1525,10 +1525,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);
Unnamed repository; edit this file 'description' to name the repository.