t/mro/next_skip.t mro tests
t/mro/overload_c3.t mro tests
t/mro/overload_dfs.t mro tests
+t/mro/pkg_gen.t mro tests
t/mro/recursion_c3.t mro tests
t/mro/recursion_dfs.t mro tests
t/mro/vulcan_c3.t mro tests
AV *mro_linear_c3; /* cached c3 @ISA linearization */
HV *mro_nextmethod; /* next::method caching */
U32 cache_gen; /* Bumping this invalidates our method cache */
+ U32 pkg_gen; /* Bumps when local methods/@ISA change */
mro_alg mro_which; /* which mro alg is in use? */
};
The "mro" namespace provides several utilities for dealing
with method resolution order and method caching in general.
+These interfaces are only available in Perl 5.9.5 and higher.
+See L<MRO::Compat> on CPAN for a mostly forwards compatible
+implementation for older Perls.
+
=head1 OVERVIEW
It's possible to change the MRO of a given class either by using C<use
Uses whichever MRO is currently in effect for that class by default,
or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
+The linearized MRO of a class is an ordered array of all of the
+classes one would search when resolving a method on that class,
+starting with the class itself.
+
+If the requested class doesn't yet exist, this function will still
+succeed, and return C<[ $classname ]>
+
Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
part of the MRO of a class, even though all classes implicitly inherit
methods from C<UNIVERSAL> and its parents.
=head2 mro::get_isarev($classname)
Gets the C<mro_isarev> for this class, returned as an
-array of class names. These are every class that "isa"
+arrayref of class names. These are every class that "isa"
the given class name, even if the isa relationship is
indirect. This is used internally by the MRO code to
keep track of method/MRO cache invalidations.
=head2 mro::method_changed_in($classname)
Invalidates the method cache of any classes dependent on the
-given class.
+given class. This is not normally necessary. The only
+known case where pure perl code can confuse the method
+cache is when you manually install a new constant
+subroutine by using a readonly scalar value, like the
+internals of L<constant> do. If you find another case,
+please report it so we can either fix it or document
+the exception here.
+
+=head2 mro::get_pkg_gen($classname)
+
+Returns an integer which is incremented every time a
+real local method in the package C<$classname> changes,
+or the local C<@ISA> of C<$classname> is modified.
+
+This is intended for authors of modules which do lots
+of class introspection, as it allows them to very quickly
+check if anything important about the local properties
+of a given class have changed since the last time they
+looked. It does not increment on method/C<@ISA>
+changes in superclasses.
+
+It's still up to you to seek out the actual changes,
+and there might not actually be any. Perhaps all
+of the changes since you last checked cancelled each
+other out and left the package in the state it was in
+before.
+
+This integer normally starts off at a value of C<1>
+when a package stash is instantiated. Calling it
+on packages whose stashes do not exist at all will
+return C<0>. If a package stash is completely
+deleted (not a normal occurence, but it can happen
+if someone does something like C<undef %PkgName::>),
+the number will be reset to either C<0> or C<1>,
+depending on how completely package was wiped out.
=head2 next::method
/* Bail out if destruction is going on */
if(PL_dirty) return 0;
+ /* XXX Once it's possible, we need to
+ detect that our @ISA is aliased in
+ other stashes, and act on the stashes
+ of all of the aliases */
+
/* The first case occurs via setisa,
the second via setisa_elem, which
calls this same magic */
Newxz(newmeta, 1, struct mro_meta);
HvAUX(stash)->xhv_mro_meta = newmeta;
newmeta->cache_gen = 1;
+ newmeta->pkg_gen = 1;
return newmeta;
}
I32 items = AvFILLp(isa) + 1;
SV** isa_ptr = AvARRAY(isa);
while(items--) {
- AV* isa_lin;
SV* const isa_item = *isa_ptr++;
HV* const isa_item_stash = gv_stashsv(isa_item, 0);
if(!isa_item_stash) {
/* if no stash, make a temporary fake MRO
containing just itself */
- isa_lin = (AV*)sv_2mortal((SV*)newAV());
+ AV* const isa_lin = newAV();
av_push(isa_lin, newSVsv(isa_item));
+ av_push(seqs, (SV*)isa_lin);
}
else {
- isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1); /* recursion */
+ /* recursion */
+ AV* const isa_lin = mro_get_linear_isa_c3(isa_item_stash, level + 1);
+ av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
}
- av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa_lin));
}
av_push(seqs, SvREFCNT_inc_simple_NN((SV*)isa));
meta->mro_linear_dfs = NULL;
meta->mro_linear_c3 = 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 */
SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
HV * const isarev = svp ? (HV*)*svp : NULL;
+ /* Inc the package generation, since a local method changed */
+ HvMROMETA(stash)->pkg_gen++;
+
/* If stash is UNIVERSAL, or one of UNIVERSAL's parents,
invalidate all method caches globally */
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
XS(XS_mro_is_universal);
XS(XS_mro_invalidate_method_caches);
XS(XS_mro_method_changed_in);
+XS(XS_mro_get_pkg_gen);
XS(XS_next_can);
XS(XS_next_method);
XS(XS_maybe_next_method);
newXSproto("mro::is_universal", XS_mro_is_universal, file, "$");
newXSproto("mro::invalidate_all_method_caches", XS_mro_invalidate_method_caches, file, "");
newXSproto("mro::method_changed_in", XS_mro_method_changed_in, file, "$");
+ newXSproto("mro::get_pkg_gen", XS_mro_get_pkg_gen, file, "$");
newXS("next::can", XS_next_can, file);
newXS("next::method", XS_next_method, file);
newXS("maybe::next::method", XS_maybe_next_method, file);
classname = ST(0);
class_stash = gv_stashsv(classname, 0);
- if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
- if(items > 1) {
+ if(!class_stash) {
+ /* No stash exists yet, give them just the classname */
+ AV* isalin = newAV();
+ av_push(isalin, newSVsv(classname));
+ ST(0) = sv_2mortal(newRV_noinc((SV*)isalin));
+ XSRETURN(1);
+ }
+ else if(items > 1) {
const char* const which = SvPV_nolen(ST(1));
if(strEQ(which, "dfs"))
RETVAL = mro_get_linear_isa_dfs(class_stash, 0);
dXSARGS;
SV* classname;
HV* class_stash;
- struct mro_meta* meta;
PERL_UNUSED_ARG(cv);
classname = ST(0);
class_stash = gv_stashsv(classname, 0);
- if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
- meta = HvMROMETA(class_stash);
- if(meta->mro_which == MRO_DFS)
+ if(!class_stash || HvMROMETA(class_stash)->mro_which == MRO_DFS)
ST(0) = sv_2mortal(newSVpvn("dfs", 3));
else
ST(0) = sv_2mortal(newSVpvn("c3", 2));
dVAR;
dXSARGS;
SV* classname;
- HV* class_stash;
SV** svp;
HV* isarev;
- char* stashname;
- STRLEN stashname_len;
+ char* classname_pv;
+ STRLEN classname_len;
+ AV* ret_array;
PERL_UNUSED_ARG(cv);
classname = ST(0);
- class_stash = gv_stashsv(classname, 0);
- if(!class_stash)
- Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
-
SP -= items;
- stashname = HvNAME_get(class_stash);
- stashname_len = HvNAMELEN_get(class_stash);
- svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
+
+ classname_pv = SvPV_nolen(classname);
+ classname_len = strlen(classname_pv);
+ svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
isarev = svp ? (HV*)*svp : NULL;
+
+ ret_array = newAV();
if(isarev) {
HE* iter;
hv_iterinit(isarev);
while((iter = hv_iternext(isarev)))
- XPUSHs(hv_iterkeysv(iter));
+ av_push(ret_array, newSVsv(hv_iterkeysv(iter)));
}
+ XPUSHs(sv_2mortal(newRV_noinc((SV*)ret_array)));
PUTBACK;
return;
dVAR;
dXSARGS;
SV* classname;
- HV* class_stash;
HV* isarev;
- char* stashname;
- STRLEN stashname_len;
+ char* classname_pv;
+ STRLEN classname_len;
SV** svp;
PERL_UNUSED_ARG(cv);
Perl_croak(aTHX_ "Usage: mro::is_universal(classname)");
classname = ST(0);
- class_stash = gv_stashsv(classname, 0);
- if(!class_stash) Perl_croak(aTHX_ "No such class: '%"SVf"'!", SVfARG(classname));
- stashname = HvNAME_get(class_stash);
- stashname_len = HvNAMELEN_get(class_stash);
+ classname_pv = SvPV_nolen(classname);
+ classname_len = strlen(classname_pv);
- svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
+ svp = hv_fetch(PL_isarev, classname_pv, classname_len, 0);
isarev = svp ? (HV*)*svp : NULL;
- if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
+ if((classname_len == 9 && strEQ(classname_pv, "UNIVERSAL"))
|| (isarev && hv_exists(isarev, "UNIVERSAL", 9)))
XSRETURN_YES;
else
XSRETURN_EMPTY;
}
+XS(XS_mro_get_pkg_gen)
+{
+ dVAR;
+ dXSARGS;
+ SV* classname;
+ HV* class_stash;
+
+ PERL_UNUSED_ARG(cv);
+
+ if(items != 1)
+ Perl_croak(aTHX_ "Usage: mro::get_pkg_gen(classname)");
+
+ classname = ST(0);
+
+ class_stash = gv_stashsv(classname, 0);
+
+ SP -= items;
+
+ XPUSHs(sv_2mortal(newSViv(
+ class_stash ? HvMROMETA(class_stash)->pkg_gen : 0
+ )));
+
+ PUTBACK;
+ return;
+}
+
XS(XS_next_can)
{
dVAR;
static void
S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype)
{
- I32 method_changed = 0;
+ I32 mro_changes = 0; /* 1 = method, 2 = isa */
if (dtype != SVt_PVGV) {
const char * const name = GvNAME(sstr);
/* If source has a real method, then a method is
going to change */
else if(GvCV((GV*)sstr)) {
- method_changed = 1;
+ mro_changes = 1;
}
}
/* If dest already had a real method, that's a change as well */
- if(!method_changed && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) {
- method_changed = 1;
+ if(!mro_changes && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) {
+ mro_changes = 1;
}
+ if(strEQ(GvNAME((GV*)dstr),"ISA"))
+ mro_changes = 2;
+
gp_free((GV*)dstr);
isGV_with_GP_off(dstr);
(void)SvOK_off(dstr);
GvIMPORTED_on(dstr);
}
GvMULTI_on(dstr);
- if(method_changed) mro_method_changed_in(GvSTASH(dstr));
+ if(mro_changes == 2) mro_isa_changed_in(GvSTASH(dstr));
+ else if(mro_changes) mro_method_changed_in(GvSTASH(dstr));
return;
}
use strict;
use warnings;
-require q(./test.pl); plan(tests => 8);
+require q(./test.pl); plan(tests => 12);
{
package MRO_A;
[qw/MRO_F MRO_D MRO_E MRO_A MRO_B MRO_C/]
));
-my @isarev = sort { $a cmp $b } mro::get_isarev('MRO_B');
+my @isarev = sort { $a cmp $b } @{mro::get_isarev('MRO_B')};
ok(eq_array(
\@isarev,
[qw/MRO_D MRO_E MRO_F/]
@UNIVERSAL::ISA = ();
ok(mro::is_universal('MRO_B'));
+
+# is_universal, get_mro, and get_linear_isa should
+# handle non-existant packages sanely
+ok(!mro::is_universal('Does_Not_Exist'));
+is(mro::get_mro('Also_Does_Not_Exist'), 'dfs');
+ok(eq_array(
+ mro::get_linear_isa('Does_Not_Exist_Three'),
+ [qw/Does_Not_Exist_Three/]
+));
+
+# Assigning @ISA via globref
+{
+ package MRO_TestBase;
+ sub testfunc { return 123 }
+ package MRO_TestOtherBase;
+ sub testfunctwo { return 321 }
+ package MRO_M; our @ISA = qw/MRO_TestBase/;
+}
+*MRO_N::ISA = *MRO_M::ISA;
+is(eval { MRO_N->testfunc() }, 123);
+
+# XXX TODO (when there's a way to backtrack through a glob's aliases)
+# push(@MRO_M::ISA, 'MRO_TestOtherBase');
+# is(eval { MRO_N->testfunctwo() }, 321);
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+
+chdir 't' if -d 't';
+require q(./test.pl); plan(tests => 6);
+
+{
+ package Foo;
+ our @ISA = qw//;
+}
+
+ok(!mro::get_pkg_gen('ReallyDoesNotExist'),
+ "pkg_gen 0 for non-existant pkg");
+
+my $f_gen = mro::get_pkg_gen('Foo');
+ok($f_gen > 0, 'Foo pkg_gen > 0');
+
+{
+ no warnings 'once';
+ *Foo::foo_func = sub { 123 };
+}
+my $new_f_gen = mro::get_pkg_gen('Foo');
+ok($new_f_gen > $f_gen, 'Foo pkg_gen incs for methods');
+$f_gen = $new_f_gen;
+
+@Foo::ISA = qw/Bar/;
+$new_f_gen = mro::get_pkg_gen('Foo');
+ok($new_f_gen > $f_gen, 'Foo pkg_gen incs for @ISA');
+
+undef %Foo::;
+is(mro::get_pkg_gen('Foo'), 1, "pkg_gen 1 for undef %Pkg::");
+
+delete $::{"Foo::"};
+is(mro::get_pkg_gen('Foo'), 0, 'pkg_gen 0 for delete $::{Pkg::}');
projects / p5sagit/p5-mst-13.2.git / commitdiff