*/
/*
- * "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
#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 <Graham.Barr@tiuk.ti.com>
* The main guts of traverse_isa was actually copied from gv_fetchmeth
{
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;
#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);
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);
/* 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);
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);
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, "\\%");
{
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)
}
}
-XS(XS_Regexp_DESTROY)
-{
- PERL_UNUSED_CONTEXT;
- PERL_UNUSED_ARG(cv);
-}
-
XS(XS_PerlIO_get_layers)
{
dVAR;
(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;
https://perl5.git.perl.org / perl5.git / blobdiff