X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/6e449a3ab1e3bd9d7e138ca681c733e57d4daa49..a1fea99b3ddaebb8d880c2daff65d93f1f665e1d:/universal.c?ds=sidebyside

diff --git a/universal.c b/universal.c
index 7d1bd55..be58760 100644
--- 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))
@@ -91,11 +93,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 +135,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;
 
@@ -205,6 +211,7 @@ XS(XS_Internals_SvREADONLY);
 XS(XS_Internals_SvREFCNT);
 XS(XS_Internals_hv_clear_placehold);
 XS(XS_PerlIO_get_layers);
+XS(XS_Regexp_DESTROY);
 XS(XS_Internals_hash_seed);
 XS(XS_Internals_rehash_seed);
 XS(XS_Internals_HvREHASH);
@@ -213,6 +220,7 @@ XS(XS_re_is_regexp);
 XS(XS_re_regname);
 XS(XS_re_regnames);
 XS(XS_re_regnames_count);
+XS(XS_re_regexp_pattern);
 XS(XS_Tie_Hash_NamedCapture_FETCH);
 XS(XS_Tie_Hash_NamedCapture_STORE);
 XS(XS_Tie_Hash_NamedCapture_DELETE);
@@ -268,6 +276,7 @@ Perl_boot_core_UNIVERSAL(pTHX)
                XS_Internals_hv_clear_placehold, file, "\\%");
     newXSproto("PerlIO::get_layers",
                XS_PerlIO_get_layers, file, "*;@");
+    newXS("Regexp::DESTROY", XS_Regexp_DESTROY, file);
     newXSproto("Internals::hash_seed",XS_Internals_hash_seed, file, "");
     newXSproto("Internals::rehash_seed",XS_Internals_rehash_seed, file, "");
     newXSproto("Internals::HvREHASH", XS_Internals_HvREHASH, file, "\\%");
@@ -275,6 +284,7 @@ Perl_boot_core_UNIVERSAL(pTHX)
     newXSproto("re::regname", XS_re_regname, file, ";$$");
     newXSproto("re::regnames", XS_re_regnames, file, ";$");
     newXSproto("re::regnames_count", XS_re_regnames_count, file, "");
+    newXSproto("re::regexp_pattern", XS_re_regexp_pattern, file, "$");
     newXS("Tie::Hash::NamedCapture::FETCH", XS_Tie_Hash_NamedCapture_FETCH, file);
     newXS("Tie::Hash::NamedCapture::STORE", XS_Tie_Hash_NamedCapture_STORE, file);
     newXS("Tie::Hash::NamedCapture::DELETE", XS_Tie_Hash_NamedCapture_DELETE, file);
@@ -286,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;
@@ -320,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);
 
@@ -461,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);
@@ -497,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;
@@ -521,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;
@@ -545,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;
@@ -569,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;
@@ -615,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));
@@ -634,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
@@ -650,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);
@@ -671,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);
@@ -697,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))
@@ -714,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;
@@ -733,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;
 }
@@ -744,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);
@@ -760,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;
@@ -778,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));
@@ -797,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);
@@ -811,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);
@@ -868,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);
@@ -879,13 +905,18 @@ XS(XS_Internals_hv_clear_placehold)
     }
 }
 
+XS(XS_Regexp_DESTROY)
+{
+    PERL_UNUSED_CONTEXT;
+    PERL_UNUSED_ARG(cv);
+}
+
 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;
