diff options
-rw-r--r-- | embed.fnc | 3 | ||||
-rw-r--r-- | embed.h | 2 | ||||
-rw-r--r-- | global.sym | 1 | ||||
-rw-r--r-- | mro.c | 32 | ||||
-rw-r--r-- | pod/perlapi.pod | 17 | ||||
-rw-r--r-- | proto.h | 8 | ||||
-rw-r--r-- | universal.c | 141 | ||||
-rw-r--r-- | xsutils.c | 19 |
8 files changed, 115 insertions, 108 deletions
@@ -148,6 +148,9 @@ pM |PERL_CONTEXT* |create_eval_scope|U32 flags : croak()'s first parm can be NULL. Otherwise, mod_perl breaks. Afprd |void |croak |NULLOK const char* pat|... Apr |void |vcroak |NULLOK const char* pat|NULLOK va_list* args +Aprd |void |croak_xs_usage |NN const CV *const cv \ + |NN const char *const params + #if defined(PERL_IMPLICIT_CONTEXT) Afnrp |void |croak_nocontext|NULLOK const char* pat|... Afnp |OP* |die_nocontext |NN const char* pat|... @@ -104,6 +104,7 @@ #endif #define croak Perl_croak #define vcroak Perl_vcroak +#define croak_xs_usage Perl_croak_xs_usage #if defined(PERL_IMPLICIT_CONTEXT) #define croak_nocontext Perl_croak_nocontext #define die_nocontext Perl_die_nocontext @@ -2421,6 +2422,7 @@ #define create_eval_scope(a) Perl_create_eval_scope(aTHX_ a) #endif #define vcroak(a,b) Perl_vcroak(aTHX_ a,b) +#define croak_xs_usage(a,b) Perl_croak_xs_usage(aTHX_ a,b) #if defined(PERL_IMPLICIT_CONTEXT) #endif #ifdef PERL_CORE diff --git a/global.sym b/global.sym index 53e15a8a5f..248d8a4bb4 100644 --- a/global.sym +++ b/global.sym @@ -61,6 +61,7 @@ Perl_cast_uv Perl_my_chsize Perl_croak Perl_vcroak +Perl_croak_xs_usage Perl_croak_nocontext Perl_die_nocontext Perl_deb_nocontext @@ -707,10 +707,8 @@ XS(XS_mro_get_linear_isa) { HV* class_stash; SV* classname; - PERL_UNUSED_ARG(cv); - if(items < 1 || items > 2) - Perl_croak(aTHX_ "Usage: mro::get_linear_isa(classname [, type ])"); + croak_xs_usage(cv, "classname [, type ]"); classname = ST(0); class_stash = gv_stashsv(classname, 0); @@ -748,10 +746,8 @@ XS(XS_mro_set_mro) HV* class_stash; struct mro_meta* meta; - PERL_UNUSED_ARG(cv); - if (items != 2) - Perl_croak(aTHX_ "Usage: mro::set_mro(classname, type)"); + croak_xs_usage(cv, "classname, type"); classname = ST(0); whichstr = SvPV_nolen(ST(1)); @@ -783,10 +779,8 @@ XS(XS_mro_get_mro) SV* classname; HV* class_stash; - PERL_UNUSED_ARG(cv); - if (items != 1) - Perl_croak(aTHX_ "Usage: mro::get_mro(classname)"); + croak_xs_usage(cv, "classname"); classname = ST(0); class_stash = gv_stashsv(classname, 0); @@ -806,10 +800,8 @@ XS(XS_mro_get_isarev) HV* isarev; AV* ret_array; - PERL_UNUSED_ARG(cv); - if (items != 1) - Perl_croak(aTHX_ "Usage: mro::get_isarev(classname)"); + croak_xs_usage(cv, "classname"); classname = ST(0); @@ -842,10 +834,8 @@ XS(XS_mro_is_universal) STRLEN classname_len; HE* he; - PERL_UNUSED_ARG(cv); - if (items != 1) - Perl_croak(aTHX_ "Usage: mro::is_universal(classname)"); + croak_xs_usage(cv, "classname"); classname = ST(0); @@ -866,10 +856,8 @@ XS(XS_mro_invalidate_method_caches) dVAR; dXSARGS; - PERL_UNUSED_ARG(cv); - if (items != 0) - Perl_croak(aTHX_ "Usage: mro::invalidate_all_method_caches()"); + croak_xs_usage(cv, ""); PL_sub_generation++; @@ -883,10 +871,8 @@ XS(XS_mro_method_changed_in) SV* classname; HV* class_stash; - PERL_UNUSED_ARG(cv); - if(items != 1) - Perl_croak(aTHX_ "Usage: mro::method_changed_in(classname)"); + croak_xs_usage(cv, "classname"); classname = ST(0); @@ -905,10 +891,8 @@ XS(XS_mro_get_pkg_gen) SV* classname; HV* class_stash; - PERL_UNUSED_ARG(cv); - if(items != 1) - Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)"); + croak_xs_usage(cv, "classname"); classname = ST(0); diff --git a/pod/perlapi.pod b/pod/perlapi.pod index 2644e88a8a..effd8fbe0e 100644 --- a/pod/perlapi.pod +++ b/pod/perlapi.pod @@ -3931,6 +3931,23 @@ Found in file sv.h =over 8 +=item croak_xs_usage +X<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"); + + void croak_xs_usage(CV *const cv, const char *const params) + +=for hackers +Found in file universal.c + =item get_sv X<get_sv> @@ -327,6 +327,14 @@ PERL_CALLCONV void Perl_croak(pTHX_ const char* pat, ...) PERL_CALLCONV void Perl_vcroak(pTHX_ const char* pat, va_list* args) __attribute__noreturn__; +PERL_CALLCONV void Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) + __attribute__noreturn__ + __attribute__nonnull__(pTHX_1) + __attribute__nonnull__(pTHX_2); +#define PERL_ARGS_ASSERT_CROAK_XS_USAGE \ + assert(cv); assert(params) + + #if defined(PERL_IMPLICIT_CONTEXT) PERL_CALLCONV void Perl_croak_nocontext(const char* pat, ...) __attribute__noreturn__ diff --git a/universal.c b/universal.c index d03596c82b..7026195b6b 100644 --- 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(%"UVXf")(%s)", (UV)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; @@ -1050,7 +1065,6 @@ XS(XS_Internals_HvREHASH) /* Subject to change */ { dVAR; dXSARGS; - PERL_UNUSED_ARG(cv); if (SvROK(ST(0))) { const HV * const hv = (HV *) SvRV(ST(0)); if (items == 1 && SvTYPE(hv) == SVt_PVHV) { @@ -1070,7 +1084,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 +1101,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; @@ -1117,10 +1130,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; @@ -1158,10 +1170,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; @@ -1205,10 +1216,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 +1308,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; @@ -1332,10 +1341,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 +1366,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 +1385,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 +1407,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 +1435,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; @@ -1463,10 +1467,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; @@ -1495,10 +1498,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; @@ -1525,10 +1527,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); @@ -150,10 +150,9 @@ XS(XS_attributes_bootstrap) { dVAR; dXSARGS; - PERL_UNUSED_ARG(cv); if( items > 1 ) - Perl_croak(aTHX_ "Usage: attributes::bootstrap $module"); + croak_xs_usage(cv, "$module"); newXS("attributes::_modify_attrs", XS_attributes__modify_attrs, file); newXSproto("attributes::_guess_stash", XS_attributes__guess_stash, file, "$"); @@ -168,12 +167,10 @@ XS(XS_attributes__modify_attrs) dVAR; dXSARGS; SV *rv, *sv; - PERL_UNUSED_ARG(cv); if (items < 1) { usage: - Perl_croak(aTHX_ - "Usage: attributes::_modify_attrs $reference, @attributes"); + croak_xs_usage(cv, "@attributes"); } rv = ST(0); @@ -192,12 +189,10 @@ XS(XS_attributes__fetch_attrs) dXSARGS; SV *rv, *sv; cv_flags_t cvflags; - PERL_UNUSED_ARG(cv); if (items != 1) { usage: - Perl_croak(aTHX_ - "Usage: attributes::_fetch_attrs $reference"); + croak_xs_usage(cv, "$reference"); } rv = ST(0); @@ -237,12 +232,10 @@ XS(XS_attributes__guess_stash) dXSARGS; SV *rv, *sv; dXSTARG; - PERL_UNUSED_ARG(cv); if (items != 1) { usage: - Perl_croak(aTHX_ - "Usage: attributes::_guess_stash $reference"); + croak_xs_usage(cv, "$reference"); } rv = ST(0); @@ -287,12 +280,10 @@ XS(XS_attributes_reftype) dXSARGS; SV *rv, *sv; dXSTARG; - PERL_UNUSED_ARG(cv); if (items != 1) { usage: - Perl_croak(aTHX_ - "Usage: attributes::reftype $reference"); + croak_xs_usage(cv, "$reference"); } rv = ST(0); |