*/
/*
- * "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;
rv = &PL_sv_undef;
if (SvROK(sv)) {
- sv = (SV*)SvRV(sv);
+ sv = MUTABLE_SV(SvRV(sv));
if (SvOBJECT(sv))
pkg = SvSTASH(sv);
}
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;
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);
undef = NULL;
}
else {
- sv = (SV*)&PL_sv_undef;
+ sv = &PL_sv_undef;
undef = "(undef)";
}
}
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)),
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();
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;
if (items != 1)
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);
}
}
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);
}
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;
if (!ret)
XSRETURN_UNDEF;
- av = (AV*)SvRV(ret);
+ av = MUTABLE_AV(SvRV(ret));
length = av_len(av);
for (i = 0; i <= length; i++) {
/* 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));
+ 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);
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 (!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);
}
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);
}
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);
}
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;
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;
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;
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;
projects / p5sagit/p5-mst-13.2.git / blobdiff