In perl.git, the branch blead has been updated
<http://perl5.git.perl.org/perl.git/commitdiff/26a6507471ec85dcb2e7186a21d6d849b1ea1bb7?hp=989690ac118eb981de3afdd9b2e092362f453d31>
- Log -----------------------------------------------------------------
commit 26a6507471ec85dcb2e7186a21d6d849b1ea1bb7
Author: Karl Williamson <pub...@khwilliamson.com>
Date: Wed Oct 6 22:16:56 2010 -0600
charnames.t: Make sure code point aliasess are right
Some code points have two (possibly more names). This makes sure that
all work.
M lib/charnames.t
commit 1c757d3c33b6ccddf49d99ccb22ccd0029ef7b84
Author: Karl Williamson <pub...@khwilliamson.com>
Date: Wed Oct 6 22:12:35 2010 -0600
charnames.t: Extract common code to subroutine
M lib/charnames.t
commit 62c1e33fbe385549e958f7699d17bfc9e0cd1ca2
Author: Father Chrysostomos <spr...@cpan.org>
Date: Tue Oct 12 22:07:17 2010 -0700
[perl #78362] Make mro_package_moved check for recursion
The existence of main::main::... caused mro_package_moved to break
Text::Template, and probably Acme::Meta as well.
M embed.fnc
M mro.c
M proto.h
M t/mro/package_aliases.t
-----------------------------------------------------------------------
Summary of changes:
embed.fnc | 2 +-
lib/charnames.t | 32 +++++++++++++++++++-------------
mro.c | 31 +++++++++++++++++++++++++------
proto.h | 2 +-
t/mro/package_aliases.t | 9 ++++++++-
5 files changed, 54 insertions(+), 22 deletions(-)
diff --git a/embed.fnc b/embed.fnc
index e111448..ee596d1 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -2362,7 +2362,7 @@ sd |AV* |mro_get_linear_isa_dfs|NN HV*
stash|U32 level
md |void |mro_isa_changed_in|NN HV* stash
pd |void |mro_isa_changed_in3|NULLOK HV* stash|NULLOK const char
*stashname|STRLEN stashname_len
Apd |void |mro_method_changed_in |NN HV* stash
-pdx |void |mro_package_moved |NULLOK HV * const stash|NULLOK const
HV * const oldstash|NULLOK const GV * const gv|NULLOK const char
*newname|STRLEN newname_len
+pdx |void |mro_package_moved |NULLOK HV * const stash|NULLOK const
HV * const oldstash|NULLOK const GV * const gv|NULLOK const char *newname|I32
newname_len
: Only used in perl.c
p |void |boot_core_mro
Apon |void |sys_init |NN int* argc|NN char*** argv
diff --git a/lib/charnames.t b/lib/charnames.t
index 54e1be4..4944266 100644
--- a/lib/charnames.t
+++ b/lib/charnames.t
@@ -94,6 +94,17 @@ sub to_bytes {
unpack"U0a*", shift;
}
+sub test_vianame ($$$) {
+
+ # Run the vianame tests on a code point
+
+ my ($i, $hex, $name) = @_;
+
+ # Half the time use vianame, and half string_vianame
+ return is(charnames::vianame($name), $i, "Verify vianame(\"$name\") is
0x$hex") if rand() < .5;
+ return is(charnames::string_vianame($name), chr($i), "Verify
string_vianame(\"$name\") is chr(0x$hex)");
+}
+
{
use charnames ':full';
@@ -943,12 +954,12 @@ is("\N{U+1D0C5}", "\N{BYZANTINE MUSICAL SYMBOL FTHORA
SKLIRON CHROMA VASIS}");
s/^\s*#.*//;
next unless $_;
my ($hex, $name) = split ";";
- if (rand() < .5) {
- is(charnames::vianame($name), hex $hex, "Verify vianame(\"$name\")
is 0x$hex");
- }
- else {
- is(charnames::string_vianame($name), chr(hex $hex), "Verify
string_vianame(\"$name\") is chr(0x$hex)");
- }
+ my $i = CORE::hex $hex;
+
+ # Make sure that both aliases (the one in UnicodeData, and the one we
+ # just read) return the same code point.
+ test_vianame($i, $hex, $name);
+ test_vianame($i, $hex, $names[$i]);
}
close $fh;
@@ -1012,13 +1023,8 @@ is("\N{U+1D0C5}", "\N{BYZANTINE MUSICAL SYMBOL FTHORA
SKLIRON CHROMA VASIS}");
} else {
# Otherwise, test that the name and code point map
- # correctly. Half the time use vianame, and half
- # string_vianame
- if (rand() < .5) {
- $all_pass &= is(charnames::vianame($names[$i]), $i,
"Verify vianame(\"$names[$i]\") is 0x$hex");
- } else {
- $all_pass &= is(charnames::string_vianame($names[$i]),
chr($i), "Verify string_vianame(\"$names[$i]\") is chr(0x$hex)");
- }
+ # correctly.
+ $all_pass &= test_vianame($i, $hex, $names[$i]);
$all_pass &= is(charnames::viacode($i), $names[$i], "Verify
viacode(0x$hex) is \"$names[$i]\"");
# And make sure that a non-algorithmically named code
diff --git a/mro.c b/mro.c
index 84626a5..830ef5a 100644
--- a/mro.c
+++ b/mro.c
@@ -589,26 +589,35 @@ non-existent packages that have corresponding entries in
C<stash>.
void
Perl_mro_package_moved(pTHX_ HV * const stash, const HV * const oldstash,
const GV * const gv, const char *newname,
- STRLEN newname_len)
+ I32 newname_len)
{
register XPVHV* xhv;
register HE *entry;
I32 riter = -1;
HV *seen = NULL;
+ /* If newname_len is negative, it is actually the call depth (negated).
+ */
+ const I32 level = newname_len < 0 ? newname_len : 0;
assert(stash || oldstash);
assert(oldstash || gv || newname);
+ if(level < -100) return;
+
if(!newname && oldstash) {
newname = HvNAME_get(oldstash);
newname_len = HvNAMELEN_get(oldstash);
}
if(!newname && gv) {
SV * const namesv = sv_newmortal();
+ STRLEN len;
gv_fullname4(namesv, gv, NULL, 0);
- newname = SvPV_const(namesv, newname_len);
- newname_len -= 2; /* skip trailing :: */
+ newname = SvPV_const(namesv, len);
+ newname_len = len - 2; /* skip trailing :: */
}
+ /* XXX This relies on the fact that package names cannot contain nulls.
+ */
+ if(newname_len < 0) newname_len = strlen(newname);
mro_isa_changed_in3((HV *)oldstash, newname, newname_len);
@@ -649,13 +658,17 @@ Perl_mro_package_moved(pTHX_ HV * const stash, const HV *
const oldstash,
SV ** const stashentry
= stash ? hv_fetch(stash, key, len, 0) : NULL;
HV *substash;
+
+ /* Avoid main::main::main::... */
+ if(oldsubstash == oldstash) continue;
+
if(
stashentry && *stashentry
&& (substash = GvHV(*stashentry))
&& HvNAME(substash)
)
mro_package_moved(
- substash, oldsubstash, NULL, NULL, 0
+ substash, oldsubstash, NULL, NULL, level-1
);
else if(oldsubstash && HvNAME(oldsubstash))
mro_isa_changed_in(oldsubstash);
@@ -697,15 +710,21 @@ Perl_mro_package_moved(pTHX_ HV * const stash, const HV *
const oldstash,
substash = GvHV(HeVAL(entry));
if(substash && HvNAME(substash)) {
+ SV *namesv;
+
+ /* Avoid checking main::main::main::... */
+ if(substash == stash) continue;
+
/* Add :: and the key (minus the trailing ::)
to newname. */
- SV *namesv
+ namesv
= newSVpvn_flags(newname, newname_len, SVs_TEMP);
sv_catpvs(namesv, "::");
sv_catpvn(namesv, key, len-2);
mro_package_moved(
substash, NULL, NULL,
- SvPV_nolen_const(namesv), newname_len+len
+ SvPV_nolen_const(namesv),
+ level-1
);
}
}
diff --git a/proto.h b/proto.h
index aff9574..23577f9 100644
--- a/proto.h
+++ b/proto.h
@@ -2256,7 +2256,7 @@ PERL_CALLCONV void
Perl_mro_method_changed_in(pTHX_ HV* stash)
#define PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN \
assert(stash)
-PERL_CALLCONV void Perl_mro_package_moved(pTHX_ HV * const stash, const HV
* const oldstash, const GV * const gv, const char *newname, STRLEN newname_len);
+PERL_CALLCONV void Perl_mro_package_moved(pTHX_ HV * const stash, const HV
* const oldstash, const GV * const gv, const char *newname, I32 newname_len);
PERL_CALLCONV void Perl_mro_register(pTHX_ const struct mro_alg *mro)
__attribute__nonnull__(pTHX_1);
#define PERL_ARGS_ASSERT_MRO_REGISTER \
diff --git a/t/mro/package_aliases.t b/t/mro/package_aliases.t
index 3f13a76..8b54ebd 100644
--- a/t/mro/package_aliases.t
+++ b/t/mro/package_aliases.t
@@ -10,7 +10,7 @@ BEGIN {
use strict;
use warnings;
-plan(tests => 15);
+plan(tests => 16);
{
package New;
@@ -192,3 +192,10 @@ for(
is $pet->speak, 'Woof!',
'the deleted stash is gone completely when freed';
}
+
+# mro_package_moved needs to check for self-referential packages.
+# This broke Text::Template [perl #78362].
+watchdog 3;
+*foo:: = \%::;
+*Acme::META::Acme:: = \*Acme::; # indirect self-reference
+pass("mro_package_moved and self-referential packages");
--
Perl5 Master Repository
