/*
=for apidoc mro_method_changed_in
Invalidates method caching on any child classes
of the given stash, so that they might notice
the changes in this one.
Ideally, all instances of C<PL_sub_generation++> in
perl source outside of F<mro.c> should be
replaced by calls to this.
Perl automatically handles most of the common
ways a method might be redefined. However, there
are a few ways you could change a method in a stash
without the cache code noticing, in which case you
need to call this method afterwards:
1) Directly manipulating the stash HV entries from
XS code.
2) Assigning a reference to a readonly scalar
constant into a stash entry in order to create
a constant subroutine (like F<constant.pm>
does).
This same method is available from pure perl
via, C<mro::method_changed_in(classname)>.
=cut
*/
void
Perl_mro_method_changed_in(pTHX_ HV *stash)
{
const char * const stashname = HvENAME_get(stash);
const STRLEN stashname_len = HvENAMELEN_get(stash);
SV ** const svp = hv_fetchhek(PL_isarev, HvENAME_HEK(stash), 0);
HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
if(!stashname)
Perl_croak(aTHX_ "Can't call mro_method_changed_in() on anonymous symbol table");
/* Inc the package generation, since a local method changed */
HvMROMETA(stash)->pkg_gen++;
/* DESTROY can be cached in SvSTASH. */
if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
/* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
invalidate all method caches globally */
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
|| (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
PL_sub_generation++;
return;
}
/* else, invalidate the method caches of all child classes,
but not itself */
if(isarev) {
HE* iter;
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
struct mro_meta* mrometa;
if(!revstash) continue;
mrometa = HvMROMETA(revstash);
mrometa->cache_gen++;
if(mrometa->mro_nextmethod)
hv_clear(mrometa->mro_nextmethod);
if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
}
}
/* The method change may be due to *{$package . "::()"} = \&nil; in
overload.pm. */
HvAMAGIC_on(stash);
/* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
}
/* helper to return the stash for a svref, (Sv|Cv|Gv|GvE)STASH */
static HV*
S_guess_stash(pTHX_ SV* sv)
{
if (SvOBJECT(sv)) {
return SvSTASH(sv);
}
else {
HV *stash = NULL;
switch (SvTYPE(sv)) {
case SVt_PVCV:
if (CvGV(sv) && isGV(CvGV(sv)) && GvSTASH(CvGV(sv)))
return GvSTASH(CvGV(sv));
else if (/* !CvANON(sv) && */ CvSTASH(sv))
return CvSTASH(sv);
break;
case SVt_PVGV:
if (isGV_with_GP(sv) && GvGP(sv) && GvESTASH(MUTABLE_GV(sv)))
return GvESTASH(MUTABLE_GV(sv));
break;
default:
break;
}
return stash;
}
}
bool
Perl_sv_derived_from(pTHX_ SV *sv, const char *name)
{
char *type;
HV *stash;
stash = Nullhv;
type = Nullch;
if (SvGMAGICAL(sv))
mg_get(sv) ;
if (SvROK(sv)) {
sv = SvRV(sv);
type = sv_reftype(sv,0);
if (SvOBJECT(sv))
stash = SvSTASH(sv);
}
else {
stash = gv_stashsv(sv, FALSE);
}
return (type && strEQ(type,name)) ||
(stash && isa_lookup(stash, name, strlen(name), 0) == &PL_sv_yes)
? TRUE
: FALSE ;
}
static void
Scalarize(pTHX_ SV *sv, AV *av)
{
int n = av_len(av)+1;
if (n == 0)
sv_setpvn(sv,"",0);
else
{
SV **svp;
if (n == 1 && (svp = av_fetch(av, 0, 0)))
{
STRLEN len = 0;
char *s = SvPV(*svp,len);
#ifdef SvUTF8
int utf8 = SvUTF8(*svp);
sv_setpvn(sv,s,len);
if (utf8)
SvUTF8_on(sv);
#else
sv_setpvn(sv,s,len);
#endif
}
else
{
Tcl_DString ds;
int i;
Tcl_DStringInit(&ds);
for (i=0; i < n; i++)
{
if ((svp = av_fetch(av, i, 0)))
{
SV *el = *svp;
int temp = 0;
if (SvROK(el) && !SvOBJECT(SvRV(el)) && SvTYPE(SvRV(el)) == SVt_PVAV)
{
el = newSVpv("",0);
temp = 1;
if ((AV *) SvRV(*svp) == av)
abort();
Scalarize(aTHX_ el,(AV *) SvRV(*svp));
}
Tcl_DStringAppendElement(&ds,Tcl_GetString(el));
if (temp)
SvREFCNT_dec(el);
}
}
sv_setpvn(sv,Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
sv_maybe_utf8(sv);
Tcl_DStringFree(&ds);
}
}
}
MP_INLINE server_rec *modperl_sv2server_rec(pTHX_ SV *sv)
{
if (SvOBJECT(sv) || (SvROK(sv) && (SvTYPE(SvRV(sv)) == SVt_PVMG))) {
return INT2PTR(server_rec *, SvObjIV(sv));
}
/* next see if we have Apache2->request available */
{
request_rec *r = NULL;
(void)modperl_tls_get_request_rec(&r);
if (r) {
return r->server;
}
}
/* modperl_global_get_server_rec is not thread safe w/o locking */
return modperl_global_get_server_rec();
}
static SV *
ForceScalar(pTHX_ SV *sv)
{
if (SvGMAGICAL(sv))
mg_get(sv);
if (SvTYPE(sv) == SVt_PVAV)
{
AV *av = (AV *) sv;
SV *newsv = newSVpv("",0);
Scalarize(aTHX_ newsv, (AV *) av);
av_clear(av);
av_store(av,0,newsv);
return newsv;
}
else
{
if (SvROK(sv) && !SvOBJECT(SvRV(sv)) && SvTYPE(SvRV(sv)) == SVt_PVAV)
{
/* Callbacks and lists often get stringified by mistake due to
Tcl/Tk's string fixation - don't change the real value
*/
SV *newsv = newSVpv("",0);
Scalarize(aTHX_ newsv, (AV *) SvRV(sv));
return sv_2mortal(newsv);
}
else if (!SvOK(sv))
{
/* Map undef to null string */
if (SvREADONLY(sv))
{
SV *newsv = newSVpv("",0);
return sv_2mortal(newsv);
}
else
sv_setpvn(sv,"",0);
}
return sv;
}
}
void _mpack_item(SV *res, SV *o)
{
size_t len, res_len, new_len;
char *s, *res_s;
res_s = SvPVbyte(res, res_len);
unsigned i;
if (!SvOK(o)) {
new_len = res_len + mp_sizeof_nil();
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_nil(res_s + res_len);
return;
}
if (SvROK(o)) {
o = SvRV(o);
if (SvOBJECT(o)) {
SvGETMAGIC(o);
HV *stash = SvSTASH(o);
GV *mtd = gv_fetchmethod_autoload(stash, "msgpack", 0);
if (!mtd)
croak("Object has no method 'msgpack'");
dSP;
ENTER;
SAVETMPS;
PUSHMARK(SP);
XPUSHs (sv_bless (sv_2mortal (newRV_inc(o)), stash));
PUTBACK;
call_sv((SV *)GvCV(mtd), G_SCALAR);
SPAGAIN;
SV *pkt = POPs;
if (!SvOK(pkt))
croak("O->msgpack returned undef");
s = SvPV(pkt, len);
new_len = res_len + len;
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
memcpy(res_s + res_len, s, len);
PUTBACK;
FREETMPS;
LEAVE;
return;
}
switch(SvTYPE(o)) {
case SVt_PVAV: {
AV *a = (AV *)o;
len = av_len(a) + 1;
new_len = res_len + mp_sizeof_array(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_array(res_s + res_len, len);
for (i = 0; i < len; i++) {
SV **item = av_fetch(a, i, 0);
if (!item)
_mpack_item(res, 0);
else
_mpack_item(res, *item);
}
break;
}
case SVt_PVHV: {
HV *h = (HV *)o;
len = hv_iterinit(h);
new_len = res_len + mp_sizeof_map(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_map(res_s + res_len, len);
for (;;) {
HE * iter = hv_iternext(h);
if (!iter)
break;
SV *k = hv_iterkeysv(iter);
SV *v = HeVAL(iter);
_mpack_item(res, k);
_mpack_item(res, v);
}
break;
}
default:
croak("Can't serialize reference");
}
return;
}
switch(SvTYPE(o)) {
case SVt_PV:
case SVt_PVIV:
case SVt_PVNV:
case SVt_PVMG:
case SVt_REGEXP:
if (!looks_like_number(o)) {
s = SvPV(o, len);
new_len = res_len + mp_sizeof_str(len);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_str(res_s + res_len, s, len);
break;
}
case SVt_NV: {
NV v = SvNV(o);
IV iv = (IV)v;
if (v != iv) {
new_len = res_len + mp_sizeof_double(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_double(res_s + res_len, v);
break;
}
}
case SVt_IV: {
IV v = SvIV(o);
if (v >= 0) {
new_len = res_len + mp_sizeof_uint(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_uint(res_s + res_len, v);
} else {
new_len = res_len + mp_sizeof_int(v);
res_s = SvGROW(res, new_len);
SvCUR_set(res, new_len);
mp_encode_int(res_s + res_len, v);
}
break;
}
default:
croak("Internal msgpack error %d", SvTYPE(o));
}
}
void
Perl_mro_isa_changed_in(pTHX_ HV* stash)
{
HV* isarev;
AV* linear_mro;
HE* iter;
SV** svp;
I32 items;
bool is_universal;
struct mro_meta * meta;
HV *isa = NULL;
const HEK * const stashhek = HvENAME_HEK(stash);
const char * const stashname = HvENAME_get(stash);
const STRLEN stashname_len = HvENAMELEN_get(stash);
PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
if(!stashname)
Perl_croak(aTHX_ "Can't call mro_isa_changed_in() on anonymous symbol table");
/* wipe out the cached linearizations for this stash */
meta = HvMROMETA(stash);
CLEAR_LINEAR(meta);
if (meta->isa) {
/* Steal it for our own purposes. */
isa = (HV *)sv_2mortal((SV *)meta->isa);
meta->isa = NULL;
}
/* Inc the package generation, since our @ISA changed */
meta->pkg_gen++;
/* Wipe the global method cache if this package
is UNIVERSAL or one of its parents */
svp = hv_fetchhek(PL_isarev, stashhek, 0);
isarev = svp ? MUTABLE_HV(*svp) : NULL;
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
|| (isarev && hv_exists(isarev, "UNIVERSAL", 9))) {
PL_sub_generation++;
is_universal = TRUE;
}
else { /* Wipe the local method cache otherwise */
meta->cache_gen++;
is_universal = FALSE;
}
/* wipe next::method cache too */
if(meta->mro_nextmethod) hv_clear(meta->mro_nextmethod);
/* Changes to @ISA might turn overloading on */
HvAMAGIC_on(stash);
/* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
/* DESTROY can be cached in SvSTASH. */
if (!SvOBJECT(stash)) SvSTASH(stash) = NULL;
/* Iterate the isarev (classes that are our children),
wiping out their linearization, method and isa caches
and upating PL_isarev. */
if(isarev) {
HV *isa_hashes = NULL;
/* We have to iterate through isarev twice to avoid a chicken and
* egg problem: if A inherits from B and both are in isarev, A might
* be processed before B and use B's previous linearisation.
*/
/* First iteration: Wipe everything, but stash away the isa hashes
* since we still need them for updating PL_isarev.
*/
if(hv_iterinit(isarev)) {
/* Only create the hash if we need it; i.e., if isarev has
any elements. */
isa_hashes = (HV *)sv_2mortal((SV *)newHV());
}
while((iter = hv_iternext(isarev))) {
HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
struct mro_meta* revmeta;
if(!revstash) continue;
revmeta = HvMROMETA(revstash);
CLEAR_LINEAR(revmeta);
if(!is_universal)
revmeta->cache_gen++;
if(revmeta->mro_nextmethod)
hv_clear(revmeta->mro_nextmethod);
if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL;
(void)
hv_store(
isa_hashes, (const char*)&revstash, sizeof(HV *),
revmeta->isa ? (SV *)revmeta->isa : &PL_sv_undef, 0
);
revmeta->isa = NULL;
}
/* Second pass: Update PL_isarev. We can just use isa_hashes to
* avoid another round of stash lookups. */
/* isarev might be deleted from PL_isarev during this loop, so hang
* on to it. */
SvREFCNT_inc_simple_void_NN(sv_2mortal((SV *)isarev));
if(isa_hashes) {
hv_iterinit(isa_hashes);
while((iter = hv_iternext(isa_hashes))) {
HV* const revstash = *(HV **)HEK_KEY(HeKEY_hek(iter));
HV * const isa = (HV *)HeVAL(iter);
const HEK *namehek;
/* We're starting at the 2nd element, skipping revstash */
linear_mro = mro_get_linear_isa(revstash);
svp = AvARRAY(linear_mro) + 1;
items = AvFILLp(linear_mro);
namehek = HvENAME_HEK(revstash);
if (!namehek) namehek = HvNAME_HEK(revstash);
while (items--) {
SV* const sv = *svp++;
HV* mroisarev;
HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
/* That fetch should not fail. But if it had to create
a new SV for us, then will need to upgrade it to an
HV (which sv_upgrade() can now do for us). */
mroisarev = MUTABLE_HV(HeVAL(he));
SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
/* This hash only ever contains PL_sv_yes. Storing it
over itself is almost as cheap as calling hv_exists,
so on aggregate we expect to save time by not making
two calls to the common HV code for the case where
it doesn't exist. */
(void)
hv_storehek(mroisarev, namehek, &PL_sv_yes);
}
if ((SV *)isa != &PL_sv_undef) {
assert(namehek);
mro_clean_isarev(
isa, HEK_KEY(namehek), HEK_LEN(namehek),
HvMROMETA(revstash)->isa, HEK_HASH(namehek),
HEK_UTF8(namehek)
);
}
}
}
}
/* Now iterate our MRO (parents), adding ourselves and everything from
our isarev to their isarev.
*/
/* We're starting at the 2nd element, skipping ourselves here */
linear_mro = mro_get_linear_isa(stash);
svp = AvARRAY(linear_mro) + 1;
items = AvFILLp(linear_mro);
while (items--) {
SV* const sv = *svp++;
HV* mroisarev;
HE *he = hv_fetch_ent(PL_isarev, sv, TRUE, 0);
/* That fetch should not fail. But if it had to create a new SV for
us, then will need to upgrade it to an HV (which sv_upgrade() can
now do for us. */
mroisarev = MUTABLE_HV(HeVAL(he));
SvUPGRADE(MUTABLE_SV(mroisarev), SVt_PVHV);
/* This hash only ever contains PL_sv_yes. Storing it over itself is
almost as cheap as calling hv_exists, so on aggregate we expect to
save time by not making two calls to the common HV code for the
case where it doesn't exist. */
(void)hv_storehek(mroisarev, stashhek, &PL_sv_yes);
}
/* Delete our name from our former parents' isarevs. */
if(isa && HvARRAY(isa))
mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
HEK_HASH(stashhek), HEK_UTF8(stashhek));
}
IV
PerlIOEncode_pushed(pTHX_ PerlIO * f, const char *mode, SV * arg, PerlIO_funcs *tab)
{
PerlIOEncode *e = PerlIOSelf(f, PerlIOEncode);
dSP;
IV code = PerlIOBuf_pushed(aTHX_ f, mode, Nullsv,tab);
SV *result = Nullsv;
PUSHSTACKi(PERLSI_MAGIC);
SPAGAIN;
ENTER;
SAVETMPS;
PUSHMARK(sp);
XPUSHs(arg);
PUTBACK;
if (call_pv("Encode::find_encoding", G_SCALAR) != 1) {
/* should never happen */
Perl_die(aTHX_ "Encode::find_encoding did not return a value");
return -1;
}
SPAGAIN;
result = POPs;
PUTBACK;
if (!SvROK(result) || !SvOBJECT(SvRV(result))) {
e->enc = Nullsv;
if (ckWARN_d(WARN_IO))
Perl_warner(aTHX_ packWARN(WARN_IO), "Cannot find encoding \"%" SVf "\"",
arg);
errno = EINVAL;
code = -1;
}
else {
/* $enc->renew */
PUSHMARK(sp);
XPUSHs(result);
PUTBACK;
if (call_method("renew",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
if (ckWARN_d(WARN_IO))
Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support renew method",
arg);
}
else {
SPAGAIN;
result = POPs;
PUTBACK;
}
e->enc = newSVsv(result);
PUSHMARK(sp);
XPUSHs(e->enc);
PUTBACK;
if (call_method("needs_lines",G_SCALAR|G_EVAL) != 1 || SvTRUE(ERRSV)) {
if (ckWARN_d(WARN_IO))
Perl_warner(aTHX_ packWARN(WARN_IO), "\"%" SVf "\" does not support needs_lines",
arg);
}
else {
SPAGAIN;
result = POPs;
PUTBACK;
if (SvTRUE(result)) {
e->flags |= NEEDS_LINES;
}
}
PerlIOBase(f)->flags |= PERLIO_F_UTF8;
}
e->chk = newSVsv(get_sv("PerlIO::encoding::fallback", 0));
e->inEncodeCall = 0;
FREETMPS;
LEAVE;
POPSTACK;
return code;
}
