X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ac0e6a2fd2970df72270aecb94d407fe170b43a7..a1fea99b3ddaebb8d880c2daff65d93f1f665e1d:/universal.c diff --git a/universal.c b/universal.c index 0d2ec1c..be58760 100644 --- a/universal.c +++ b/universal.c @@ -16,6 +16,11 @@ /* This file contains the code that implements the functions in Perl's * UNIVERSAL package, such as UNIVERSAL->can(). + * + * It is also used to store XS functions that need to be present in + * miniperl for a lack of a better place to put them. It might be + * clever to move them to seperate XS files which would then be pulled + * in by some to-be-written build process. */ #include "EXTERN.h" @@ -32,16 +37,15 @@ */ STATIC bool -S_isa_lookup(pTHX_ HV *stash, const char *name, const HV* const name_stash, - int len, int level) +S_isa_lookup(pTHX_ HV *stash, const char * const name, const HV* const name_stash) { dVAR; - AV* av; - GV* gv; - GV** gvp; - HV* hv = NULL; - SV* subgen = NULL; + AV* stash_linear_isa; + SV** svp; 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 */ @@ -56,75 +60,23 @@ S_isa_lookup(pTHX_ HV *stash, const char *name, const HV* const name_stash, if (strEQ(name, "UNIVERSAL")) return TRUE; - if (level > 100) - Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", - hvname); - - gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE); - - if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (subgen = GvSV(gv)) - && (hv = GvHV(gv))) - { - if (SvIV(subgen) == (IV)PL_sub_generation) { - SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE); - if (svp) { - SV * const sv = *svp; -#ifdef DEBUGGING - if (sv != &PL_sv_undef) - DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", - name, hvname) ); -#endif - return (sv == &PL_sv_yes); - } - } - else { - DEBUG_o( Perl_deb(aTHX_ "ISA Cache in package %s is stale\n", - hvname) ); - hv_clear(hv); - sv_setiv(subgen, PL_sub_generation); + 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))) + return TRUE; } - gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); - - if (gvp && (gv = *gvp) && isGV_with_GP(gv) && (av = GvAV(gv))) { - if (!hv || !subgen) { - gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE); - - gv = *gvp; - - if (SvTYPE(gv) != SVt_PVGV) - gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); - - if (!hv) - hv = GvHVn(gv); - if (!subgen) { - subgen = newSViv(PL_sub_generation); - GvSV(gv) = subgen; - } - } - if (hv) { - SV** svp = AvARRAY(av); - /* NOTE: No support for tied ISA */ - I32 items = AvFILLp(av) + 1; - while (items--) { - SV* const sv = *svp++; - HV* const basestash = gv_stashsv(sv, 0); - if (!basestash) { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Can't locate package %"SVf" for @%s::ISA", - SVfARG(sv), hvname); - continue; - } - if (isa_lookup(basestash, name, name_stash, len, level + 1)) { - (void)hv_store(hv,name,len,&PL_sv_yes,0); - return TRUE; - } - } - (void)hv_store(hv,name,len,&PL_sv_no,0); - } - } return FALSE; } @@ -141,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)) { @@ -162,7 +116,7 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name) if (stash) { HV * const name_stash = gv_stashpv(name, 0); - return isa_lookup(stash, name, name_stash, strlen(name), 0); + return isa_lookup(stash, name, name_stash); } else return FALSE; @@ -181,12 +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; @@ -199,7 +156,7 @@ Perl_sv_does(pTHX_ SV *sv, const char *name) if (sv_isobject(sv)) { classname = sv_reftype(SvRV(sv),TRUE); } else { - classname = SvPV(sv,PL_na); + classname = SvPV_nolen(sv); } if (strEQ(name,classname)) @@ -207,10 +164,15 @@ Perl_sv_does(pTHX_ SV *sv, const char *name) PUSHMARK(SP); XPUSHs(sv); - XPUSHs(sv_2mortal(newSVpv(name, 0))); + mXPUSHs(newSVpv(name, 0)); PUTBACK; - call_method("isa", G_SCALAR); + 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 */ + SvSCREAM_on(methodname); + call_sv(methodname, G_SCALAR | G_METHOD); SPAGAIN; does_it = SvTRUE( TOPs ); @@ -220,26 +182,6 @@ Perl_sv_does(pTHX_ SV *sv, const char *name) return does_it; } -regexp * -Perl_get_re_arg( pTHX_ SV *sv, U32 flags, MAGIC **mgp) { - MAGIC *mg; - if (sv) { - if (SvMAGICAL(sv)) - mg_get(sv); - if (SvROK(sv) && - (sv = (SV*)SvRV(sv)) && /* assign deliberate */ - SvTYPE(sv) == SVt_PVMG && - (mg = mg_find(sv, PERL_MAGIC_qr))) /* assign deliberate */ - { - if (mgp) *mgp = mg; - return (regexp *)mg->mg_obj; - } - } - if (mgp) *mgp = NULL; - return ((flags && PL_curpm) ? PM_GETRE(PL_curpm) : NULL); -} - - PERL_XS_EXPORT_C void XS_UNIVERSAL_isa(pTHX_ CV *cv); PERL_XS_EXPORT_C void XS_UNIVERSAL_can(pTHX_ CV *cv); PERL_XS_EXPORT_C void XS_UNIVERSAL_DOES(pTHX_ CV *cv); @@ -275,11 +217,19 @@ XS(XS_Internals_rehash_seed); XS(XS_Internals_HvREHASH); XS(XS_Internals_inc_sub_generation); XS(XS_re_is_regexp); -XS(XS_re_regname); -XS(XS_re_regnames); -XS(XS_re_regnames_iterinit); -XS(XS_re_regnames_iternext); +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); +XS(XS_Tie_Hash_NamedCapture_CLEAR); +XS(XS_Tie_Hash_NamedCapture_EXISTS); +XS(XS_Tie_Hash_NamedCapture_FIRSTK); +XS(XS_Tie_Hash_NamedCapture_NEXTK); +XS(XS_Tie_Hash_NamedCapture_SCALAR); +XS(XS_Tie_Hash_NamedCapture_flags); void Perl_boot_core_UNIVERSAL(pTHX) @@ -330,25 +280,66 @@ Perl_boot_core_UNIVERSAL(pTHX) 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, "\\%"); - newXSproto("Internals::inc_sub_generation",XS_Internals_inc_sub_generation, - file, ""); newXSproto("re::is_regexp", XS_re_is_regexp, file, "$"); - newXSproto("re::regname", XS_re_regname, file, ";$$$"); - newXSproto("re::regnames", XS_re_regnames, file, ";$$"); - newXSproto("re::regnames_iterinit", XS_re_regnames_iterinit, file, ";$"); - newXSproto("re::regnames_iternext", XS_re_regnames_iternext, file, ";$$"); - newXSproto("re::regnames_count", XS_re_regnames_count, file, ";$"); + 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); + newXS("Tie::Hash::NamedCapture::CLEAR", XS_Tie_Hash_NamedCapture_CLEAR, file); + newXS("Tie::Hash::NamedCapture::EXISTS", XS_Tie_Hash_NamedCapture_EXISTS, file); + newXS("Tie::Hash::NamedCapture::FIRSTKEY", XS_Tie_Hash_NamedCapture_FIRSTK, file); + newXS("Tie::Hash::NamedCapture::NEXTKEY", XS_Tie_Hash_NamedCapture_NEXTK, file); + newXS("Tie::Hash::NamedCapture::SCALAR", XS_Tie_Hash_NamedCapture_SCALAR, file); + 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; @@ -374,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); @@ -416,7 +406,7 @@ XS(XS_UNIVERSAL_DOES) PERL_UNUSED_ARG(cv); if (items != 2) - Perl_croak(aTHX_ "Usage: invocant->does(kind)"); + Perl_croak(aTHX_ "Usage: invocant->DOES(kind)"); else { SV * const sv = ST(0); const char *name; @@ -495,15 +485,15 @@ XS(XS_UNIVERSAL_VERSION) } else { Perl_croak(aTHX_ "%s version %"SVf" required--" "this is only version %"SVf"", HvNAME_get(pkg), - SVfARG(vnumify(req)), - SVfARG(vnumify(sv))); + SVfARG(vstringify(req)), + SVfARG(vstringify(sv))); } } } if ( SvOK(sv) && sv_derived_from(sv, "version") ) { - ST(0) = vnumify(sv); + ST(0) = vstringify(sv); } else { ST(0) = sv; } @@ -515,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); @@ -541,7 +530,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; } @@ -551,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; @@ -564,7 +552,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; @@ -575,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; @@ -588,7 +575,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; @@ -599,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; @@ -612,7 +598,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; @@ -623,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; @@ -657,7 +642,7 @@ XS(XS_version_vcmp) rs = newSViv(vcmp(lobj,rvs)); } - PUSHs(sv_2mortal(rs)); + mPUSHs(rs); } PUTBACK; @@ -669,14 +654,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; } @@ -688,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 @@ -704,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); @@ -725,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); @@ -739,7 +720,7 @@ XS(XS_version_qv) } else { - PUSHs(sv_2mortal(new_version(ver))); + mPUSHs(new_version(ver)); } PUTBACK; @@ -751,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)) @@ -768,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; @@ -787,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; } @@ -798,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); @@ -814,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; @@ -832,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)); @@ -851,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); @@ -865,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); @@ -922,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); @@ -943,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; @@ -1003,7 +974,6 @@ XS(XS_PerlIO_get_layers) } if (gv && (io = GvIO(gv))) { - dTARGET; AV* const av = PerlIO_get_layers(aTHX_ input ? IoIFP(io) : IoOFP(io)); I32 i; @@ -1020,26 +990,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++; @@ -1047,7 +1022,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++; } } @@ -1103,280 +1078,461 @@ XS(XS_Internals_HvREHASH) /* Subject to change */ Perl_croak(aTHX_ "Internals::HvREHASH $hashref"); } -XS(XS_Internals_inc_sub_generation) +XS(XS_re_is_regexp) { - dVAR; - /* Using dXSARGS would also have dITEM and dSP, - * which define 2 unused local variables. */ - dAXMARK; - PERL_UNUSED_ARG(cv); - PERL_UNUSED_VAR(mark); - ++PL_sub_generation; - XSRETURN_EMPTY; + dVAR; + dXSARGS; + PERL_UNUSED_VAR(cv); + + if (items != 1) + croak_xs_usage(cv, "sv"); + + SP -= items; + + if (SvRXOK(ST(0))) { + XSRETURN_YES; + } else { + XSRETURN_NO; + } } -XS(XS_re_is_regexp) +XS(XS_re_regnames_count) { + REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + SV * ret; dVAR; dXSARGS; - if (items != 1) - Perl_croak(aTHX_ "Usage: %s(%s)", "re::is_regexp", "sv"); - PERL_UNUSED_VAR(cv); /* -W */ - PERL_UNUSED_VAR(ax); /* -Wall */ + + if (items != 0) + croak_xs_usage(cv, ""); + SP -= items; - { - SV * sv = ST(0); - if ( Perl_get_re_arg( aTHX_ sv, 0, NULL ) ) - { - XSRETURN_YES; - } else { - XSRETURN_NO; - } - /* NOTREACHED */ - PUTBACK; - return; + + if (!rx) + XSRETURN_UNDEF; + + ret = CALLREG_NAMED_BUFF_COUNT(rx); + + SPAGAIN; + + if (ret) { + mXPUSHs(ret); + PUTBACK; + return; + } else { + XSRETURN_UNDEF; } } XS(XS_re_regname) { + dVAR; + dXSARGS; + REGEXP * rx; + U32 flags; + SV * ret; - dVAR; + if (items < 1 || items > 2) + croak_xs_usage(cv, "name[, all ]"); + + SP -= items; + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) + XSRETURN_UNDEF; + + if (items == 2 && SvTRUE(ST(1))) { + flags = RXapif_ALL; + } else { + flags = RXapif_ONE; + } + ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(0), (flags | RXapif_REGNAME)); + + if (ret) { + mXPUSHs(ret); + XSRETURN(1); + } + XSRETURN_UNDEF; +} + + +XS(XS_re_regnames) +{ + dVAR; dXSARGS; - if (items < 1 || items > 3) - Perl_croak(aTHX_ "Usage: %s(%s)", "re::regname", "sv, qr = NULL, all = NULL"); - PERL_UNUSED_VAR(cv); /* -W */ - PERL_UNUSED_VAR(ax); /* -Wall */ + REGEXP * rx; + U32 flags; + SV *ret; + AV *av; + I32 length; + I32 i; + SV **entry; + + if (items > 1) + croak_xs_usage(cv, "[all]"); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) + XSRETURN_UNDEF; + + if (items == 1 && SvTRUE(ST(0))) { + flags = RXapif_ALL; + } else { + flags = RXapif_ONE; + } + SP -= items; - { - SV * sv = ST(0); - SV * qr; - SV * all; - regexp *re = NULL; - SV *bufs = NULL; - - if (items < 2) - qr = NULL; - else { - qr = ST(1); - } - if (items < 3) - all = NULL; - else { - all = ST(2); - } - { - re = Perl_get_re_arg( aTHX_ qr, 1, NULL); - if (SvPOK(sv) && re && re->paren_names) { - bufs = CALLREG_NAMEDBUF(re,sv,all && SvTRUE(all)); - if (bufs) { - if (all && SvTRUE(all)) - XPUSHs(newRV(bufs)); - else - XPUSHs(SvREFCNT_inc(bufs)); - XSRETURN(1); + ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES)); + + SPAGAIN; + + SP -= items; + + if (!ret) + XSRETURN_UNDEF; + + av = (AV*)SvRV(ret); + length = av_len(av); + + for (i = 0; i <= length; i++) { + entry = av_fetch(av, i, FALSE); + + if (!entry) + Perl_croak(aTHX_ "NULL array element in re::regnames()"); + + 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; } - PUTBACK; - return; } + /* NOT-REACHED */ } -XS(XS_re_regnames) +XS(XS_Tie_Hash_NamedCapture_FETCH) { - dVAR; + dVAR; dXSARGS; - if (items < 0 || items > 2) - Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames", "sv = NULL, all = NULL"); - PERL_UNUSED_VAR(cv); /* -W */ - PERL_UNUSED_VAR(ax); /* -Wall */ + REGEXP * rx; + U32 flags; + SV * ret; + + if (items != 2) + croak_xs_usage(cv, "$key, $flags"); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) + XSRETURN_UNDEF; + SP -= items; - { - SV * sv; - SV * all; - regexp *re = NULL; - IV count = 0; - if (items < 1) - sv = NULL; - else { - sv = ST(0); - } + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + ret = CALLREG_NAMED_BUFF_FETCH(rx, ST(1), flags); - if (items < 2) - all = NULL; - else { - all = ST(1); - } - { - re = Perl_get_re_arg( aTHX_ sv, 1, NULL ); - if (re && re->paren_names) { - HV *hv= re->paren_names; - (void)hv_iterinit(hv); - while (1) { - HE *temphe = hv_iternext_flags(hv,0); - if (temphe) { - IV i; - IV parno = 0; - SV* sv_dat = HeVAL(temphe); - I32 *nums = (I32*)SvPVX(sv_dat); - for ( i = 0; i < SvIVX(sv_dat); i++ ) { - if ((I32)(re->lastcloseparen) >= nums[i] && - re->startp[nums[i]] != -1 && - re->endp[nums[i]] != -1) - { - parno = nums[i]; - break; - } - } - if (parno || (all && SvTRUE(all))) { - STRLEN len; - char *pv = HePV(temphe, len); - if ( GIMME_V == G_ARRAY ) - XPUSHs(newSVpvn(pv,len)); - count++; - } - } else { - break; - } - } - } - if ( GIMME_V == G_ARRAY ) - XSRETURN(count); - else - XSRETURN_UNDEF; - } - PUTBACK; - return; + SPAGAIN; + + if (ret) { + mXPUSHs(ret); + PUTBACK; + return; } + XSRETURN_UNDEF; } +XS(XS_Tie_Hash_NamedCapture_STORE) +{ + dVAR; + dXSARGS; + REGEXP * rx; + U32 flags; + + if (items != 3) + croak_xs_usage(cv, "$key, $value, $flags"); -XS(XS_re_regnames_iterinit) + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) { + if (!PL_localizing) + Perl_croak(aTHX_ PL_no_modify); + else + XSRETURN_UNDEF; + } + + SP -= items; + + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + CALLREG_NAMED_BUFF_STORE(rx,ST(1), ST(2), flags); +} + +XS(XS_Tie_Hash_NamedCapture_DELETE) { - dVAR; + dVAR; dXSARGS; - if (items < 0 || items > 1) - Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iterinit", "sv = NULL"); - PERL_UNUSED_VAR(cv); /* -W */ - PERL_UNUSED_VAR(ax); /* -Wall */ + REGEXP * rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + U32 flags; + + if (items != 2) + croak_xs_usage(cv, "$key, $flags"); + + if (!rx) + Perl_croak(aTHX_ PL_no_modify); + SP -= items; - { - SV * sv; - regexp *re = NULL; - if (items < 1) - sv = NULL; - else { - sv = ST(0); - } - { - re = Perl_get_re_arg( aTHX_ sv, 1, NULL ); - if (re && re->paren_names) { - (void)hv_iterinit(re->paren_names); - XPUSHs(newSViv(HvTOTALKEYS(re->paren_names))); - } else { - XSRETURN_UNDEF; - } - } - PUTBACK; - return; - } + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + CALLREG_NAMED_BUFF_DELETE(rx, ST(1), flags); } +XS(XS_Tie_Hash_NamedCapture_CLEAR) +{ + dVAR; + dXSARGS; + REGEXP * rx; + U32 flags; + + if (items != 1) + croak_xs_usage(cv, "$flags"); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; -XS(XS_re_regnames_iternext) + if (!rx) + Perl_croak(aTHX_ PL_no_modify); + + SP -= items; + + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + CALLREG_NAMED_BUFF_CLEAR(rx, flags); +} + +XS(XS_Tie_Hash_NamedCapture_EXISTS) { - dVAR; + dVAR; dXSARGS; - if (items < 0 || items > 2) - Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_iternext", "sv = NULL, all = NULL"); - PERL_UNUSED_VAR(cv); /* -W */ - PERL_UNUSED_VAR(ax); /* -Wall */ + REGEXP * rx; + U32 flags; + SV * ret; + + if (items != 2) + croak_xs_usage(cv, "$key, $flags"); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) + XSRETURN_UNDEF; + SP -= items; - { - SV * sv; - SV * all; - regexp *re; - if (items < 1) - sv = NULL; - else { - sv = ST(0); - } + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + ret = CALLREG_NAMED_BUFF_EXISTS(rx, ST(1), flags); - if (items < 2) - all = NULL; - else { - all = ST(1); - } - { - re = Perl_get_re_arg( aTHX_ sv, 1, NULL ); - if (re && re->paren_names) { - HV *hv= re->paren_names; - while (1) { - HE *temphe = hv_iternext_flags(hv,0); - if (temphe) { - IV i; - IV parno = 0; - SV* sv_dat = HeVAL(temphe); - I32 *nums = (I32*)SvPVX(sv_dat); - for ( i = 0; i < SvIVX(sv_dat); i++ ) { - if ((I32)(re->lastcloseparen) >= nums[i] && - re->startp[nums[i]] != -1 && - re->endp[nums[i]] != -1) - { - parno = nums[i]; - break; - } - } - if (parno || (all && SvTRUE(all))) { - STRLEN len; - char *pv = HePV(temphe, len); - XPUSHs(newSVpvn(pv,len)); - XSRETURN(1); - } - } else { - break; - } - } - } - XSRETURN_UNDEF; - } + SPAGAIN; + + XPUSHs(ret); PUTBACK; return; - } } - -XS(XS_re_regnames_count) +XS(XS_Tie_Hash_NamedCapture_FIRSTK) { - SV * sv; - regexp *re = NULL; - dVAR; + dVAR; dXSARGS; + REGEXP * rx; + U32 flags; + SV * ret; + + if (items != 1) + croak_xs_usage(cv, ""); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) + XSRETURN_UNDEF; - if (items < 0 || items > 1) - Perl_croak(aTHX_ "Usage: %s(%s)", "re::regnames_count", "sv = NULL"); - PERL_UNUSED_VAR(cv); /* -W */ - PERL_UNUSED_VAR(ax); /* -Wall */ SP -= items; - if (items < 1) - sv = NULL; - else { - sv = ST(0); + + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + ret = CALLREG_NAMED_BUFF_FIRSTKEY(rx, flags); + + SPAGAIN; + + if (ret) { + mXPUSHs(ret); + PUTBACK; + } else { + XSRETURN_UNDEF; } - re = Perl_get_re_arg( aTHX_ sv, 1, NULL ); - if (re && re->paren_names) { - XPUSHs(newSViv(HvTOTALKEYS(re->paren_names))); + +} + +XS(XS_Tie_Hash_NamedCapture_NEXTK) +{ + dVAR; + dXSARGS; + REGEXP * rx; + U32 flags; + SV * ret; + + if (items != 2) + croak_xs_usage(cv, "$lastkey"); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) + XSRETURN_UNDEF; + + SP -= items; + + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + ret = CALLREG_NAMED_BUFF_NEXTKEY(rx, ST(1), flags); + + SPAGAIN; + + if (ret) { + mXPUSHs(ret); } else { XSRETURN_UNDEF; } PUTBACK; - return; +} + +XS(XS_Tie_Hash_NamedCapture_SCALAR) +{ + dVAR; + dXSARGS; + REGEXP * rx; + U32 flags; + SV * ret; + + if (items != 1) + croak_xs_usage(cv, ""); + + rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + + if (!rx) + XSRETURN_UNDEF; + + SP -= items; + + flags = (U32)INT2PTR(IV,SvIV(SvRV((SV*)ST(0)))); + ret = CALLREG_NAMED_BUFF_SCALAR(rx, flags); + + SPAGAIN; + + if (ret) { + mXPUSHs(ret); + PUTBACK; + return; + } else { + XSRETURN_UNDEF; + } +} + +XS(XS_Tie_Hash_NamedCapture_flags) +{ + dVAR; + dXSARGS; + + if (items != 0) + croak_xs_usage(cv, ""); + + mXPUSHu(RXapif_ONE); + mXPUSHu(RXapif_ALL); + PUTBACK; + return; }