X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/cbc021f9c76c5db718d993d3cc885284fbbff80f..16eb5365105fd7ab1815c325059d04765892205f:/universal.c diff --git a/universal.c b/universal.c index 7cbaaf7..35d1bcc 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, 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,13 +9,20 @@ */ /* - * "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 * 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 separate XS files which would then be pulled + * in by some to-be-written build process. */ #include "EXTERN.h" @@ -32,96 +39,44 @@ */ STATIC bool -S_isa_lookup(pTHX_ HV *stash, const char *name, HV* name_stash, - int len, int level) +S_isa_lookup(pTHX_ HV *stash, const char * const name) { dVAR; - AV* av; - GV* gv; - GV** gvp; - HV* hv = NULL; - SV* subgen = NULL; - const char *hvname; - - /* A stash/class can go by many names (ie. User == main::User), so - we compare the stash itself just in case */ - if (name_stash && (stash == name_stash)) - return TRUE; + const struct mro_meta *const meta = HvMROMETA(stash); + HV *isa = meta->isa; + STRLEN len = strlen(name); + const HV *our_stash; - hvname = HvNAME_get(stash); + PERL_ARGS_ASSERT_ISA_LOOKUP; - if (strEQ(hvname, name)) - return TRUE; + if (!isa) { + (void)mro_get_linear_isa(stash); + isa = meta->isa; + } - if (strEQ(name, "UNIVERSAL")) + 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 (level > 100) - Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", - hvname); - - gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", FALSE); - - if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (subgen = GvSV(gv)) - && (hv = GvHV(gv))) - { - if (SvIV(subgen) == (IV)PL_sub_generation) { - SV* sv; - SV** const svp = (SV**)hv_fetch(hv, name, len, FALSE); - if (svp && (sv = *svp) != (SV*)&PL_sv_undef) { - DEBUG_o( Perl_deb(aTHX_ "Using cached ISA %s for package %s\n", - name, hvname) ); - 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); - } } - gvp = (GV**)hv_fetchs(stash, "ISA", FALSE); - - if (gvp && (gv = *gvp) != (GV*)&PL_sv_undef && (av = GvAV(gv))) { - if (!hv || !subgen) { - gvp = (GV**)hv_fetchs(stash, "::ISA::CACHE::", TRUE); - - gv = *gvp; + /* A stash/class can go by many names (ie. User == main::User), so + we use the HvENAME in the stash itself, which is canonical, falling + back to HvNAME if necessary. */ + our_stash = gv_stashpvn(name, len, 0); - if (SvTYPE(gv) != SVt_PVGV) - gv_init(gv, stash, "::ISA::CACHE::", 14, TRUE); + if (our_stash) { + HEK *canon_name = HvENAME_HEK(our_stash); + if (!canon_name) canon_name = HvNAME_HEK(our_stash); - 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, FALSE); - if (!basestash) { - if (ckWARN(WARN_MISC)) - Perl_warner(aTHX_ packWARN(WARN_SYNTAX), - "Can't locate package %"SVf" for @%s::ISA", - (void*)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); + 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; } @@ -138,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)) { @@ -154,16 +111,10 @@ Perl_sv_derived_from(pTHX_ SV *sv, const char *name) stash = SvOBJECT(sv) ? SvSTASH(sv) : NULL; } else { - stash = gv_stashsv(sv, FALSE); + stash = gv_stashsv(sv, 0); } - if (stash) { - HV * const name_stash = gv_stashpv(name, FALSE); - return isa_lookup(stash, name, name_stash, strlen(name), 0); - } - else - return FALSE; - + return stash ? isa_lookup(stash, name) : FALSE; } /* @@ -178,36 +129,48 @@ 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; SvGETMAGIC(sv); if (!SvOK(sv) || !(SvROK(sv) || (SvPOK(sv) && SvCUR(sv)) - || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) + || (SvGMAGICAL(sv) && SvPOKp(sv) && SvCUR(sv)))) { + LEAVE; return FALSE; + } if (sv_isobject(sv)) { classname = sv_reftype(SvRV(sv),TRUE); } else { - classname = SvPV(sv,PL_na); + classname = SvPV_nolen(sv); } - if (strEQ(name,classname)) + if (strEQ(name,classname)) { + LEAVE; return TRUE; + } 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 ); @@ -217,102 +180,50 @@ Perl_sv_does(pTHX_ SV *sv, const char *name) return does_it; } -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); -PERL_XS_EXPORT_C void XS_UNIVERSAL_VERSION(pTHX_ CV *cv); -XS(XS_version_new); -XS(XS_version_stringify); -XS(XS_version_numify); -XS(XS_version_normal); -XS(XS_version_vcmp); -XS(XS_version_boolean); -#ifdef HASATTRIBUTE_NORETURN -XS(XS_version_noop) __attribute__noreturn__; -#else -XS(XS_version_noop); -#endif -XS(XS_version_is_alpha); -XS(XS_version_qv); -XS(XS_utf8_is_utf8); -XS(XS_utf8_valid); -XS(XS_utf8_encode); -XS(XS_utf8_decode); -XS(XS_utf8_upgrade); -XS(XS_utf8_downgrade); -XS(XS_utf8_unicode_to_native); -XS(XS_utf8_native_to_unicode); -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); -XS(XS_Internals_inc_sub_generation); +/* +=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_boot_core_UNIVERSAL(pTHX) +Perl_croak_xs_usage(pTHX_ const CV *const cv, const char *const params) { - dVAR; - static const char file[] = __FILE__; + const GV *const gv = CvGV(cv); - newXS("UNIVERSAL::isa", XS_UNIVERSAL_isa, file); - newXS("UNIVERSAL::can", XS_UNIVERSAL_can, file); - newXS("UNIVERSAL::DOES", XS_UNIVERSAL_DOES, file); - newXS("UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, file); - { - /* register the overloading (type 'A') magic */ - PL_amagic_generation++; - /* Make it findable via fetchmethod */ - newXS("version::()", XS_version_noop, file); - newXS("version::new", XS_version_new, file); - newXS("version::(\"\"", XS_version_stringify, file); - newXS("version::stringify", XS_version_stringify, file); - newXS("version::(0+", XS_version_numify, file); - newXS("version::numify", XS_version_numify, file); - newXS("version::normal", XS_version_normal, file); - newXS("version::(cmp", XS_version_vcmp, file); - newXS("version::(<=>", XS_version_vcmp, file); - newXS("version::vcmp", XS_version_vcmp, file); - newXS("version::(bool", XS_version_boolean, file); - newXS("version::boolean", XS_version_boolean, file); - newXS("version::(nomethod", XS_version_noop, file); - newXS("version::noop", XS_version_noop, file); - newXS("version::is_alpha", XS_version_is_alpha, file); - newXS("version::qv", XS_version_qv, file); + 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); } - newXS("utf8::is_utf8", XS_utf8_is_utf8, file); - newXS("utf8::valid", XS_utf8_valid, file); - newXS("utf8::encode", XS_utf8_encode, file); - newXS("utf8::decode", XS_utf8_decode, file); - newXS("utf8::upgrade", XS_utf8_upgrade, file); - newXS("utf8::downgrade", XS_utf8_downgrade, file); - newXS("utf8::native_to_unicode", XS_utf8_native_to_unicode, file); - newXS("utf8::unicode_to_native", XS_utf8_unicode_to_native, file); - newXSproto("Internals::SvREADONLY",XS_Internals_SvREADONLY, file, "\\[$%@];$"); - newXSproto("Internals::SvREFCNT",XS_Internals_SvREFCNT, file, "\\[$%@];$"); - newXSproto("Internals::hv_clear_placeholders", - 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, "\\%"); - newXSproto("Internals::inc_sub_generation",XS_Internals_inc_sub_generation, - file, ""); } - XS(XS_UNIVERSAL_isa) { dVAR; dXSARGS; 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; @@ -340,7 +251,7 @@ XS(XS_UNIVERSAL_can) HV *pkg = NULL; if (items != 2) - Perl_croak(aTHX_ "Usage: UNIVERSAL::can(object-ref, method)"); + croak_xs_usage(cv, "object-ref, method"); sv = ST(0); @@ -354,18 +265,18 @@ 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); } else { - pkg = gv_stashsv(sv, FALSE); + pkg = gv_stashsv(sv, 0); } 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; @@ -376,9 +287,10 @@ XS(XS_UNIVERSAL_DOES) { dVAR; dXSARGS; + 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; @@ -400,15 +312,16 @@ XS(XS_UNIVERSAL_VERSION) GV *gv; SV *sv; const char *undef; + 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); } else { - pkg = gv_stashsv(ST(0), FALSE); + pkg = gv_stashsv(ST(0), 0); } gvp = pkg ? (GV**)hv_fetchs(pkg, "VERSION", FALSE) : NULL; @@ -418,11 +331,11 @@ XS(XS_UNIVERSAL_VERSION) sv_setsv(nsv, sv); sv = nsv; if ( !sv_derived_from(sv, "version")) - upg_version(sv); + upg_version(sv, FALSE); undef = NULL; } else { - sv = (SV*)&PL_sv_undef; + sv = &PL_sv_undef; undef = "(undef)"; } @@ -444,23 +357,27 @@ XS(XS_UNIVERSAL_VERSION) if ( !sv_derived_from(req, "version")) { /* req may very well be R/O, so create a new object */ - SV * const nsv = sv_newmortal(); - sv_setsv(nsv, req); - req = nsv; - upg_version(req); + req = sv_2mortal( new_version(req) ); + } + + if ( vcmp( req, sv ) > 0 ) { + 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(sv_2mortal(vnormal(req))), + SVfARG(sv_2mortal(vnormal(sv)))); + } else { + Perl_croak(aTHX_ "%s version %"SVf" required--" + "this is only version %"SVf"", HvNAME_get(pkg), + SVfARG(sv_2mortal(vstringify(req))), + SVfARG(sv_2mortal(vstringify(sv)))); + } } - if ( vcmp( req, sv ) > 0 ) - Perl_croak(aTHX_ "%s version %"SVf" (%"SVf") required--" - "this is only version %"SVf" (%"SVf")", HvNAME_get(pkg), - (void*)vnumify(req), - (void*)vnormal(req), - (void*)vnumify(sv), - (void*)vnormal(sv)); } if ( SvOK(sv) && sv_derived_from(sv, "version") ) { - ST(0) = vnumify(sv); + ST(0) = sv_2mortal(vstringify(sv)); } else { ST(0) = sv; } @@ -473,7 +390,7 @@ XS(XS_version_new) dVAR; dXSARGS; if (items > 3) - Perl_croak(aTHX_ "Usage: version::new(class, version)"); + croak_xs_usage(cv, "class, version"); SP -= items; { SV *vs = ST(1); @@ -483,10 +400,10 @@ XS(XS_version_new) ? HvNAME(SvSTASH(SvRV(ST(0)))) : (char *)SvPV_nolen(ST(0)); - if ( items == 1 || vs == &PL_sv_undef ) { /* no param or explicit undef */ + if ( items == 1 || ! SvOK(vs) ) { /* no param or explicit undef */ /* create empty object */ vs = sv_newmortal(); - sv_setpvn(vs,"",0); + sv_setpvs(vs, "0"); } else if ( items == 3 ) { vs = sv_newmortal(); @@ -495,9 +412,9 @@ XS(XS_version_new) rv = new_version(vs); if ( strcmp(classname,"version") != 0 ) /* inherited new() */ - sv_bless(rv, gv_stashpv(classname,TRUE)); + sv_bless(rv, gv_stashpv(classname, GV_ADD)); - PUSHs(sv_2mortal(rv)); + mPUSHs(rv); PUTBACK; return; } @@ -508,18 +425,18 @@ XS(XS_version_stringify) dVAR; dXSARGS; if (items < 1) - Perl_croak(aTHX_ "Usage: version::stringify(lobj, ...)"); + croak_xs_usage(cv, "lobj, ..."); SP -= items; { - SV * lobj; + SV * lobj = ST(0); - if (sv_derived_from(ST(0), "version")) { - lobj = SvRV(ST(0)); + if (sv_derived_from(lobj, "version") && SvROK(lobj)) { + lobj = SvRV(lobj); } else Perl_croak(aTHX_ "lobj is not of type version"); - PUSHs(sv_2mortal(vstringify(lobj))); + mPUSHs(vstringify(lobj)); PUTBACK; return; @@ -531,18 +448,18 @@ XS(XS_version_numify) dVAR; dXSARGS; if (items < 1) - Perl_croak(aTHX_ "Usage: version::numify(lobj, ...)"); + croak_xs_usage(cv, "lobj, ..."); SP -= items; { - SV * lobj; + SV * lobj = ST(0); - if (sv_derived_from(ST(0), "version")) { - lobj = SvRV(ST(0)); + if (sv_derived_from(lobj, "version") && SvROK(lobj)) { + lobj = SvRV(lobj); } else Perl_croak(aTHX_ "lobj is not of type version"); - PUSHs(sv_2mortal(vnumify(lobj))); + mPUSHs(vnumify(lobj)); PUTBACK; return; @@ -554,18 +471,18 @@ XS(XS_version_normal) dVAR; dXSARGS; if (items < 1) - Perl_croak(aTHX_ "Usage: version::normal(lobj, ...)"); + croak_xs_usage(cv, "lobj, ..."); SP -= items; { - SV * lobj; + SV * lobj = ST(0); - if (sv_derived_from(ST(0), "version")) { - lobj = SvRV(ST(0)); + if (sv_derived_from(lobj, "version") && SvROK(lobj)) { + lobj = SvRV(lobj); } else Perl_croak(aTHX_ "lobj is not of type version"); - PUSHs(sv_2mortal(vnormal(lobj))); + mPUSHs(vnormal(lobj)); PUTBACK; return; @@ -577,13 +494,13 @@ XS(XS_version_vcmp) dVAR; dXSARGS; if (items < 1) - Perl_croak(aTHX_ "Usage: version::vcmp(lobj, ...)"); + croak_xs_usage(cv, "lobj, ..."); SP -= items; { - SV * lobj; + SV * lobj = ST(0); - if (sv_derived_from(ST(0), "version")) { - lobj = SvRV(ST(0)); + if (sv_derived_from(lobj, "version") && SvROK(lobj)) { + lobj = SvRV(lobj); } else Perl_croak(aTHX_ "lobj is not of type version"); @@ -596,7 +513,8 @@ XS(XS_version_vcmp) if ( ! sv_derived_from(robj, "version") ) { - robj = new_version(robj); + robj = new_version(SvOK(robj) ? robj : newSVpvs_flags("0", SVs_TEMP)); + sv_2mortal(robj); } rvs = SvRV(robj); @@ -609,7 +527,7 @@ XS(XS_version_vcmp) rs = newSViv(vcmp(lobj,rvs)); } - PUSHs(sv_2mortal(rs)); + mPUSHs(rs); } PUTBACK; @@ -622,12 +540,12 @@ XS(XS_version_boolean) dVAR; dXSARGS; if (items < 1) - Perl_croak(aTHX_ "Usage: version::boolean(lobj, ...)"); + croak_xs_usage(cv, "lobj, ..."); SP -= items; - if (sv_derived_from(ST(0), "version")) { + if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) { SV * const lobj = SvRV(ST(0)); SV * const rs = newSViv( vcmp(lobj,new_version(newSVpvs("0"))) ); - PUSHs(sv_2mortal(rs)); + mPUSHs(rs); PUTBACK; return; } @@ -640,8 +558,8 @@ XS(XS_version_noop) dVAR; dXSARGS; if (items < 1) - Perl_croak(aTHX_ "Usage: version::noop(lobj, ...)"); - if (sv_derived_from(ST(0), "version")) + croak_xs_usage(cv, "lobj, ..."); + if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) Perl_croak(aTHX_ "operation not supported with version object"); else Perl_croak(aTHX_ "lobj is not of type version"); @@ -655,11 +573,11 @@ XS(XS_version_is_alpha) dVAR; dXSARGS; 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")) { + if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) { 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; @@ -674,37 +592,54 @@ XS(XS_version_qv) { dVAR; dXSARGS; - if (items != 1) - Perl_croak(aTHX_ "Usage: version::qv(ver)"); + PERL_UNUSED_ARG(cv); SP -= items; { - SV * ver = ST(0); - if ( !SvVOK(ver) ) { /* only need to do with if not already v-string */ - SV * const vs = sv_newmortal(); - char *version; - if ( SvNOK(ver) ) /* may get too much accuracy */ - { - char tbuf[64]; - const STRLEN len = my_snprintf(tbuf, sizeof(tbuf), "%.9"NVgf, SvNVX(ver)); - version = savepvn(tbuf, len); - } - else - { - version = savesvpv(ver); - } - (void)scan_version(version,vs,TRUE); - Safefree(version); - - PUSHs(vs); + SV * ver = ST(0); + SV * rv; + const char * classname = ""; + if ( items == 2 && SvOK(ST(1)) ) { + /* getting called as object or class method */ + ver = ST(1); + classname = + sv_isobject(ST(0)) /* class called as an object method */ + ? HvNAME_get(SvSTASH(SvRV(ST(0)))) + : (char *)SvPV_nolen(ST(0)); } - else - { - PUSHs(sv_2mortal(new_version(ver))); + if ( !SvVOK(ver) ) { /* not already a v-string */ + rv = sv_newmortal(); + sv_setsv(rv,ver); /* make a duplicate */ + upg_version(rv, TRUE); + } else { + rv = sv_2mortal(new_version(ver)); + } + if ( items == 2 && strcmp(classname,"version") ) { /* inherited new() */ + sv_bless(rv, gv_stashpv(classname, GV_ADD)); } + PUSHs(rv); + } + PUTBACK; + return; +} +XS(XS_version_is_qv) +{ + dVAR; + dXSARGS; + if (items != 1) + croak_xs_usage(cv, "lobj"); + SP -= items; + if (sv_derived_from(ST(0), "version") && SvROK(ST(0))) { + SV * const lobj = ST(0); + if ( hv_exists(MUTABLE_HV(SvRV(lobj)), "qv", 2 ) ) + XSRETURN_YES; + else + XSRETURN_NO; PUTBACK; return; } + else + Perl_croak(aTHX_ "lobj is not of type version"); } XS(XS_utf8_is_utf8) @@ -712,9 +647,10 @@ XS(XS_utf8_is_utf8) dVAR; dXSARGS; if (items != 1) - Perl_croak(aTHX_ "Usage: utf8::is_utf8(sv)"); + croak_xs_usage(cv, "sv"); else { - const SV * const sv = ST(0); + SV * const sv = ST(0); + SvGETMAGIC(sv); if (SvUTF8(sv)) XSRETURN_YES; else @@ -728,7 +664,7 @@ XS(XS_utf8_valid) dVAR; dXSARGS; if (items != 1) - Perl_croak(aTHX_ "Usage: utf8::valid(sv)"); + croak_xs_usage(cv, "sv"); else { SV * const sv = ST(0); STRLEN len; @@ -746,7 +682,7 @@ XS(XS_utf8_encode) dVAR; dXSARGS; if (items != 1) - Perl_croak(aTHX_ "Usage: utf8::encode(sv)"); + croak_xs_usage(cv, "sv"); sv_utf8_encode(ST(0)); XSRETURN_EMPTY; } @@ -756,12 +692,13 @@ XS(XS_utf8_decode) dVAR; dXSARGS; 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); + bool RETVAL; + if (SvIsCOW(sv)) sv_force_normal(sv); + RETVAL = sv_utf8_decode(sv); ST(0) = boolSV(RETVAL); - sv_2mortal(ST(0)); } XSRETURN(1); } @@ -771,7 +708,7 @@ XS(XS_utf8_upgrade) dVAR; dXSARGS; if (items != 1) - Perl_croak(aTHX_ "Usage: utf8::upgrade(sv)"); + croak_xs_usage(cv, "sv"); else { SV * const sv = ST(0); STRLEN RETVAL; @@ -788,14 +725,13 @@ XS(XS_utf8_downgrade) dVAR; dXSARGS; 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)); const bool RETVAL = sv_utf8_downgrade(sv, failok); ST(0) = boolSV(RETVAL); - sv_2mortal(ST(0)); } XSRETURN(1); } @@ -807,7 +743,7 @@ XS(XS_utf8_native_to_unicode) const UV uv = SvUV(ST(0)); 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); @@ -820,7 +756,7 @@ XS(XS_utf8_unicode_to_native) const UV uv = SvUV(ST(0)); 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); @@ -830,7 +766,15 @@ XS(XS_Internals_SvREADONLY) /* This is dangerous stuff. */ { dVAR; dXSARGS; - SV * const sv = SvRV(ST(0)); + SV * const svz = ST(0); + SV * sv; + PERL_UNUSED_ARG(cv); + + /* [perl #77776] - called as &foo() not foo() */ + if (!SvROK(svz)) + croak_xs_usage(cv, "SCALAR[, ON]"); + + sv = SvRV(svz); if (items == 1) { if (SvREADONLY(sv)) @@ -856,7 +800,15 @@ XS(XS_Internals_SvREFCNT) /* This is dangerous stuff. */ { dVAR; dXSARGS; - SV * const sv = SvRV(ST(0)); + SV * const svz = ST(0); + SV * sv; + PERL_UNUSED_ARG(cv); + + /* [perl #77776] - called as &foo() not foo() */ + if (!SvROK(svz)) + croak_xs_usage(cv, "SCALAR[, REFCOUNT]"); + + sv = SvRV(svz); if (items == 1) XSRETURN_IV(SvREFCNT(sv) - 1); /* Minus the ref created for us. */ @@ -873,27 +825,21 @@ XS(XS_Internals_hv_clear_placehold) dVAR; dXSARGS; - if (items != 1) - Perl_croak(aTHX_ "Usage: UNIVERSAL::hv_clear_placeholders(hv)"); + if (items != 1 || !SvROK(ST(0))) + 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; 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; @@ -941,17 +887,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; @@ -968,26 +913,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(flgok + ? 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")", - (void*)*namsvp, - (void*)*argsvp)); + XPUSHs(sv_2mortal(Perl_newSVpvf(aTHX_ "%"SVf"(%"SVf")", + SVfARG(*namsvp), + SVfARG(*argsvp)))); else if (namok) - XPUSHs(Perl_newSVpvf(aTHX_ "%"SVf, - (void*)*namsvp)); + XPUSHs(sv_2mortal(SvREFCNT_inc_simple_NN(*namsvp))); else XPUSHs(&PL_sv_undef); nitem++; @@ -995,7 +945,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++; } } @@ -1038,8 +988,9 @@ 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)); + const HV * const hv = (const HV *) SvRV(ST(0)); if (items == 1 && SvTYPE(hv) == SVt_PVHV) { if (HvREHASH(hv)) XSRETURN_YES; @@ -1050,16 +1001,302 @@ 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; + dXSARGS; + PERL_UNUSED_VAR(cv); + + if (items != 1) + croak_xs_usage(cv, "sv"); + + if (SvRXOK(ST(0))) { + XSRETURN_YES; + } else { + XSRETURN_NO; + } +} + +XS(XS_re_regnames_count) +{ + REGEXP *rx = PL_curpm ? PM_GETRE(PL_curpm) : NULL; + SV * ret; + dVAR; + dXSARGS; + + if (items != 0) + croak_xs_usage(cv, ""); + + SP -= items; + PUTBACK; + + if (!rx) + XSRETURN_UNDEF; + + ret = CALLREG_NAMED_BUFF_COUNT(rx); + + SPAGAIN; + PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); + XSRETURN(1); +} + +XS(XS_re_regname) { 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; + dXSARGS; + REGEXP * rx; + U32 flags; + SV * ret; + + if (items < 1 || items > 2) + croak_xs_usage(cv, "name[, all ]"); + + SP -= items; + PUTBACK; + + 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)); + + SPAGAIN; + PUSHs(ret ? sv_2mortal(ret) : &PL_sv_undef); + XSRETURN(1); +} + + +XS(XS_re_regnames) +{ + dVAR; + dXSARGS; + 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; + PUTBACK; + + ret = CALLREG_NAMED_BUFF_ALL(rx, (flags | RXapif_REGNAMES)); + + SPAGAIN; + + if (!ret) + XSRETURN_UNDEF; + + av = MUTABLE_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 stringification overloads + on the object. + */ + + if ((re = SvRX(ST(0)))) /* assign deliberate */ + { + /* Houston, we have a regex! */ + SV *pattern; + + if ( GIMME_V == G_ARRAY ) { + STRLEN left = 0; + char reflags[sizeof(INT_PAT_MODS) + MAX_CHARSET_NAME_LENGTH]; + const char *fptr; + char ch; + U16 match_flags; + + /* + we are in list context so stringify + the modifiers that apply. We ignore "negative + modifiers" in this scenario, and the default character set + */ + + if (get_regex_charset(RX_EXTFLAGS(re)) != REGEX_DEPENDS_CHARSET) { + STRLEN len; + const char* const name = get_regex_charset_name(RX_EXTFLAGS(re), + &len); + Copy(name, reflags + left, len, char); + left += len; + } + fptr = INT_PAT_MODS; + match_flags = (U16)((RX_EXTFLAGS(re) & RXf_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 */ +} + +struct xsub_details { + const char *name; + XSUBADDR_t xsub; + const char *proto; +}; + +struct xsub_details details[] = { + {"UNIVERSAL::isa", XS_UNIVERSAL_isa, NULL}, + {"UNIVERSAL::can", XS_UNIVERSAL_can, NULL}, + {"UNIVERSAL::DOES", XS_UNIVERSAL_DOES, NULL}, + {"UNIVERSAL::VERSION", XS_UNIVERSAL_VERSION, NULL}, + {"version::()", XS_version_noop, NULL}, + {"version::new", XS_version_new, NULL}, + {"version::parse", XS_version_new, NULL}, + {"version::(\"\"", XS_version_stringify, NULL}, + {"version::stringify", XS_version_stringify, NULL}, + {"version::(0+", XS_version_numify, NULL}, + {"version::numify", XS_version_numify, NULL}, + {"version::normal", XS_version_normal, NULL}, + {"version::(cmp", XS_version_vcmp, NULL}, + {"version::(<=>", XS_version_vcmp, NULL}, + {"version::vcmp", XS_version_vcmp, NULL}, + {"version::(bool", XS_version_boolean, NULL}, + {"version::boolean", XS_version_boolean, NULL}, + {"version::(nomethod", XS_version_noop, NULL}, + {"version::noop", XS_version_noop, NULL}, + {"version::is_alpha", XS_version_is_alpha, NULL}, + {"version::qv", XS_version_qv, NULL}, + {"version::declare", XS_version_qv, NULL}, + {"version::is_qv", XS_version_is_qv, NULL}, + {"utf8::is_utf8", XS_utf8_is_utf8, NULL}, + {"utf8::valid", XS_utf8_valid, NULL}, + {"utf8::encode", XS_utf8_encode, NULL}, + {"utf8::decode", XS_utf8_decode, NULL}, + {"utf8::upgrade", XS_utf8_upgrade, NULL}, + {"utf8::downgrade", XS_utf8_downgrade, NULL}, + {"utf8::native_to_unicode", XS_utf8_native_to_unicode, NULL}, + {"utf8::unicode_to_native", XS_utf8_unicode_to_native, NULL}, + {"Internals::SvREADONLY", XS_Internals_SvREADONLY, "\\[$%@];$"}, + {"Internals::SvREFCNT", XS_Internals_SvREFCNT, "\\[$%@];$"}, + {"Internals::hv_clear_placeholders", XS_Internals_hv_clear_placehold, "\\%"}, + {"PerlIO::get_layers", XS_PerlIO_get_layers, "*;@"}, + {"Internals::hash_seed", XS_Internals_hash_seed, ""}, + {"Internals::rehash_seed", XS_Internals_rehash_seed, ""}, + {"Internals::HvREHASH", XS_Internals_HvREHASH, "\\%"}, + {"re::is_regexp", XS_re_is_regexp, "$"}, + {"re::regname", XS_re_regname, ";$$"}, + {"re::regnames", XS_re_regnames, ";$"}, + {"re::regnames_count", XS_re_regnames_count, ""}, + {"re::regexp_pattern", XS_re_regexp_pattern, "$"}, +}; + +void +Perl_boot_core_UNIVERSAL(pTHX) +{ + dVAR; + static const char file[] = __FILE__; + struct xsub_details *xsub = details; + const struct xsub_details *end + = details + sizeof(details) / sizeof(details[0]); + + do { + newXS_flags(xsub->name, xsub->xsub, file, xsub->proto, 0); + } while (++xsub < end); + + /* register the overloading (type 'A') magic */ + PL_amagic_generation++; + + /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */ + CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL)) + = (char *)file; } /*