This is a live mirror of the Perl 5 development currently hosted at
https://github.com/perl/perl5
https://perl5.git.perl.org
/
perl5.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
do not overallocate in zaphod32_hash
[perl5.git]
/
mro_core.c
diff --git
a/mro_core.c
b/mro_core.c
index
25d30d9
..
d1abc28
100644
(file)
--- a/
mro_core.c
+++ b/
mro_core.c
@@
-191,6
+191,10
@@
Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
newmeta->super = NULL;
newmeta->super = NULL;
+ /* clear the destructor cache */
+ newmeta->destroy = NULL;
+ newmeta->destroy_gen = 0;
+
return newmeta;
}
return newmeta;
}
@@
-199,7
+203,7
@@
Perl_mro_meta_dup(pTHX_ struct mro_meta* smeta, CLONE_PARAMS* param)
/*
=for apidoc mro_get_linear_isa_dfs
/*
=for apidoc mro_get_linear_isa_dfs
-Returns the Depth-First Search linearization of
@ISA
+Returns the Depth-First Search linearization of
C<@ISA>
the given stash. The return value is a read-only AV*.
C<level> should be 0 (it is used internally in this
function's recursion).
the given stash. The return value is a read-only AV*.
C<level> should be 0 (it is used internally in this
function's recursion).
@@
-237,7
+241,7
@@
S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
if (level > 100)
Perl_croak(aTHX_
if (level > 100)
Perl_croak(aTHX_
- "Recursive inheritance detected in package '%"
HEKf
"'",
+ "Recursive inheritance detected in package '%"
HEKf
"'",
HEKfARG(stashhek));
meta = HvMROMETA(stash);
HEKfARG(stashhek));
meta = HvMROMETA(stash);
@@
-342,7
+346,7
@@
S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
/* They have no stash. So create ourselves an ->isa cache
as if we'd copied it from what theirs should be. */
stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
/* They have no stash. So create ourselves an ->isa cache
as if we'd copied it from what theirs should be. */
stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
- (void) hv_store
(stored, "UNIVERSAL", 9, &PL_sv_undef, 0
);
+ (void) hv_store
s(stored, "UNIVERSAL", &PL_sv_undef
);
av_push(retval,
newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
&PL_sv_undef, 0))));
av_push(retval,
newSVhek(HeKEY_hek(hv_store_ent(stored, sv,
&PL_sv_undef, 0))));
@@
-352,7
+356,7
@@
S_mro_get_linear_isa_dfs(pTHX_ HV *stash, U32 level)
} else {
/* We have no parents. */
stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
} else {
/* We have no parents. */
stored = MUTABLE_HV(sv_2mortal(MUTABLE_SV(newHV())));
- (void) hv_store
(stored, "UNIVERSAL", 9, &PL_sv_undef, 0
);
+ (void) hv_store
s(stored, "UNIVERSAL", &PL_sv_undef
);
}
(void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
}
(void) hv_store_ent(stored, our_name, &PL_sv_undef, 0);
@@
-447,7
+451,7
@@
Perl_mro_get_linear_isa(pTHX_ HV *stash)
HEK_LEN(canon_name), HEK_FLAGS(canon_name),
HV_FETCH_ISSTORE, &PL_sv_undef,
HEK_HASH(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
);
+ (void) hv_store
s(isa_hash, "UNIVERSAL", &PL_sv_undef
);
SvREADONLY_on(isa_hash);
SvREADONLY_on(isa_hash);
@@
-461,7
+465,7
@@
Perl_mro_get_linear_isa(pTHX_ HV *stash)
=for apidoc mro_isa_changed_in
Takes the necessary steps (cache invalidations, mostly)
=for apidoc mro_isa_changed_in
Takes the necessary steps (cache invalidations, mostly)
-when the
@ISA
of the given package has changed. Invoked
+when the
C<@ISA>
of the given package has changed. Invoked
by the C<setisa> magic, should not need to invoke directly.
=cut
by the C<setisa> magic, should not need to invoke directly.
=cut
@@
-520,8
+524,8
@@
Perl_mro_isa_changed_in(pTHX_ HV* stash)
svp = hv_fetchhek(PL_isarev, stashhek, 0);
isarev = svp ? MUTABLE_HV(*svp) : NULL;
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
))) {
+ if((
memEQs(stashname, stashname_len
, "UNIVERSAL"))
+ || (isarev && hv_exists
s(isarev, "UNIVERSAL"
))) {
PL_sub_generation++;
is_universal = TRUE;
}
PL_sub_generation++;
is_universal = TRUE;
}
@@
-538,8
+542,8
@@
Perl_mro_isa_changed_in(pTHX_ HV* stash)
/* pessimise derefs for now. Will get recalculated by Gv_AMupdate() */
HvAUX(stash)->xhv_aux_flags &= ~HvAUXf_NO_DEREF;
/* 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
;
+ /* DESTROY can be cached in
meta
. */
+
meta->destroy_gen = 0
;
/* Iterate the isarev (classes that are our children),
wiping out their linearization, method and isa caches
/* Iterate the isarev (classes that are our children),
wiping out their linearization, method and isa caches
@@
-950,7
+954,7
@@
S_mro_gather_and_rename(pTHX_ HV * const stashes, HV * const seen_stashes,
STRLEN len;
const char *name = SvPVx_const(*svp, len);
if(PL_stashcache) {
STRLEN len;
const char *name = SvPVx_const(*svp, len);
if(PL_stashcache) {
- DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"
SVf
"'\n",
+ DEBUG_o(Perl_deb(aTHX_ "mro_gather_and_rename clearing PL_stashcache for '%"
SVf
"'\n",
SVfARG(*svp)));
(void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
}
SVfARG(*svp)));
(void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len : (I32)len, G_DISCARD);
}
@@
-1295,7
+1299,7
@@
XS code.
2) Assigning a reference to a readonly scalar
constant into a stash entry in order to create
2) Assigning a reference to a readonly scalar
constant into a stash entry in order to create
-a constant subroutine (like
constant.pm
+a constant subroutine (like
F<constant.pm>
does).
This same method is available from pure perl
does).
This same method is available from pure perl
@@
-1320,13
+1324,13
@@
Perl_mro_method_changed_in(pTHX_ HV *stash)
/* Inc the package generation, since a local method changed */
HvMROMETA(stash)->pkg_gen++;
/* 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
;
+ /* DESTROY can be cached in
meta
*/
+
HvMROMETA(stash)->destroy_gen = 0
;
/* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
invalidate all method caches globally */
/* 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
))) {
+ if((
memEQs(stashname, stashname_len
, "UNIVERSAL"))
+ || (isarev && hv_exists
s(isarev, "UNIVERSAL"
))) {
PL_sub_generation++;
return;
}
PL_sub_generation++;
return;
}
@@
-1346,7
+1350,7
@@
Perl_mro_method_changed_in(pTHX_ HV *stash)
mrometa->cache_gen++;
if(mrometa->mro_nextmethod)
hv_clear(mrometa->mro_nextmethod);
mrometa->cache_gen++;
if(mrometa->mro_nextmethod)
hv_clear(mrometa->mro_nextmethod);
-
if (!SvOBJECT(revstash)) SvSTASH(revstash) = NULL
;
+
mrometa->destroy_gen = 0
;
}
}
}
}
@@
-1365,7
+1369,7
@@
Perl_mro_set_mro(pTHX_ struct mro_meta *const meta, SV *const name)
PERL_ARGS_ASSERT_MRO_SET_MRO;
if (!which)
PERL_ARGS_ASSERT_MRO_SET_MRO;
if (!which)
- Perl_croak(aTHX_ "Invalid mro name: '%"
SVf
"'", name);
+ Perl_croak(aTHX_ "Invalid mro name: '%"
SVf
"'", name);
if(meta->mro_which != which) {
if (meta->mro_linear_current && !meta->mro_linear_all) {
if(meta->mro_which != which) {
if (meta->mro_linear_current && !meta->mro_linear_all) {
@@
-1411,7
+1415,7
@@
XS(XS_mro_method_changed_in)
classname = ST(0);
class_stash = gv_stashsv(classname, 0);
classname = ST(0);
class_stash = gv_stashsv(classname, 0);
- if(!class_stash) Perl_croak(aTHX_ "No such class: '%"
SVf
"'!", SVfARG(classname));
+ if(!class_stash) Perl_croak(aTHX_ "No such class: '%"
SVf
"'!", SVfARG(classname));
mro_method_changed_in(class_stash);
mro_method_changed_in(class_stash);