X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/f1f66076265cc2bac3adabd54c01b0dea28ca3f0..636a19183afddcfee3e377f79668687caee21a8f:/universal.c diff --git a/universal.c b/universal.c index 40b0eae..4da6fc5 100644 --- a/universal.c +++ b/universal.c @@ -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 @@ -31,6 +33,41 @@ #include "perliol.h" /* For the PERLIO_F_XXX */ #endif +static HV * +S_get_isa_hash(pTHX_ HV *const stash) +{ + dVAR; + struct mro_meta *const meta = HvMROMETA(stash); + + PERL_ARGS_ASSERT_GET_ISA_HASH; + + if (!meta->isa) { + AV *const isa = mro_get_linear_isa(stash); + if (!meta->isa) { + HV *const isa_hash = newHV(); + /* Linearisation didn't build it for us, so do it here. */ + SV *const *svp = AvARRAY(isa); + SV *const *const svp_end = svp + AvFILLp(isa) + 1; + const HEK *const canon_name = HvNAME_HEK(stash); + + while (svp < svp_end) { + (void) hv_store_ent(isa_hash, *svp++, &PL_sv_undef, 0); + } + + (void) hv_common(isa_hash, NULL, HEK_KEY(canon_name), + HEK_LEN(canon_name), HEK_FLAGS(canon_name), + HV_FETCH_ISSTORE, &PL_sv_undef, + HEK_HASH(canon_name)); + (void) hv_store(isa_hash, "UNIVERSAL", 9, &PL_sv_undef, 0); + + SvREADONLY_on(isa_hash); + + meta->isa = isa_hash; + } + } + return meta->isa; +} + /* * Contributed by Graham Barr * The main guts of traverse_isa was actually copied from gv_fetchmeth @@ -41,7 +78,7 @@ S_isa_lookup(pTHX_ HV *stash, const char * const name) { dVAR; const struct mro_meta *const meta = HvMROMETA(stash); - HV *const isa = meta->isa ? meta->isa : Perl_get_isa_hash(aTHX_ stash); + HV *const isa = meta->isa ? meta->isa : S_get_isa_hash(aTHX_ stash); STRLEN len = strlen(name); const HV *our_stash; @@ -184,6 +221,7 @@ XS(XS_version_noop); #endif XS(XS_version_is_alpha); XS(XS_version_qv); +XS(XS_version_is_qv); XS(XS_utf8_is_utf8); XS(XS_utf8_valid); XS(XS_utf8_encode); @@ -196,11 +234,9 @@ 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); XS(XS_re_is_regexp); XS(XS_re_regname); XS(XS_re_regnames); @@ -232,6 +268,7 @@ Perl_boot_core_UNIVERSAL(pTHX) /* Make it findable via fetchmethod */ newXS("version::()", XS_version_noop, file); newXS("version::new", XS_version_new, file); + newXS("version::parse", XS_version_new, file); newXS("version::(\"\"", XS_version_stringify, file); newXS("version::stringify", XS_version_stringify, file); newXS("version::(0+", XS_version_numify, file); @@ -246,6 +283,8 @@ Perl_boot_core_UNIVERSAL(pTHX) newXS("version::noop", XS_version_noop, file); newXS("version::is_alpha", XS_version_is_alpha, file); newXS("version::qv", XS_version_qv, file); + newXS("version::declare", XS_version_qv, file); + newXS("version::is_qv", XS_version_is_qv, file); } newXS("utf8::is_utf8", XS_utf8_is_utf8, file); newXS("utf8::valid", XS_utf8_valid, file); @@ -261,7 +300,9 @@ 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); + /* Providing a Regexp::DESTROY fixes #21347. See test in t/op/ref.t */ + CvFILE(newCONSTSUB(get_hv("Regexp::", GV_ADD), "DESTROY", NULL)) + = (char *)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, "\\%"); @@ -692,25 +733,54 @@ XS(XS_version_qv) { dVAR; dXSARGS; - if (items != 1) - croak_xs_usage(cv, "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 rv = sv_newmortal(); + SV * ver = ST(0); + SV * rv; + const char * classname = ""; + if ( items == 2 && (ST(1)) != &PL_sv_undef ) { + /* 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)); + } + if ( !SvVOK(ver) ) { /* not already a v-string */ + rv = sv_newmortal(); sv_setsv(rv,ver); /* make a duplicate */ upg_version(rv, TRUE); - PUSHs(rv); + } else { + rv = sv_2mortal(new_version(ver)); } - else - { - mPUSHs(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")) { + 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) @@ -890,12 +960,6 @@ XS(XS_Internals_hv_clear_placehold) } } -XS(XS_Regexp_DESTROY) -{ - PERL_UNUSED_CONTEXT; - PERL_UNUSED_ARG(cv); -} - XS(XS_PerlIO_get_layers) { dVAR; @@ -988,7 +1052,7 @@ XS(XS_PerlIO_get_layers) (SvUTF8(*argsvp) ? SVf_UTF8 : 0) | SVs_TEMP) : &PL_sv_undef); - XPUSHs(namok + XPUSHs(flgok ? sv_2mortal(SvREFCNT_inc_simple_NN(*flgsvp)) : &PL_sv_undef); nitem += 3;