In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/dc93d7fb33f6b20933ff809c56ba68b8513d02c8?hp=d699ecb701ac42e5f50b4ec00c162c4dc9532b91>
- Log -----------------------------------------------------------------
commit dc93d7fb33f6b20933ff809c56ba68b8513d02c8
Author: Nicholas Clark <n...@ccl4.org>
Date: Sun Sep 23 22:48:42 2012 +0200
Flush PL_stashcache when assigning a file handle to a typeglob.
File handles take priority over stashes for method dispatch. Assigning a
file handle to a typeglob potentially creates a file handle where one did
not exist before. As PL_stashcache only contains entries for names which
unambiguously resolve to stashes, such a change may mean that PL_stashcache
now contains an invalid entry. As it's hard to work out exactly which
entries
might be affected, simply flush the entire cache and let it rebuild itself.
M sv.c
M t/op/method.t
commit b3ebc22146bca162c8b7f92453024f9f7a965c0a
Author: Nicholas Clark <n...@ccl4.org>
Date: Sun Sep 23 22:21:14 2012 +0200
Restore use of PL_stashcache, the stash name lookup cache for method calls.
Commit da6b625f78f5f133 in Aug 2011 inadvertently broke the code that looks
up values in PL_stashcache. As it's a only cache, quite correctly everything
carried on working without it.
Restoring it re-introduces two bugs first introduced when PL_stashcache was
added, by commit 081fc587427bbcef in Apr 2003.
M pp_hot.c
M t/op/method.t
commit 103f5a36127499843005aa988becbcdca21384af
Author: Nicholas Clark <n...@ccl4.org>
Date: Sun Sep 23 22:05:16 2012 +0200
-Do now also reports updates and use of PL_stashcache.
M gv.c
M hv.c
M mro.c
M pp_hot.c
M sv.c
commit 6f908f1bab380b2a2d78d238aad9752a9721f38a
Author: Nicholas Clark <n...@ccl4.org>
Date: Sun Sep 23 22:01:14 2012 +0200
Test the resolution behaviour for file handles and package names.
Historical behaviour is that file handles take priority over package names,
and the use of PL_stashcache shouldn't change this.
M MANIFEST
A t/lib/Count.pm
M t/op/method.t
-----------------------------------------------------------------------
Summary of changes:
MANIFEST | 1 +
gv.c | 1 +
hv.c | 15 +++++-
mro.c | 8 +++-
pp_hot.c | 12 +++--
sv.c | 14 +++++-
t/lib/Count.pm | 8 +++
t/op/method.t | 136 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-
8 files changed, 183 insertions(+), 12 deletions(-)
create mode 100644 t/lib/Count.pm
diff --git a/MANIFEST b/MANIFEST
index 350312d..6ac316d 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -5065,6 +5065,7 @@ t/lib/Cname.pm Test charnames in
regexes (op/pat.t)
t/lib/common.pl Helper for lib/{warnings,feature}.t
t/lib/commonsense.t See if configuration meets basic needs
t/lib/compmod.pl Helper for 1_compile.t
+t/lib/Count.pm Helper for t/op/method.t
t/lib/croak/mg Test croak calls from mg.c
t/lib/croak/op Test croak calls from op.c
t/lib/croak/pp_ctl Test croak calls from pp_ctl.c
diff --git a/gv.c b/gv.c
index 12f9491..f352452 100644
--- a/gv.c
+++ b/gv.c
@@ -2172,6 +2172,7 @@ Perl_gp_free(pTHX_ GV *gv)
Somehow gp->gp_hv can end up pointing at freed garbage. */
if (hv && SvTYPE(hv) == SVt_PVHV) {
const HEK *hvname_hek = HvNAME_HEK(hv);
+ DEBUG_o(Perl_deb(aTHX_ "gp_free clearing PL_stashcache for
'%"HEKf"'\n", hvname_hek));
if (PL_stashcache && hvname_hek)
(void)hv_delete(PL_stashcache, HEK_KEY(hvname_hek),
(HEK_UTF8(hvname_hek) ? -HEK_LEN(hvname_hek) :
HEK_LEN(hvname_hek)),
diff --git a/hv.c b/hv.c
index d542462..5432280 100644
--- a/hv.c
+++ b/hv.c
@@ -1812,11 +1812,14 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
/* note that the code following prior to hfreeentries is duplicated
* in sv_clear(), and changes here should be done there too */
if (PL_phase != PERL_PHASE_DESTRUCT && (name = HvNAME(hv))) {
- if (PL_stashcache)
+ if (PL_stashcache) {
+ DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for
'%"
+ HEKf"'\n", HvNAME_HEK(hv)));
(void)hv_delete(PL_stashcache, name,
HEK_UTF8(HvNAME_HEK(hv)) ? -HvNAMELEN_get(hv) :
HvNAMELEN_get(hv),
G_DISCARD
);
+ }
hv_name_set(hv, NULL, 0, 0);
}
if (save) {
@@ -1831,20 +1834,26 @@ Perl_hv_undef_flags(pTHX_ HV *hv, U32 flags)
if ((name = HvENAME_get(hv))) {
if (PL_phase != PERL_PHASE_DESTRUCT)
mro_isa_changed_in(hv);
- if (PL_stashcache)
+ if (PL_stashcache) {
+ DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for
effective name '%"
+ HEKf"'\n", HvENAME_HEK(hv)));
(void)hv_delete(
PL_stashcache, name,
HEK_UTF8(HvENAME_HEK(hv)) ? -HvENAMELEN_get(hv) :
HvENAMELEN_get(hv),
G_DISCARD
);
+ }
}
/* If this call originated from sv_clear, then we must check for
* effective names that need freeing, as well as the usual name. */
name = HvNAME(hv);
if (flags & HV_NAME_SETALL ? !!aux->xhv_name_u.xhvnameu_name : !!name) {
- if (name && PL_stashcache)
+ if (name && PL_stashcache) {
+ DEBUG_o(Perl_deb(aTHX_ "hv_undef_flags clearing PL_stashcache for
name '%"
+ HEKf"'\n", HvNAME_HEK(hv)));
(void)hv_delete(PL_stashcache, name, (HEK_UTF8(HvNAME_HEK(hv)) ?
-HvNAMELEN_get(hv) : HvNAMELEN_get(hv)), G_DISCARD);
+ }
hv_name_set(hv, NULL, 0, flags);
}
if((meta = aux->xhv_mro_meta)) {
diff --git a/mro.c b/mro.c
index c30662d..8ed73f6 100644
--- a/mro.c
+++ b/mro.c
@@ -952,9 +952,13 @@ S_mro_gather_and_rename(pTHX_ HV * const stashes, HV *
const seen_stashes,
while (items--) {
const U32 name_utf8 = SvUTF8(*svp);
STRLEN len;
- const char *name = SvPVx_const(*svp++, len);
- if(PL_stashcache)
+ 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",
+ *svp));
(void)hv_delete(PL_stashcache, name, name_utf8 ? -(I32)len :
(I32)len, G_DISCARD);
+ }
+ ++svp;
hv_ename_delete(oldstash, name, len, name_utf8);
if (!fetched_isarev) {
diff --git a/pp_hot.c b/pp_hot.c
index 302f47e..4c90ce9 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -2971,15 +2971,17 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
GV* iogv;
STRLEN packlen;
const char * const packname = SvPV_nomg_const(sv, packlen);
- bool packname_is_utf8 = FALSE;
+ const bool packname_is_utf8 = !!SvUTF8(sv);
const HE* const he =
- (const HE *)hv_common_key_len(
- PL_stashcache, packname,
- packlen * -(packname_is_utf8 = !!SvUTF8(sv)), 0, NULL, 0
+ (const HE *)hv_common(
+ PL_stashcache, NULL, packname, packlen,
+ packname_is_utf8 ? HVhek_UTF8 : 0, 0, NULL, 0
);
if (he) {
stash = INT2PTR(HV*,SvIV(HeVAL(he)));
+ DEBUG_o(Perl_deb(aTHX_ "PL_stashcache hit %p for '%"SVf"'\n",
+ stash, sv));
goto fetch;
}
@@ -3003,6 +3005,8 @@ S_method_common(pTHX_ SV* meth, U32* hashp)
SV* const ref = newSViv(PTR2IV(stash));
(void)hv_store(PL_stashcache, packname,
packname_is_utf8 ? -(I32)packlen :
(I32)packlen, ref, 0);
+ DEBUG_o(Perl_deb(aTHX_ "PL_stashcache caching %p for
'%"SVf"'\n",
+ stash, sv));
}
goto fetch;
}
diff --git a/sv.c b/sv.c
index f63ab8d..2417e86 100644
--- a/sv.c
+++ b/sv.c
@@ -1397,6 +1397,7 @@ Perl_sv_upgrade(pTHX_ register SV *const sv, svtype
new_type)
SvOBJECT_on(io);
/* Clear the stashcache because a new IO could overrule a package
name */
+ DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n"));
hv_clear(PL_stashcache);
SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv))));
@@ -3882,6 +3883,14 @@ S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr)
assert(mg);
Perl_magic_clearisa(aTHX_ NULL, mg);
}
+ else if (stype == SVt_PVIO) {
+ DEBUG_o(Perl_deb(aTHX_ "glob_assign_ref clearing
PL_stashcache\n"));
+ /* It's a cache. It will rebuild itself quite happily.
+ It's a lot of effort to work out exactly which key (or keys)
+ might be invalidated by the creation of the this file handle.
+ */
+ hv_clear(PL_stashcache);
+ }
break;
}
SvREFCNT_dec(dref);
@@ -6047,9 +6056,12 @@ Perl_sv_clear(pTHX_ SV *const orig_sv)
if ( PL_phase != PERL_PHASE_DESTRUCT
&& (name = HvNAME((HV*)sv)))
{
- if (PL_stashcache)
+ if (PL_stashcache) {
+ DEBUG_o(Perl_deb(aTHX_ "sv_clear clearing PL_stashcache
for '%"SVf"'\n",
+ sv));
(void)hv_delete(PL_stashcache, name,
HvNAMEUTF8((HV*)sv) ? -HvNAMELEN_get((HV*)sv) :
HvNAMELEN_get((HV*)sv), G_DISCARD);
+ }
hv_name_set((HV*)sv, NULL, 0, 0);
}
diff --git a/t/lib/Count.pm b/t/lib/Count.pm
new file mode 100644
index 0000000..635b5de
--- /dev/null
+++ b/t/lib/Count.pm
@@ -0,0 +1,8 @@
+# zero! ha ha ha
+package Count;
+"ha!";
+__DATA__
+one! ha ha ha
+two! ha ha ha
+three! ha ha ha
+four! ha ha ha
diff --git a/t/op/method.t b/t/op/method.t
index 799eda0..5ed8f76 100644
--- a/t/op/method.t
+++ b/t/op/method.t
@@ -6,14 +6,14 @@
BEGIN {
chdir 't' if -d 't';
- @INC = qw(. ../lib);
+ @INC = qw(. ../lib lib);
require "test.pl";
}
use strict;
no warnings 'once';
-plan(tests => 116);
+plan(tests => 141);
@A::ISA = 'B';
@B::ISA = 'C';
@@ -489,3 +489,135 @@ like $@,
is "3foo"->CORE::uc, '3FOO', '"3foo"->CORE::uc';
{ no strict; @{"3foo::ISA"} = "CORE"; }
is "3foo"->uc, '3FOO', '"3foo"->uc (autobox style!)';
+
+# Test that PL_stashcache doesn't change the resolution behaviour for file
+# handles and package names.
+SKIP: {
+ skip_if_miniperl('file handles as methods requires loading IO::File', 25);
+ require Fcntl;
+
+ foreach (qw (Count::DATA Count Colour::H1 Color::H1 C3::H1)) {
+ eval qq{
+ package $_;
+
+ sub getline {
+ return "method in $_";
+ }
+
+ 1;
+ } or die $@;
+ }
+
+ BEGIN {
+ *The::Count:: = \*Count::;
+ }
+
+ is(Count::DATA->getline(), 'method in Count::DATA',
+ 'initial resolution is a method');
+ is(The::Count::DATA->getline(), 'method in Count::DATA',
+ 'initial resolution is a method in aliased classes');
+
+ require Count;
+
+ is(Count::DATA->getline(), "one! ha ha ha\n", 'file handles take
priority');
+ is(The::Count::DATA->getline(), "two! ha ha ha\n",
+ 'file handles take priority in aliased classes');
+
+ eval q{close Count::DATA} or die $!;
+
+ {
+ no warnings 'io';
+ is(Count::DATA->getline(), undef,
+ "closing a file handle doesn't change object resolution");
+ is(The::Count::DATA->getline(), undef,
+ "closing a file handle doesn't change object resolution in aliased
classes");
+}
+
+ undef *Count::DATA;
+ is(Count::DATA->getline(), 'method in Count::DATA',
+ 'undefining the typeglob does change object resolution');
+ is(The::Count::DATA->getline(), 'method in Count::DATA',
+ 'undefining the typeglob does change object resolution in aliased
classes');
+
+ is(Count->getline(), 'method in Count',
+ 'initial resolution is a method');
+ is(The::Count->getline(), 'method in Count',
+ 'initial resolution is a method in aliased classes');
+
+ eval q{
+ open Count, '<', $INC{'Count.pm'}
+ or die "Can't open $INC{'Count.pm'}: $!";
+1;
+ } or die $@;
+
+ is(Count->getline(), "# zero! ha ha ha\n", 'file handles take priority');
+ is(The::Count->getline(), 'method in Count', 'but not in an aliased
class');
+
+ eval q{close Count} or die $!;
+
+ {
+ no warnings 'io';
+ is(Count->getline(), undef,
+ "closing a file handle doesn't change object resolution");
+ }
+
+ undef *Count;
+ is(Count->getline(), 'method in Count',
+ 'undefining the typeglob does change object resolution');
+
+ open Colour::H1, 'op/method.t' or die $!;
+ while (<Colour::H1>) {
+ last if /^__END__/;
+ }
+ open CLOSED, 'TEST' or die $!;
+ close CLOSED or die $!;
+
+ my $fh_start = tell Colour::H1;
+ my $data_start = tell DATA;
+ is(Colour::H1->getline(), <DATA>, 'read from a file');
+ is(Color::H1->getline(), 'method in Color::H1',
+ 'initial resolution is a method');
+
+ *Color::H1 = *Colour::H1{IO};
+
+ is(Colour::H1->getline(), <DATA>, 'read from a file');
+ is(Color::H1->getline(), <DATA>,
+ 'file handles take priority after typeglob assignment');
+
+ *Color::H1 = *CLOSED{IO};
+ {
+ no warnings 'io';
+ is(Color::H1->getline(), undef,
+ "assigning a closed a file handle doesn't change object resolution");
+ }
+
+ undef *Color::H1;
+ is(Color::H1->getline(), 'method in Color::H1',
+ 'undefining the typeglob does change object resolution');
+
+ seek Colour::H1, $fh_start, Fcntl::SEEK_SET() or die $!;
+ seek DATA, $data_start, Fcntl::SEEK_SET() or die $!;
+
+ is(Colour::H1->getline(), <DATA>, 'read from a file');
+ is(C3::H1->getline(), 'method in C3::H1', 'intial resolution is a method');
+
+ *Copy:: = \*C3::;
+ *C3:: = \*Colour::;
+
+ is(Colour::H1->getline(), <DATA>, 'read from a file');
+ is(C3::H1->getline(), <DATA>,
+ 'file handles take priority after stash aliasing');
+
+ *C3:: = \*Copy::;
+
+ is(C3::H1->getline(), 'method in C3::H1',
+ 'restoring the stash returns to a method');
+}
+
+__END__
+#FF9900
+#F78C08
+#FFA500
+#FF4D00
+#FC5100
+#FF5D00
--
Perl5 Master Repository
