From: Craig A. Berry Date: Sat, 19 May 2007 01:00:15 +0000 (+0000) Subject: Various mro updates from Brandon Black. References: X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=70cd14a10b623c21342f84d4826106411378add8;p=p5sagit%2Fp5-mst-13.2.git Various mro updates from Brandon Black. References: <84621a60705111347q40f9dd9ciefa9468e9ff9ca6c@mail.gmail.com> <84621a60705121458i34ff361fh9166e8558781df41@mail.gmail.com> <84621a60705141111q70ed307r9181dfc2834a8f5c@mail.gmail.com> <84621a60705160937h53946fcfg70635908302724e8@mail.gmail.com> p4raw-id: //depot/perl@31239 --- diff --git a/MANIFEST b/MANIFEST index 75867e4..5ee091d 100644 --- a/MANIFEST +++ b/MANIFEST @@ -3631,6 +3631,7 @@ t/mro/next_NEXT.t mro tests 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 diff --git a/hv.h b/hv.h index 67432e9..5600ac3 100644 --- a/hv.h +++ b/hv.h @@ -51,6 +51,7 @@ struct mro_meta { 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? */ }; diff --git a/lib/mro.pm b/lib/mro.pm index 301f7a4..31da81b 100644 --- a/lib/mro.pm +++ b/lib/mro.pm @@ -35,6 +35,10 @@ mro - Method Resolution Order 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 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 or C 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 (and any members of C's MRO) are not part of the MRO of a class, even though all classes implicitly inherit methods from C and its parents. @@ -105,7 +116,7 @@ Returns the MRO of the given class (either C or C). =head2 mro::get_isarev($classname) Gets the C 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. @@ -149,7 +160,41 @@ caching in all packages. =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 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), +the number will be reset to either C<0> or C<1>, +depending on how completely package was wiped out. =head2 next::method diff --git a/mg.c b/mg.c index 200da51..77ae021 100644 --- a/mg.c +++ b/mg.c @@ -1519,6 +1519,11 @@ Perl_magic_setisa(pTHX_ SV *sv, MAGIC *mg) /* 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 */ diff --git a/mro.c b/mro.c index 1e14bd1..8d98fdc 100644 --- a/mro.c +++ b/mro.c @@ -34,6 +34,7 @@ Perl_mro_meta_init(pTHX_ HV* stash) Newxz(newmeta, 1, struct mro_meta); HvAUX(stash)->xhv_mro_meta = newmeta; newmeta->cache_gen = 1; + newmeta->pkg_gen = 1; return newmeta; } @@ -242,19 +243,20 @@ Perl_mro_get_linear_isa_c3(pTHX_ HV* stash, I32 level) 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)); @@ -453,6 +455,9 @@ Perl_mro_isa_changed_in(pTHX_ HV* stash) 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 */ @@ -572,6 +577,9 @@ Perl_mro_method_changed_in(pTHX_ HV *stash) 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")) @@ -804,6 +812,7 @@ XS(XS_mro_get_isarev); 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); @@ -821,6 +830,7 @@ Perl_boot_core_mro(pTHX) 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); @@ -840,9 +850,15 @@ XS(XS_mro_get_linear_isa) { 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); @@ -907,7 +923,6 @@ XS(XS_mro_get_mro) dXSARGS; SV* classname; HV* class_stash; - struct mro_meta* meta; PERL_UNUSED_ARG(cv); @@ -916,10 +931,8 @@ XS(XS_mro_get_mro) 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)); @@ -932,11 +945,11 @@ XS(XS_mro_get_isarev) 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); @@ -945,22 +958,22 @@ XS(XS_mro_get_isarev) 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; @@ -971,10 +984,9 @@ XS(XS_mro_is_universal) 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); @@ -983,16 +995,14 @@ XS(XS_mro_is_universal) 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 @@ -1036,6 +1046,32 @@ XS(XS_mro_method_changed_in) 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; diff --git a/sv.c b/sv.c index 6f526b2..bd10280 100644 --- a/sv.c +++ b/sv.c @@ -3145,7 +3145,7 @@ copy-ish functions and macros use this underneath. 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); @@ -3186,15 +3186,18 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) /* 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); @@ -3209,7 +3212,8 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) 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; } diff --git a/t/mro/basic.t b/t/mro/basic.t index 3f1d1cf..0871d19 100644 --- a/t/mro/basic.t +++ b/t/mro/basic.t @@ -3,7 +3,7 @@ use strict; use warnings; -require q(./test.pl); plan(tests => 8); +require q(./test.pl); plan(tests => 12); { package MRO_A; @@ -32,7 +32,7 @@ ok(eq_array( [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/] @@ -45,3 +45,27 @@ ok(mro::is_universal('MRO_B')); @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); diff --git a/t/mro/pkg_gen.t b/t/mro/pkg_gen.t new file mode 100644 index 0000000..6a507ac --- /dev/null +++ b/t/mro/pkg_gen.t @@ -0,0 +1,36 @@ +#!./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::}');