X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=universal.c;h=f8ba9f7b8238d33e70ca883987c62ff188118741;hb=9711599ee3b2375539002b6ddc0873ec478916bb;hp=7fc2ad367c17437b0e4496e9d6a4d7c47e1e0192;hpb=5c35adbb8fc4c988807097c4d379e2485ada5865;p=p5sagit%2Fp5-mst-13.2.git diff --git a/universal.c b/universal.c index 7fc2ad3..f8ba9f7 100644 --- a/universal.c +++ b/universal.c @@ -1,7 +1,7 @@ /* universal.c * * Copyright (C) 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, - * 2005, 2006, 2007 by Larry Wall and others + * 2005, 2006, 2007, 2008 by Larry Wall and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. @@ -9,9 +9,11 @@ */ /* - * "The roots of those mountains must be roots indeed; there must be - * great secrets buried there which have not been discovered since the - * beginning." --Gandalf, relating Gollum's story + * '"The roots of those mountains must be roots indeed; there must be + * great secrets buried there which have not been discovered since the + * beginning."' --Gandalf, relating Gollum's history + * + * [p.54 of _The Lord of the Rings_, I/ii: "The Shadow of the Past"] */ /* This file contains the code that implements the functions in Perl's @@ -37,42 +39,35 @@ */ STATIC bool -S_isa_lookup(pTHX_ HV *stash, const char * const name, const HV* const name_stash) +S_isa_lookup(pTHX_ HV *stash, const char * const name) { dVAR; - AV* stash_linear_isa; - SV** svp; - const char *hvname; - I32 items; - - /* 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)) - return TRUE; + const struct mro_meta *const meta = HvMROMETA(stash); + HV *const isa = meta->isa ? meta->isa : Perl_get_isa_hash(aTHX_ stash); + STRLEN len = strlen(name); + const HV *our_stash; - hvname = HvNAME_get(stash); + PERL_ARGS_ASSERT_ISA_LOOKUP; - if (strEQ(hvname, name)) + if (hv_common(isa, NULL, name, len, 0 /* No "UTF-8" flag possible with only + a char * argument*/, + HV_FETCH_ISEXISTS, NULL, 0)) { + /* Direct name lookup worked. */ return TRUE; + } - if (strEQ(name, "UNIVERSAL")) - return TRUE; + /* A stash/class can go by many names (ie. User == main::User), so + we use the name in the stash itself, which is canonical. */ + our_stash = gv_stashpvn(name, len, 0); - stash_linear_isa = mro_get_linear_isa(stash); - svp = AvARRAY(stash_linear_isa) + 1; - items = AvFILLp(stash_linear_isa); - while (items--) { - SV* const basename_sv = *svp++; - HV* const basestash = gv_stashsv(basename_sv, 0); - if (!basestash) { - if (ckWARN(WARN_SYNTAX)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Can't locate package %"SVf" for the parents of %s", - SVfARG(basename_sv), hvname); - continue; - } - if(name_stash == basestash || strEQ(name, SvPVX(basename_sv))) + if (our_stash) { + HEK *const canon_name = HvNAME_HEK(our_stash); + + if (hv_common(isa, NULL, HEK_KEY(canon_name), HEK_LEN(canon_name), + HEK_FLAGS(canon_name), + HV_FETCH_ISEXISTS, NULL, HEK_HASH(canon_name))) { return TRUE; + } } return FALSE; @@ -91,11 +86,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)) { @@ -110,13 +107,7 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name) stash = gv_stashsv(sv, 0); } - if (stash) { - HV * const name_stash = gv_stashpv(name, 0); - return isa_lookup(stash, name, name_stash); - } - else - return FALSE; - + return stash ? isa_lookup(stash, name) : FALSE; } /* @@ -131,13 +122,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; @@ -158,10 +151,10 @@ Perl_sv_does(pTHX_ SV *sv, const char *name) PUSHMARK(SP); XPUSHs(sv); - XPUSHs(sv_2mortal(newSVpv(name, 0))); + mXPUSHs(newSVpv(name, 0)); PUTBACK; - methodname = sv_2mortal(newSVpvs("isa")); + methodname = newSVpvs_flags("isa", SVs_TEMP); /* ugly hack: use the SvSCREAM flag so S_method_common * can figure out we're calling DOES() and not isa(), * and report eventual errors correctly. --rgs */ @@ -205,6 +198,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 +207,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 +263,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 +271,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 +283,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 for emitting the usage message for xsubs + + croak_xs_usage(cv, "eee_yow"); + +works out the package name and subroutine name from C, and then calls +C. Hence if C is C<&ouch::awk>, it would call C 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 +352,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); @@ -337,7 +368,7 @@ XS(XS_UNIVERSAL_can) rv = &PL_sv_undef; if (SvROK(sv)) { - sv = (SV*)SvRV(sv); + sv = MUTABLE_SV(SvRV(sv)); if (SvOBJECT(sv)) pkg = SvSTASH(sv); } @@ -348,7 +379,7 @@ XS(XS_UNIVERSAL_can) if (pkg) { GV * const gv = gv_fetchmethod_autoload(pkg, name, FALSE); if (gv && isGV(gv)) - rv = sv_2mortal(newRV((SV*)GvCV(gv))); + rv = sv_2mortal(newRV(MUTABLE_SV(GvCV(gv)))); } ST(0) = rv; @@ -387,7 +418,7 @@ XS(XS_UNIVERSAL_VERSION) PERL_UNUSED_ARG(cv); if (SvROK(ST(0))) { - sv = (SV*)SvRV(ST(0)); + sv = MUTABLE_SV(SvRV(ST(0))); if (!SvOBJECT(sv)) Perl_croak(aTHX_ "Cannot find version of an unblessed reference"); pkg = SvSTASH(sv); @@ -407,7 +438,7 @@ XS(XS_UNIVERSAL_VERSION) undef = NULL; } else { - sv = (SV*)&PL_sv_undef; + sv = &PL_sv_undef; undef = "(undef)"; } @@ -433,7 +464,7 @@ XS(XS_UNIVERSAL_VERSION) } if ( vcmp( req, sv ) > 0 ) { - if ( hv_exists((HV*)SvRV(req), "qv", 2 ) ) { + if ( hv_exists(MUTABLE_HV(SvRV(req)), "qv", 2 ) ) { Perl_croak(aTHX_ "%s version %"SVf" required--" "this is only version %"SVf"", HvNAME_get(pkg), SVfARG(vnormal(req)), @@ -461,9 +492,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); @@ -476,7 +506,7 @@ XS(XS_version_new) if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */ /* create empty object */ vs = sv_newmortal(); - sv_setpvn(vs,"",0); + sv_setpvs(vs,""); } else if ( items == 3 ) { vs = sv_newmortal(); @@ -487,7 +517,7 @@ XS(XS_version_new) if ( strcmp(classname,"version") != 0 ) /* inherited new() */ sv_bless(rv, gv_stashpv(classname, GV_ADD)); - PUSHs(sv_2mortal(rv)); + mPUSHs(rv); PUTBACK; return; } @@ -497,9 +527,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; @@ -510,7 +539,7 @@ XS(XS_version_stringify) else Perl_croak(aTHX_ "lobj is not of type version"); - PUSHs(sv_2mortal(vstringify(lobj))); + mPUSHs(vstringify(lobj)); PUTBACK; return; @@ -521,9 +550,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; @@ -534,7 +562,7 @@ XS(XS_version_numify) else Perl_croak(aTHX_ "lobj is not of type version"); - PUSHs(sv_2mortal(vnumify(lobj))); + mPUSHs(vnumify(lobj)); PUTBACK; return; @@ -545,9 +573,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; @@ -558,7 +585,7 @@ XS(XS_version_normal) else Perl_croak(aTHX_ "lobj is not of type version"); - PUSHs(sv_2mortal(vnormal(lobj))); + mPUSHs(vnormal(lobj)); PUTBACK; return; @@ -569,9 +596,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; @@ -603,7 +629,7 @@ XS(XS_version_vcmp) rs = newSViv(vcmp(lobj,rvs)); } - PUSHs(sv_2mortal(rs)); + mPUSHs(rs); } PUTBACK; @@ -615,14 +641,13 @@ 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)); SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) ); - PUSHs(sv_2mortal(rs)); + mPUSHs(rs); PUTBACK; return; } @@ -634,9 +659,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,13 +674,12 @@ 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); - if ( hv_exists((HV*)SvRV(lobj), "alpha", 5 ) ) + if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "alpha", 5 ) ) XSRETURN_YES; else XSRETURN_NO; @@ -671,9 +694,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); @@ -685,7 +707,7 @@ XS(XS_version_qv) } else { - PUSHs(sv_2mortal(new_version(ver))); + mPUSHs(new_version(ver)); } PUTBACK; @@ -697,9 +719,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 +735,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 +753,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 +763,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 +778,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 +795,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 +813,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 +826,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,24 +882,28 @@ 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 * const hv = MUTABLE_HV(SvRV(ST(0))); hv_clear_placeholders(hv); XSRETURN(0); } } +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; @@ -933,17 +951,16 @@ XS(XS_PerlIO_get_layers) } sv = POPs; - gv = (GV*)sv; + gv = MUTABLE_GV(sv); if (!isGV(sv)) { if (SvROK(sv) && isGV(SvRV(sv))) - gv = (GV*)SvRV(sv); + gv = MUTABLE_GV(SvRV(sv)); else if (SvPOKp(sv)) gv = gv_fetchsv(sv, 0, SVt_PVIO); } if (gv && (io = GvIO(gv))) { - dTARGET; AV* const av = PerlIO_get_layers(aTHX_ input ? IoIFP(io) : IoOFP(io)); I32 i; @@ -960,26 +977,31 @@ 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 - ? newSVpvn(SvPVX_const(*namsvp), SvCUR(*namsvp)) + ? sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp)) : &PL_sv_undef); XPUSHs(argok - ? 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) - XPUSHi(SvIVX(*flgsvp)); - else - XPUSHs(&PL_sv_undef); nitem += 3; } else { if (namok && argok) - XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", + XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", SVfARG(*namsvp), - SVfARG(*argsvp))); + SVfARG(*argsvp)))); else if (namok) - XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, - SVfARG(*namsvp))); + XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))); else XPUSHs(&PL_sv_undef); nitem++; @@ -987,7 +1009,7 @@ XS(XS_PerlIO_get_layers) const IV flags = SvIVX(*flgsvp); if (flags & PERLIO_F_UTF8) { - XPUSHs(newSVpvs("utf8")); + XPUSHs(newSVpvs_flags("utf8", SVs_TEMP)); nitem++; } } @@ -1032,7 +1054,7 @@ XS(XS_Internals_HvREHASH) /* Subject to change */ dXSARGS; PERL_UNUSED_ARG(cv); if (SvROK(ST(0))) { - const HV * const hv = (HV *) SvRV(ST(0)); + const HV * const hv = (const HV *) SvRV(ST(0)); if (items == 1 && SvTYPE(hv) == SVt_PVHV) { if (HvREHASH(hv)) XSRETURN_YES; @@ -1050,7 +1072,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; @@ -1067,10 +1089,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; @@ -1082,7 +1103,7 @@ XS(XS_re_regnames_count) SPAGAIN; if (ret) { - XPUSHs(ret); + mXPUSHs(ret); PUTBACK; return; } else { @@ -1097,10 +1118,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; @@ -1117,10 +1137,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; @@ -1138,10 +1155,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; @@ -1165,7 +1181,7 @@ XS(XS_re_regnames) if (!ret) XSRETURN_UNDEF; - av = (AV*)SvRV(ret); + av = MUTABLE_AV(SvRV(ret)); length = av_len(av); for (i = 0; i <= length; i++) { @@ -1174,12 +1190,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(MUTABLE_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; @@ -1187,10 +1296,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; @@ -1199,16 +1307,13 @@ XS(XS_Tie_Hash_NamedCapture_FETCH) SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags); SPAGAIN; if (ret) { - if (SvROK(ret)) - XPUSHs(ret); - else - XPUSHs(SvREFCNT_inc(ret)); + mXPUSHs(ret); PUTBACK; return; } @@ -1221,23 +1326,22 @@ 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; if (!rx) { if (!PL_localizing) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); else XSRETURN_UNDEF; } SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags); } @@ -1247,17 +1351,16 @@ 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); + Perl_croak(aTHX_ "%s", PL_no_modify); SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags); } @@ -1267,19 +1370,18 @@ 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; if (!rx) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); CALLREG_NAMED_BUFF_CLEAR(rx, flags); } @@ -1290,10 +1392,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; @@ -1302,7 +1403,7 @@ XS(XS_Tie_Hash_NamedCapture_EXISTS) SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags); SPAGAIN; @@ -1319,10 +1420,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; @@ -1331,13 +1431,13 @@ XS(XS_Tie_Hash_NamedCapture_FIRSTK) SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags); SPAGAIN; if (ret) { - XPUSHs(SvREFCNT_inc(ret)); + mXPUSHs(ret); PUTBACK; } else { XSRETURN_UNDEF; @@ -1352,10 +1452,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; @@ -1364,13 +1463,13 @@ XS(XS_Tie_Hash_NamedCapture_NEXTK) SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags); SPAGAIN; if (ret) { - XPUSHs(ret); + mXPUSHs(ret); } else { XSRETURN_UNDEF; } @@ -1384,10 +1483,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; @@ -1396,13 +1494,13 @@ XS(XS_Tie_Hash_NamedCapture_SCALAR) SP -= items; - flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + flags = (U32)INT2PTR(IV,SvIV(SvRV(MUTABLE_SV(ST(0))))); ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags); SPAGAIN; if (ret) { - XPUSHs(ret); + mXPUSHs(ret); PUTBACK; return; } else { @@ -1414,13 +1512,12 @@ 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, ""); - XPUSHs(sv_2mortal(newSVuv(RXapif_ONE))); - XPUSHs(sv_2mortal(newSVuv(RXapif_ALL))); + mXPUSHu(RXapif_ONE); + mXPUSHu(RXapif_ALL); PUTBACK; return; }