@@ -959,16 +990,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 {
@@ -977,8 +1014,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++;
@@ -1049,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;
 
@@ -1066,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;
 
@@ -1081,7 +1116,7 @@ XS(XS_re_regnames_count)
     SPAGAIN;
 
     if (ret) {
-        XPUSHs(ret);
+        mXPUSHs(ret);
         PUTBACK;
         return;
     } else {
@@ -1096,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;
 
@@ -1116,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;    
@@ -1137,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;
 
@@ -1173,12 +1203,105 @@ 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;
 }
 
+XS(XS_re_regexp_pattern)
+{
+    dVAR;
+    dXSARGS;
+    REGEXP *re;
+
+    if (items != 1)
+	croak_xs_usage(cv, "sv");
+
+    SP -= items;
+
+    /*
+       Checks if a reference is a regex or not. If the parameter is
+       not a ref, or is not the result of a qr// then returns false
+       in scalar context and an empty list in list context.
+       Otherwise in list context it returns the pattern and the
+       modifiers, in scalar context it returns the pattern just as it
+       would if the qr// was stringified normally, regardless as
+       to the class of the variable and any strigification overloads
+       on the object.
+    */
+
+    if ((re = SvRX(ST(0)))) /* assign deliberate */
+    {
+        /* Housten, we have a regex! */
+        SV *pattern;
+        STRLEN left = 0;
+        char reflags[6];
+
+        if ( GIMME_V == G_ARRAY ) {
+            /*
+               we are in list context so stringify
+               the modifiers that apply. We ignore "negative
+               modifiers" in this scenario.
+            */
+
+            const char *fptr = INT_PAT_MODS;
+            char ch;
+            U16 match_flags = (U16)((RX_EXTFLAGS(re) & PMf_COMPILETIME)
+                                    >> RXf_PMf_STD_PMMOD_SHIFT);
+
+            while((ch = *fptr++)) {
+                if(match_flags & 1) {
+                    reflags[left++] = ch;
+                }
+                match_flags >>= 1;
+            }
+
+            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(newSVpvn_flags(reflags, left, SVs_TEMP));
+            XSRETURN(2);
+        } else {
+            /* Scalar, so use the string that Perl would return */
+            /* return the pattern in (?msix:..) format */
+#if PERL_VERSION >= 11
+            pattern = sv_2mortal(newSVsv((SV*)re));
+#else
+            pattern = newSVpvn_flags(RX_WRAPPED(re), RX_WRAPLEN(re),
+				     (RX_UTF8(re) ? SVf_UTF8 : 0) | SVs_TEMP);
+#endif
+            XPUSHs(pattern);
+            XSRETURN(1);
+        }
+    } else {
+        /* It ain't a regexp folks */
+        if ( GIMME_V == G_ARRAY ) {
+            /* return the empty list */
+            XSRETURN_UNDEF;
+        } else {
+            /* Because of the (?:..) wrapping involved in a
+               stringified pattern it is impossible to get a
+               result for a real regexp that would evaluate to
+               false. Therefore we can return PL_sv_no to signify
+               that the object is not a regex, this means that one
+               can say
+
+                 if (regex($might_be_a_regex) eq '(?:foo)') { }
+
+               and not worry about undefined values.
+            */
+            XSRETURN_NO;
+        }
+    }
+    /* NOT-REACHED */
+}
+
 XS(XS_Tie_Hash_NamedCapture_FETCH)
 {
     dVAR;
@@ -1186,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;
 
@@ -1204,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;
     }
@@ -1220,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;
 
@@ -1246,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);
@@ -1266,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;
 
@@ -1289,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;
 
@@ -1318,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;
 
@@ -1336,7 +1450,7 @@ XS(XS_Tie_Hash_NamedCapture_FIRSTK)
     SPAGAIN;
 
     if (ret) {
-        XPUSHs(SvREFCNT_inc(ret));
+        mXPUSHs(ret);
         PUTBACK;
     } else {
         XSRETURN_UNDEF;
@@ -1351,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;
 
@@ -1369,7 +1482,7 @@ XS(XS_Tie_Hash_NamedCapture_NEXTK)
     SPAGAIN;
 
     if (ret) {
-        XPUSHs(ret);
+        mXPUSHs(ret);
     } else {
         XSRETURN_UNDEF;
     }  
@@ -1383,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;
 
@@ -1401,7 +1513,7 @@ XS(XS_Tie_Hash_NamedCapture_SCALAR)
     SPAGAIN;
 
     if (ret) {
-        XPUSHs(ret);
+        mXPUSHs(ret);
         PUTBACK;
         return;
     } else {
@@ -1413,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);