t/lib/warnings/utf8 Tests for utf8.c for warnings.t
t/lib/warnings/util Tests for util.c for warnings.t
t/mro/basic_01_c3.t mro tests
+t/mro/basic_01_c3_utf8.t utf8 mro tests
t/mro/basic_01_dfs.t mro tests
+t/mro/basic_01_dfs_utf8.t utf8 mro tests
t/mro/basic_02_c3.t mro tests
+t/mro/basic_02_c3_utf8.t utf8 mro tests
t/mro/basic_02_dfs.t mro tests
+t/mro/basic_02_dfs_utf8.t utf8 mro tests
t/mro/basic_03_c3.t mro tests
+t/mro/basic_03_c3_utf8.t utf8 mro tests
t/mro/basic_03_dfs.t mro tests
+t/mro/basic_03_dfs_utf8.t utf8 mro tests
t/mro/basic_04_c3.t mro tests
+t/mro/basic_04_c3_utf8.t utf8 mro tests
t/mro/basic_04_dfs.t mro tests
+t/mro/basic_04_dfs_utf8.t utf8 mro tests
t/mro/basic_05_c3.t mro tests
+t/mro/basic_05_c3_utf8.t utf8 mro tests
t/mro/basic_05_dfs.t mro tests
+t/mro/basic_05_dfs_utf8.t utf8 mro tests
t/mro/basic.t mro tests
+t/mro/basic_utf8.t utf8 mro tests
t/mro/c3_with_overload.t mro tests
+t/mro/c3_with_overload_utf8.t utf8 mro tests
t/mro/complex_c3.t mro tests
+t/mro/complex_c3_utf8.t utf8 mro tests
t/mro/complex_dfs.t mro tests
+t/mro/complex_dfs_utf8.t utf8 mro tests
t/mro/dbic_c3.t mro tests
+t/mro/dbic_c3_utf8.t utf8 mro tests
t/mro/dbic_dfs.t mro tests
+t/mro/dbic_dfs_utf8.t utf8 mro tests
t/mro/inconsistent_c3.t mro tests
+t/mro/inconsistent_c3_utf8.t utf8 mro tests
t/mro/isa_aliases.t tests for shared @ISA arrays
+t/mro/isa_aliases_utf8.t utf8 mro tests
t/mro/isa_c3.t test for optimisatised mro_get_linear_isa_c3
+t/mro/isa_c3_utf8.t utf8 mro tests
t/mro/isa_dfs.t test for optimisatised mro_get_linear_isa_dfs
+t/mro/isa_dfs_utf8.t utf8 mro tests
t/mro/isarev.t PL_isarev/mro::get_isarev tests
+t/mro/isarev_utf8.t utf8 mro tests
t/mro/method_caching.t mro tests
+t/mro/method_caching_utf8.t utf8 mro tests
t/mro/next_edgecases.t mro tests
+t/mro/next_edgecases_utf8.t utf8 mro tests
t/mro/next_goto.t mro tests
+t/mro/next_goto_utf8.t utf8 mro tests
t/mro/next_inanon.t mro tests
+t/mro/next_inanon_utf8.t utf8 mro tests
t/mro/next_ineval.t mro tests
+t/mro/next_ineval_utf8.t utf8 mro tests
t/mro/next_method.t mro tests
+t/mro/next_method_utf8.t utf8 mro tests
t/mro/next_NEXT.t mro tests
+t/mro/next_NEXT_utf8.t utf8 mro tests
t/mro/next_skip.t mro tests
+t/mro/next_skip_utf8.t utf8 mro tests
t/mro/overload_c3.t mro tests
+t/mro/overload_c3_utf8.t utf8 mro tests
t/mro/overload_dfs.t mro tests
t/mro/package_aliases.t mro tests
+t/mro/package_aliases_utf8.t utf8 mro tests
t/mro/pkg_gen.t mro tests
+t/mro/pkg_gen_utf8.t utf8 mro tests
t/mro/recursion_c3.t mro tests
+t/mro/recursion_c3_utf8.t utf8 mro tests
t/mro/recursion_dfs.t mro tests
+t/mro/recursion_dfs_utf8.t utf8 mro tests
t/mro/vulcan_c3.t mro tests
+t/mro/vulcan_c3_utf8.t utf8 mro tests
t/mro/vulcan_dfs.t mro tests
+t/mro/vulcan_dfs_utf8.t utf8 mro tests
toke.c The tokener
t/op/64bitint.t See if 64 bit integers work
t/op/alarm.t See if alarm works
s |void |mro_clean_isarev|NN HV * const isa \
|NN const char * const name \
|const STRLEN len \
- |NULLOK HV * const exceptions
+ |NULLOK HV * const exceptions|U32 flags
s |void |mro_gather_and_rename|NN HV * const stashes \
|NN HV * const seen_stashes \
|NULLOK HV *stash \
#define unwind_handler_stack(a) S_unwind_handler_stack(aTHX_ a)
# endif
# if defined(PERL_IN_MRO_C)
-#define mro_clean_isarev(a,b,c,d) S_mro_clean_isarev(aTHX_ a,b,c,d)
+#define mro_clean_isarev(a,b,c,d,e) S_mro_clean_isarev(aTHX_ a,b,c,d,e)
#define mro_gather_and_rename(a,b,c,d,e) S_mro_gather_and_rename(aTHX_ a,b,c,d,e)
#define mro_get_linear_isa_dfs(a,b) S_mro_get_linear_isa_dfs(aTHX_ a,b)
# endif
SV *stashname;
const char *fq_subname;
const char *subname;
+ bool subname_utf8 = 0;
STRLEN stashname_len;
STRLEN subname_len;
SV* sv;
fq_subname = SvPVX(sv);
fq_subname_len = SvCUR(sv);
+ subname_utf8 = SvUTF8(sv) ? 1 : 0;
subname = strrchr(fq_subname, ':');
} else {
subname = NULL;
/* beyond here is just for cache misses, so perf isn't as critical */
stashname_len = subname - fq_subname - 2;
- stashname = newSVpvn_flags(fq_subname, stashname_len, SVs_TEMP);
+ stashname = newSVpvn_flags(fq_subname, stashname_len,
+ SVs_TEMP | (subname_utf8 ? SVf_UTF8 : 0));
/* has ourselves at the top of the list */
linear_av = S_mro_get_linear_isa_c3(aTHX_ selfstash, 0);
assert(curstash);
- gvp = (GV**)hv_fetch(curstash, subname, subname_len, 0);
+ gvp = (GV**)hv_fetch(curstash, subname,
+ subname_utf8 ? -subname_len : subname_len, 0);
if (!gvp) continue;
candidate = *gvp;
assert(candidate);
if (SvTYPE(candidate) != SVt_PVGV)
- gv_init(candidate, curstash, subname, subname_len, TRUE);
+ gv_init_pvn(candidate, curstash, subname, subname_len,
+ GV_ADDMULTI|(subname_utf8 ? SVf_UTF8 : 0));
/* Notably, we only look for real entries, not method cache
entries, because in C3 the method cache of a parent is not
const char * const stashname = HvENAME_get(stash);
const STRLEN stashname_len = HvENAMELEN_get(stash);
+ const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
PERL_ARGS_ASSERT_MRO_ISA_CHANGED_IN;
/* Wipe the global method cache if this package
is UNIVERSAL or one of its parents */
- svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
+ svp = hv_fetch(PL_isarev, stashname,
+ stashname_utf8 ? -stashname_len : stashname_len, 0);
isarev = svp ? MUTABLE_HV(*svp) : NULL;
if((stashname_len == 9 && strEQ(stashname, "UNIVERSAL"))
isa_hashes = (HV *)sv_2mortal((SV *)newHV());
}
while((iter = hv_iternext(isarev))) {
- I32 len;
- const char* const revkey = hv_iterkey(iter, &len);
- HV* revstash = gv_stashpvn(revkey, len, 0);
+ HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
struct mro_meta* revmeta;
if(!revstash) continue;
(void)
hv_store(
- mroisarev, HEK_KEY(namehek), HEK_LEN(namehek),
+ mroisarev, HEK_KEY(namehek),
+ HEK_UTF8(namehek) ? -HEK_LEN(namehek) : HEK_LEN(namehek),
&PL_sv_yes, 0
);
}
if((SV *)isa != &PL_sv_undef)
mro_clean_isarev(
isa, HEK_KEY(namehek), HEK_LEN(namehek),
- HvMROMETA(revstash)->isa
+ HvMROMETA(revstash)->isa, (HEK_UTF8(namehek) ? SVf_UTF8 : 0)
);
}
}
save time by not making two calls to the common HV code for the
case where it doesn't exist. */
- (void)hv_store(mroisarev, stashname, stashname_len, &PL_sv_yes, 0);
+ (void)hv_store(mroisarev, stashname,
+ stashname_utf8 ? -stashname_len : stashname_len, &PL_sv_yes, 0);
}
/* Delete our name from our former parents’ isarevs. */
if(isa && HvARRAY(isa))
- mro_clean_isarev(isa, stashname, stashname_len, meta->isa);
+ mro_clean_isarev(isa, stashname, stashname_len, meta->isa,
+ (stashname_utf8 ? SVf_UTF8 : 0) );
}
/* Deletes name from all the isarev entries listed in isa */
STATIC void
S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name,
- const STRLEN len, HV * const exceptions)
+ const STRLEN len, HV * const exceptions, U32 flags)
{
HE* iter;
while((iter = hv_iternext(isa))) {
I32 klen;
const char * const key = hv_iterkey(iter, &klen);
- if(exceptions && hv_exists(exceptions, key, klen)) continue;
- svp = hv_fetch(PL_isarev, key, klen, 0);
+ if(exceptions && hv_exists(exceptions, key, HeKUTF8(iter) ? -klen : klen))
+ continue;
+ svp = hv_fetch(PL_isarev, key, HeKUTF8(iter) ? -klen : klen, 0);
if(svp) {
HV * const isarev = (HV *)*svp;
- (void)hv_delete(isarev, name, len, G_DISCARD);
+ (void)hv_delete(isarev, name, (flags & SVf_UTF8) ? -len : len, G_DISCARD);
if(!HvARRAY(isarev) || !HvUSEDKEYS(isarev))
- (void)hv_delete(PL_isarev, key, klen, G_DISCARD);
+ (void)hv_delete(PL_isarev, key,
+ HeKUTF8(iter) ? -klen : klen, G_DISCARD);
}
}
}
SV **svp;
if(
!GvSTASH(gv) || !HvENAME(GvSTASH(gv)) ||
- !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), 0)) ||
+ !(svp = hv_fetch(GvSTASH(gv), GvNAME(gv),
+ GvNAMEUTF8(gv) ? -GvNAMELEN(gv) : GvNAMELEN(gv), 0)) ||
*svp != (SV *)gv
) return;
}
if (GvNAMELEN(gv) == 1) sv_catpvs(namesv, ":");
else sv_catpvs(namesv, "::");
}
- if (GvNAMELEN(gv) != 1)
+ if (GvNAMELEN(gv) != 1) {
sv_catpvn(namesv, GvNAME(gv), GvNAMELEN(gv) - 2);
/* skip trailing :: */
+ if ( GvNAMEUTF8(gv) )
+ SvUTF8_on(namesv);
+ }
}
else {
SV *aname;
if (GvNAMELEN(gv) == 1) sv_catpvs(aname, ":");
else sv_catpvs(aname, "::");
}
- if (GvNAMELEN(gv) != 1)
+ if (GvNAMELEN(gv) != 1) {
sv_catpvn(aname, GvNAME(gv), GvNAMELEN(gv) - 2);
/* skip trailing :: */
+ if ( GvNAMEUTF8(gv) )
+ SvUTF8_on(aname);
+ }
av_push((AV *)namesv, aname);
}
}
svp = &namesv;
}
while (items--) {
+ const U32 name_utf8 = SvUTF8(*svp);
STRLEN len;
const char *name = SvPVx_const(*svp++, len);
if(PL_stashcache)
- (void)hv_delete(PL_stashcache, name, len, G_DISCARD);
- hv_ename_delete(oldstash, name, len, 0);
+ (void)hv_delete(PL_stashcache, name, name_utf8 ? -len : len, G_DISCARD);
+ hv_ename_delete(oldstash, name, len, name_utf8);
if (!fetched_isarev) {
/* If the name deletion caused a name change, then we
* fies it for us, so sv_2mortal is not necessary. */
if(HvENAME_HEK(oldstash) != enamehek) {
if(meta->isa && HvARRAY(meta->isa))
- mro_clean_isarev(meta->isa, name, len, NULL);
- isarev = (HV *)hv_delete(PL_isarev, name, len, 0);
+ mro_clean_isarev(meta->isa, name, len, 0, name_utf8);
+ isarev = (HV *)hv_delete(PL_isarev, name,
+ name_utf8 ? -len : len, 0);
fetched_isarev=TRUE;
}
}
svp = &namesv;
}
while (items--) {
+ const U32 name_utf8 = SvUTF8(*svp);
STRLEN len;
const char *name = SvPVx_const(*svp++, len);
- hv_ename_add(stash, name, len, 0);
+ hv_ename_add(stash, name, len, name_utf8);
}
/* Add it to the big list if it needs
/* Extra variable to avoid a compiler warning */
char * const hvename = HvENAME(oldstash);
fetched_isarev = TRUE;
- svp = hv_fetch(PL_isarev, hvename, HvENAMELEN_get(oldstash), 0);
+ svp = hv_fetch(PL_isarev, hvename,
+ HvENAMEUTF8(oldstash)
+ ? -HvENAMELEN_get(oldstash)
+ : HvENAMELEN_get(oldstash), 0);
if (svp) isarev = MUTABLE_HV(*svp);
}
else if(SvTYPE(namesv) == SVt_PVAV) {
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
- I32 len;
- const char* const revkey = hv_iterkey(iter, &len);
- HV* revstash = gv_stashpvn(revkey, len, 0);
+ HV* revstash = gv_stashsv(hv_iterkeysv(iter), 0);
struct mro_meta * meta;
if(!revstash) continue;
/* Iterate through the entries in this list */
for(; entry; entry = HeNEXT(entry)) {
+ SV* keysv;
const char* key;
- I32 len;
+ STRLEN len;
/* If this entry is not a glob, ignore it.
Try the next. */
if (!isGV(HeVAL(entry))) continue;
- key = hv_iterkey(entry, &len);
+ keysv = hv_iterkeysv(entry);
+ key = SvPV_const(keysv, len);
if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
|| (len == 1 && key[0] == ':')) {
HV * const oldsubstash = GvHV(HeVAL(entry));
SV ** const stashentry
- = stash ? hv_fetch(stash, key, len, 0) : NULL;
+ = stash ? hv_fetch(stash, key, SvUTF8(keysv) ? -len : len, 0) : NULL;
HV *substash = NULL;
/* Avoid main::main::main::... */
else {
sv_catpvs(aname, "::");
sv_catpvn(aname, key, len-2);
+ if ( SvUTF8(keysv) )
+ SvUTF8_on(aname);
}
av_push((AV *)subname, aname);
}
else {
sv_catpvs(subname, "::");
sv_catpvn(subname, key, len-2);
+ if ( SvUTF8(keysv) )
+ SvUTF8_on(subname);
}
}
mro_gather_and_rename(
);
}
- (void)hv_store(seen, key, len, &PL_sv_yes, 0);
+ (void)hv_store(seen, key, SvUTF8(keysv) ? -len : len, &PL_sv_yes, 0);
}
}
}
/* Iterate through the entries in this list */
for(; entry; entry = HeNEXT(entry)) {
+ SV* keysv;
const char* key;
- I32 len;
+ STRLEN len;
/* If this entry is not a glob, ignore it.
Try the next. */
if (!isGV(HeVAL(entry))) continue;
- key = hv_iterkey(entry, &len);
+ keysv = hv_iterkeysv(entry);
+ key = SvPV_const(keysv, len);
if ((len > 1 && key[len-2] == ':' && key[len-1] == ':')
|| (len == 1 && key[0] == ':')) {
HV *substash;
/* If this entry was seen when we iterated through the
oldstash, skip it. */
- if(seen && hv_exists(seen, key, len)) continue;
+ if(seen && hv_exists(seen, key, SvUTF8(keysv) ? -len : len)) continue;
/* We get here only if this stash has no corresponding
entry in the stash being replaced. */
else {
sv_catpvs(aname, "::");
sv_catpvn(aname, key, len-2);
+ if ( SvUTF8(keysv) )
+ SvUTF8_on(aname);
}
av_push((AV *)subname, aname);
}
else {
sv_catpvs(subname, "::");
sv_catpvn(subname, key, len-2);
+ if ( SvUTF8(keysv) )
+ SvUTF8_on(subname);
}
}
mro_gather_and_rename(
{
const char * const stashname = HvENAME_get(stash);
const STRLEN stashname_len = HvENAMELEN_get(stash);
+ const bool stashname_utf8 = HvENAMEUTF8(stash) ? 1 : 0;
- SV ** const svp = hv_fetch(PL_isarev, stashname, stashname_len, 0);
+ SV ** const svp = hv_fetch(PL_isarev, stashname,
+ stashname_utf8 ? -stashname_len : stashname_len, 0);
HV * const isarev = svp ? MUTABLE_HV(*svp) : NULL;
PERL_ARGS_ASSERT_MRO_METHOD_CHANGED_IN;
hv_iterinit(isarev);
while((iter = hv_iternext(isarev))) {
- I32 len;
- const char* const revkey = hv_iterkey(iter, &len);
- HV* const revstash = gv_stashpvn(revkey, len, 0);
+ HV* const revstash = gv_stashsv(hv_iterkeysv(iter), 0);
struct mro_meta* mrometa;
if(!revstash) continue;
STATIC void S_unwind_handler_stack(pTHX_ const void *p);
#endif
#if defined(PERL_IN_MRO_C)
-STATIC void S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name, const STRLEN len, HV * const exceptions)
+STATIC void S_mro_clean_isarev(pTHX_ HV * const isa, const char * const name, const STRLEN len, HV * const exceptions, U32 flags)
__attribute__nonnull__(pTHX_1)
__attribute__nonnull__(pTHX_2);
#define PERL_ARGS_ASSERT_MRO_CLEAN_ISAREV \
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 4);
+
+=pod
+
+This tests the classic diamond inheritance pattern.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Ｄiᚪၚd_A;
+ sub hèllò { 'Ｄiᚪၚd_A::hèllò' }
+}
+{
+ package Ｄiᚪၚd_B;
+ use base 'Ｄiᚪၚd_A';
+}
+{
+ package Ｄiᚪၚd_C;
+ use base 'Ｄiᚪၚd_A';
+
+ sub hèllò { 'Ｄiᚪၚd_C::hèllò' }
+}
+{
+ package Ｄiᚪၚd_D;
+ use base ('Ｄiᚪၚd_B', 'Ｄiᚪၚd_C');
+ use mro 'c3';
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ｄiᚪၚd_D'),
+ [ qw(Ｄiᚪၚd_D Ｄiᚪၚd_B Ｄiᚪၚd_C Ｄiᚪၚd_A) ]
+), '... got the right MRO for Ｄiᚪၚd_D');
+
+is(Ｄiᚪၚd_D->hèllò, 'Ｄiᚪၚd_C::hèllò', '... method resolved itself as expected');
+is(Ｄiᚪၚd_D->can('hèllò')->(), 'Ｄiᚪၚd_C::hèllò', '... can(method) resolved itself as expected');
+is(UNIVERSAL::can("Ｄiᚪၚd_D", 'hèllò')->(), 'Ｄiᚪၚd_C::hèllò', '... can(method) resolved itself as expected');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 4);
+
+=pod
+
+This tests the classic diamond inheritance pattern.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Ｄiᚪၚd_A;
+ sub hèllò { 'Ｄiᚪၚd_A::hèllò' }
+}
+{
+ package Ｄiᚪၚd_B;
+ use base 'Ｄiᚪၚd_A';
+}
+{
+ package Ｄiᚪၚd_C;
+ use base 'Ｄiᚪၚd_A';
+
+ sub hèllò { 'Ｄiᚪၚd_C::hèllò' }
+}
+{
+ package Ｄiᚪၚd_D;
+ use base ('Ｄiᚪၚd_B', 'Ｄiᚪၚd_C');
+ use mro 'dfs';
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ｄiᚪၚd_D'),
+ [ qw(Ｄiᚪၚd_D Ｄiᚪၚd_B Ｄiᚪၚd_A Ｄiᚪၚd_C) ]
+), '... got the right MRO for Ｄiᚪၚd_D');
+
+is(Ｄiᚪၚd_D->hèllò, 'Ｄiᚪၚd_A::hèllò', '... method resolved itself as expected');
+is(Ｄiᚪၚd_D->can('hèllò')->(), 'Ｄiᚪၚd_A::hèllò', '... can(method) resolved itself as expected');
+is(UNIVERSAL::can("Ｄiᚪၚd_D", 'hèllò')->(), 'Ｄiᚪၚd_A::hèllò', '... can(method) resolved itself as expected');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 10);
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My first example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(D,E): pass
+class A(B,C): pass
+
+
+ 6
+ ---
+Level 3 | O | (more general)
+ / --- \
+ / | \ |
+ / | \ |
+ / | \ |
+ --- --- --- |
+Level 2 3 | D | 4| E | | F | 5 |
+ --- --- --- |
+ \ \ _ / | |
+ \ / \ _ | |
+ \ / \ | |
+ --- --- |
+Level 1 1 | B | | C | 2 |
+ --- --- |
+ \ / |
+ \ / \ /
+ ---
+Level 0 0 | A | (more specialized)
+ ---
+
+=cut
+
+{
+ package 텟ţ::ᴼ;
+ use mro 'c3';
+
+ package 텟ţ::Ḟ;
+ use mro 'c3';
+ use base '텟ţ::ᴼ';
+
+ package 텟ţ::ऍ;
+ use base '텟ţ::ᴼ';
+ use mro 'c3';
+
+ sub ƈ_or_ऍ { '텟ţ::ऍ' }
+
+ package 텟ţ::Ḋ;
+ use mro 'c3';
+ use base '텟ţ::ᴼ';
+
+ sub ƈ_or_Ḋ { '텟ţ::Ḋ' }
+
+ package 텟ţ::ƈ;
+ use base ('텟ţ::Ḋ', '텟ţ::Ḟ');
+ use mro 'c3';
+
+ sub ƈ_or_Ḋ { '텟ţ::ƈ' }
+ sub ƈ_or_ऍ { '텟ţ::ƈ' }
+
+ package 텟ţ::ᛒ;
+ use mro 'c3';
+ use base ('텟ţ::Ḋ', '텟ţ::ऍ');
+
+ package 텟ţ::ଅ;
+ use base ('텟ţ::ᛒ', '텟ţ::ƈ');
+ use mro 'c3';
+}
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::Ḟ'),
+ [ qw(텟ţ::Ḟ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::Ḟ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ऍ'),
+ [ qw(텟ţ::ऍ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::ऍ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::Ḋ'),
+ [ qw(텟ţ::Ḋ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::Ḋ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ƈ'),
+ [ qw(텟ţ::ƈ 텟ţ::Ḋ 텟ţ::Ḟ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::ƈ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ᛒ'),
+ [ qw(텟ţ::ᛒ 텟ţ::Ḋ 텟ţ::ऍ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::ᛒ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ଅ'),
+ [ qw(텟ţ::ଅ 텟ţ::ᛒ 텟ţ::ƈ 텟ţ::Ḋ 텟ţ::ऍ 텟ţ::Ḟ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::ଅ');
+
+is(텟ţ::ଅ->ƈ_or_Ḋ, '텟ţ::ƈ', '... got the expected method output');
+is(텟ţ::ଅ->can('ƈ_or_Ḋ')->(), '텟ţ::ƈ', '... can got the expected method output');
+is(텟ţ::ଅ->ƈ_or_ऍ, '텟ţ::ƈ', '... got the expected method output');
+is(텟ţ::ଅ->can('ƈ_or_ऍ')->(), '텟ţ::ƈ', '... can got the expected method output');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 10);
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My first example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(D,E): pass
+class A(B,C): pass
+
+
+ 6
+ ---
+Level 3 | O | (more general)
+ / --- \
+ / | \ |
+ / | \ |
+ / | \ |
+ --- --- --- |
+Level 2 3 | D | 4| E | | F | 5 |
+ --- --- --- |
+ \ \ _ / | |
+ \ / \ _ | |
+ \ / \ | |
+ --- --- |
+Level 1 1 | B | | C | 2 |
+ --- --- |
+ \ / |
+ \ / \ /
+ ---
+Level 0 0 | A | (more specialized)
+ ---
+
+=cut
+
+{
+ package 텟ţ::ᴼ;
+ use mro 'dfs';
+
+ package 텟ţ::Ḟ;
+ use mro 'dfs';
+ use base '텟ţ::ᴼ';
+
+ package 텟ţ::ऍ;
+ use base '텟ţ::ᴼ';
+ use mro 'dfs';
+
+ sub ƈ_or_ऍ { '텟ţ::ऍ' }
+
+ package 텟ţ::Ḋ;
+ use mro 'dfs';
+ use base '텟ţ::ᴼ';
+
+ sub ƈ_or_Ḋ { '텟ţ::Ḋ' }
+
+ package 텟ţ::ƈ;
+ use base ('텟ţ::Ḋ', '텟ţ::Ḟ');
+ use mro 'dfs';
+
+ sub ƈ_or_Ḋ { '텟ţ::ƈ' }
+ sub ƈ_or_ऍ { '텟ţ::ƈ' }
+
+ package 텟ţ::ᛒ;
+ use mro 'dfs';
+ use base ('텟ţ::Ḋ', '텟ţ::ऍ');
+
+ package 텟ţ::ଅ;
+ use base ('텟ţ::ᛒ', '텟ţ::ƈ');
+ use mro 'dfs';
+}
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::Ḟ'),
+ [ qw(텟ţ::Ḟ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::Ḟ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ऍ'),
+ [ qw(텟ţ::ऍ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::ऍ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::Ḋ'),
+ [ qw(텟ţ::Ḋ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::Ḋ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ƈ'),
+ [ qw(텟ţ::ƈ 텟ţ::Ḋ 텟ţ::ᴼ 텟ţ::Ḟ) ]
+), '... got the right MRO for 텟ţ::ƈ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ᛒ'),
+ [ qw(텟ţ::ᛒ 텟ţ::Ḋ 텟ţ::ᴼ 텟ţ::ऍ) ]
+), '... got the right MRO for 텟ţ::ᛒ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ଅ'),
+ [ qw(텟ţ::ଅ 텟ţ::ᛒ 텟ţ::Ḋ 텟ţ::ᴼ 텟ţ::ऍ 텟ţ::ƈ 텟ţ::Ḟ) ]
+), '... got the right MRO for 텟ţ::ଅ');
+
+is(텟ţ::ଅ->ƈ_or_Ḋ, '텟ţ::Ḋ', '... got the expected method output');
+is(텟ţ::ଅ->can('ƈ_or_Ḋ')->(), '텟ţ::Ḋ', '... can got the expected method output');
+is(텟ţ::ଅ->ƈ_or_ऍ, '텟ţ::ऍ', '... got the expected method output');
+is(텟ţ::ଅ->can('ƈ_or_ऍ')->(), '텟ţ::ऍ', '... can got the expected method output');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 4);
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My second example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(E,D): pass
+class A(B,C): pass
+
+ 6
+ ---
+Level 3 | O |
+ / --- \
+ / | \
+ / | \
+ / | \
+ --- --- ---
+Level 2 2 | E | 4 | D | | F | 5
+ --- --- ---
+ \ / \ /
+ \ / \ /
+ \ / \ /
+ --- ---
+Level 1 1 | B | | C | 3
+ --- ---
+ \ /
+ \ /
+ ---
+Level 0 0 | A |
+ ---
+
+>>> A.mro()
+(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
+<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
+<type 'object'>)
+
+=cut
+
+{
+ package 텟ţ::ᴼ;
+ use mro 'c3';
+
+ sub ᴼ_or_Ḋ { '텟ţ::ᴼ' }
+ sub ᴼ_or_Ḟ { '텟ţ::ᴼ' }
+
+ package 텟ţ::Ḟ;
+ use base '텟ţ::ᴼ';
+ use mro 'c3';
+
+ sub ᴼ_or_Ḟ { '텟ţ::Ḟ' }
+
+ package 텟ţ::ऍ;
+ use base '텟ţ::ᴼ';
+ use mro 'c3';
+
+ package 텟ţ::Ḋ;
+ use base '텟ţ::ᴼ';
+ use mro 'c3';
+
+ sub ᴼ_or_Ḋ { '텟ţ::Ḋ' }
+ sub ƈ_or_Ḋ { '텟ţ::Ḋ' }
+
+ package 텟ţ::ƈ;
+ use base ('텟ţ::Ḋ', '텟ţ::Ḟ');
+ use mro 'c3';
+
+ sub ƈ_or_Ḋ { '텟ţ::ƈ' }
+
+ package 텟ţ::ᛒ;
+ use base ('텟ţ::ऍ', '텟ţ::Ḋ');
+ use mro 'c3';
+
+ package 텟ţ::ଅ;
+ use base ('텟ţ::ᛒ', '텟ţ::ƈ');
+ use mro 'c3';
+}
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ଅ'),
+ [ qw(텟ţ::ଅ 텟ţ::ᛒ 텟ţ::ऍ 텟ţ::ƈ 텟ţ::Ḋ 텟ţ::Ḟ 텟ţ::ᴼ) ]
+), '... got the right MRO for 텟ţ::ଅ');
+
+is(텟ţ::ଅ->ᴼ_or_Ḋ, '텟ţ::Ḋ', '... got the right method dispatch');
+is(텟ţ::ଅ->ᴼ_or_Ḟ, '텟ţ::Ḟ', '... got the right method dispatch');
+
+# NOTE:
+# this test is particularly interesting because the p5 dispatch
+# would actually call 텟ţ::Ḋ before 텟ţ::ƈ and 텟ţ::Ḋ is a
+# subclass of 텟ţ::ƈ
+is(텟ţ::ଅ->ƈ_or_Ḋ, '텟ţ::ƈ', '... got the right method dispatch');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 4);
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"My second example"
+class O: pass
+class F(O): pass
+class E(O): pass
+class D(O): pass
+class C(D,F): pass
+class B(E,D): pass
+class A(B,C): pass
+
+ 6
+ ---
+Level 3 | O |
+ / --- \
+ / | \
+ / | \
+ / | \
+ --- --- ---
+Level 2 2 | E | 4 | D | | F | 5
+ --- --- ---
+ \ / \ /
+ \ / \ /
+ \ / \ /
+ --- ---
+Level 1 1 | B | | C | 3
+ --- ---
+ \ /
+ \ /
+ ---
+Level 0 0 | A |
+ ---
+
+>>> A.mro()
+(<class '__main__.A'>, <class '__main__.B'>, <class '__main__.E'>,
+<class '__main__.C'>, <class '__main__.D'>, <class '__main__.F'>,
+<type 'object'>)
+
+=cut
+
+{
+ package 텟ţ::ᴼ;
+ use mro 'dfs';
+
+ sub ᴼ_or_Ḋ { '텟ţ::ᴼ' }
+ sub ᴼ_or_Ḟ { '텟ţ::ᴼ' }
+
+ package 텟ţ::Ḟ;
+ use base '텟ţ::ᴼ';
+ use mro 'dfs';
+
+ sub ᴼ_or_Ḟ { '텟ţ::Ḟ' }
+
+ package 텟ţ::ऍ;
+ use base '텟ţ::ᴼ';
+ use mro 'dfs';
+
+ package 텟ţ::Ḋ;
+ use base '텟ţ::ᴼ';
+ use mro 'dfs';
+
+ sub ᴼ_or_Ḋ { '텟ţ::Ḋ' }
+ sub ƈ_or_Ḋ { '텟ţ::Ḋ' }
+
+ package 텟ţ::ƈ;
+ use base ('텟ţ::Ḋ', '텟ţ::Ḟ');
+ use mro 'dfs';
+
+ sub ƈ_or_Ḋ { '텟ţ::ƈ' }
+
+ package 텟ţ::ᛒ;
+ use base ('텟ţ::ऍ', '텟ţ::Ḋ');
+ use mro 'dfs';
+
+ package 텟ţ::ଅ;
+ use base ('텟ţ::ᛒ', '텟ţ::ƈ');
+ use mro 'dfs';
+}
+
+ok(eq_array(
+ mro::get_linear_isa('텟ţ::ଅ'),
+ [ qw(텟ţ::ଅ 텟ţ::ᛒ 텟ţ::ऍ 텟ţ::ᴼ 텟ţ::Ḋ 텟ţ::ƈ 텟ţ::Ḟ) ]
+), '... got the right MRO for 텟ţ::ଅ');
+
+is(텟ţ::ଅ->ᴼ_or_Ḋ, '텟ţ::ᴼ', '... got the right method dispatch');
+is(텟ţ::ଅ->ᴼ_or_Ḟ, '텟ţ::ᴼ', '... got the right method dispatch');
+
+# NOTE:
+# this test is particularly interesting because the p5 dispatch
+# would actually call 텟ţ::Ḋ before 텟ţ::ƈ and 텟ţ::Ḋ is a
+# subclass of 텟ţ::ƈ
+is(텟ţ::ଅ->ƈ_or_Ḋ, '텟ţ::Ḋ', '... got the right method dispatch');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 1);
+
+=pod
+
+From the parrot test t/pmc/object-meths.t
+
+ A B A E
+ \ / \ /
+ C D
+ \ /
+ \ /
+ F
+
+=cut
+
+{
+ package Ƭ::ŁiƁ::ଅ; use mro 'c3';
+ package Ƭ::ŁiƁ::ᛒ; use mro 'c3';
+ package Ƭ::ŁiƁ::ऍ; use mro 'c3';
+ package Ƭ::ŁiƁ::ƈ; use mro 'c3'; use base ('Ƭ::ŁiƁ::ଅ', 'Ƭ::ŁiƁ::ᛒ');
+ package Ƭ::ŁiƁ::Ḋ; use mro 'c3'; use base ('Ƭ::ŁiƁ::ଅ', 'Ƭ::ŁiƁ::ऍ');
+ package Ƭ::ŁiƁ::Ḟ; use mro 'c3'; use base ('Ƭ::ŁiƁ::ƈ', 'Ƭ::ŁiƁ::Ḋ');
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ƭ::ŁiƁ::Ḟ'),
+ [ qw(Ƭ::ŁiƁ::Ḟ Ƭ::ŁiƁ::ƈ Ƭ::ŁiƁ::Ḋ Ƭ::ŁiƁ::ଅ Ƭ::ŁiƁ::ᛒ Ƭ::ŁiƁ::ऍ) ]
+), '... got the right MRO for Ƭ::ŁiƁ::Ḟ');
+
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 1);
+
+=pod
+
+From the parrot test t/pmc/object-meths.t
+
+ ଅ ᛒ ଅ ऍ
+ \ / \ /
+ ƈ Ḋ
+ \ /
+ \ /
+ Ḟ
+
+=cut
+
+{
+ package Ƭ::ŁiƁ::ଅ; use mro 'dfs';
+ package Ƭ::ŁiƁ::ᛒ; use mro 'dfs';
+ package Ƭ::ŁiƁ::ऍ; use mro 'dfs';
+ package Ƭ::ŁiƁ::ƈ; use mro 'dfs'; use base ('Ƭ::ŁiƁ::ଅ', 'Ƭ::ŁiƁ::ᛒ');
+ package Ƭ::ŁiƁ::Ḋ; use mro 'dfs'; use base ('Ƭ::ŁiƁ::ଅ', 'Ƭ::ŁiƁ::ऍ');
+ package Ƭ::ŁiƁ::Ḟ; use mro 'dfs'; use base ('Ƭ::ŁiƁ::ƈ', 'Ƭ::ŁiƁ::Ḋ');
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ƭ::ŁiƁ::Ḟ'),
+ [ qw(Ƭ::ŁiƁ::Ḟ Ƭ::ŁiƁ::ƈ Ƭ::ŁiƁ::ଅ Ƭ::ŁiƁ::ᛒ Ƭ::ŁiƁ::Ḋ Ƭ::ŁiƁ::ऍ) ]
+), '... got the right MRO for Ƭ::ŁiƁ::Ḟ');
+
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 2);
+
+=pod
+
+This tests a strange bug found by Matt S. Trout
+while building DBIx::Class. Thanks Matt!!!!
+
+ <A>
+ / \
+<C> <B>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Ｄiᚪၚd_A;
+ use mro 'c3';
+
+ sub ᕘ { 'Ｄiᚪၚd_A::ᕘ' }
+}
+{
+ package Ｄiᚪၚd_B;
+ use base 'Ｄiᚪၚd_A';
+ use mro 'c3';
+
+ sub ᕘ { 'Ｄiᚪၚd_B::ᕘ => ' . (shift)->SUPER::ᕘ }
+}
+{
+ package Ｄiᚪၚd_C;
+ use mro 'c3';
+ use base 'Ｄiᚪၚd_A';
+
+}
+{
+ package Ｄiᚪၚd_D;
+ use base ('Ｄiᚪၚd_C', 'Ｄiᚪၚd_B');
+ use mro 'c3';
+
+ sub ᕘ { 'Ｄiᚪၚd_D::ᕘ => ' . (shift)->SUPER::ᕘ }
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ｄiᚪၚd_D'),
+ [ qw(Ｄiᚪၚd_D Ｄiᚪၚd_C Ｄiᚪၚd_B Ｄiᚪၚd_A) ]
+), '... got the right MRO for Ｄiᚪၚd_D');
+
+is(Ｄiᚪၚd_D->ᕘ,
+ 'Ｄiᚪၚd_D::ᕘ => Ｄiᚪၚd_B::ᕘ => Ｄiᚪၚd_A::ᕘ',
+ '... got the right next::method dispatch path');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 2);
+
+=pod
+
+This tests a strange bug found by Matt S. Trout
+while building DBIx::Class. Thanks Matt!!!!
+
+ <A>
+ / \
+<C> <B>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Ｄiᚪၚd_A;
+ use mro 'dfs';
+
+ sub ᕘ { 'Ｄiᚪၚd_A::ᕘ' }
+}
+{
+ package Ｄiᚪၚd_B;
+ use base 'Ｄiᚪၚd_A';
+ use mro 'dfs';
+
+ sub ᕘ { 'Ｄiᚪၚd_B::ᕘ => ' . (shift)->SUPER::ᕘ }
+}
+{
+ package Ｄiᚪၚd_C;
+ use mro 'dfs';
+ use base 'Ｄiᚪၚd_A';
+
+}
+{
+ package Ｄiᚪၚd_D;
+ use base ('Ｄiᚪၚd_C', 'Ｄiᚪၚd_B');
+ use mro 'dfs';
+
+ sub ᕘ { 'Ｄiᚪၚd_D::ᕘ => ' . (shift)->SUPER::ᕘ }
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ｄiᚪၚd_D'),
+ [ qw(Ｄiᚪၚd_D Ｄiᚪၚd_C Ｄiᚪၚd_A Ｄiᚪၚd_B) ]
+), '... got the right MRO for Ｄiᚪၚd_D');
+
+is(Ｄiᚪၚd_D->ᕘ,
+ 'Ｄiᚪၚd_D::ᕘ => Ｄiᚪၚd_A::ᕘ',
+ '... got the right next::method dispatch path');
--- /dev/null
+#!./perl
+
+use utf8;
+use open qw( :utf8 :std );
+use strict;
+use warnings;
+
+BEGIN { require q(./test.pl); } plan(tests => 53);
+
+require mro;
+
+{
+ package MRO_அ;
+ our @ISA = qw//;
+ package MRO_ɓ;
+ our @ISA = qw//;
+ package MRO_ᶝ;
+ our @ISA = qw//;
+ package MRO_ｄ;
+ our @ISA = qw/MRO_அ MRO_ɓ MRO_ᶝ/;
+ package MRO_ɛ;
+ our @ISA = qw/MRO_அ MRO_ɓ MRO_ᶝ/;
+ package MRO_ᚠ;
+ our @ISA = qw/MRO_ｄ MRO_ɛ/;
+}
+
+my @MFO_ᚠ_DFS = qw/MRO_ᚠ MRO_ｄ MRO_அ MRO_ɓ MRO_ᶝ MRO_ɛ/;
+my @MFO_ᚠ_C3 = qw/MRO_ᚠ MRO_ｄ MRO_ɛ MRO_அ MRO_ɓ MRO_ᶝ/;
+is(mro::get_mro('MRO_ᚠ'), 'dfs');
+ok(eq_array(
+ mro::get_linear_isa('MRO_ᚠ'), \@MFO_ᚠ_DFS
+));
+
+ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'dfs'), \@MFO_ᚠ_DFS));
+ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'c3'), \@MFO_ᚠ_C3));
+eval{mro::get_linear_isa('MRO_ᚠ', 'C3')};
+like($@, qr/^Invalid mro name: 'C3'/);
+
+mro::set_mro('MRO_ᚠ', 'c3');
+is(mro::get_mro('MRO_ᚠ'), 'c3');
+ok(eq_array(
+ mro::get_linear_isa('MRO_ᚠ'), \@MFO_ᚠ_C3
+));
+
+ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'dfs'), \@MFO_ᚠ_DFS));
+ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'c3'), \@MFO_ᚠ_C3));
+eval{mro::get_linear_isa('MRO_ᚠ', 'C3')};
+like($@, qr/^Invalid mro name: 'C3'/);
+
+ok(!mro::is_universal('MRO_ɓ'));
+
+@UNIVERSAL::ISA = qw/MRO_ᚠ/;
+ok(mro::is_universal('MRO_ɓ'));
+
+@UNIVERSAL::ISA = ();
+ok(!mro::is_universal('MRO_ᚠ'));
+ok(!mro::is_universal('MRO_ɓ'));
+
+# is_universal, get_mro, and get_linear_isa should
+# handle non-existent 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_ҭṣṱबꗻ;
+ sub 텟tf운ꜿ { return 123 }
+ package MRO_Test옽ḦРꤷsӭ;
+ sub 텟ₜꖢᶯcƧ { return 321 }
+ package MRO_Ɯ; our @ISA = qw/MRO_ҭṣṱबꗻ/;
+}
+*MRO_ᕡ::ISA = *MRO_Ɯ::ISA;
+is(eval { MRO_ᕡ->텟tf운ꜿ() }, 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);
+
+# Simple DESTROY Baseline
+{
+ my $x = 0;
+ my $obj;
+
+ {
+ package DESTROY_MRO_Bӓeᓕne;
+ sub new { bless {} => shift }
+ sub DESTROY { $x++ }
+
+ package DESTROY_MRO_Bӓeᓕne_χḻɖ;
+ our @ISA = qw/DESTROY_MRO_Bӓeᓕne/;
+ }
+
+ $obj = DESTROY_MRO_Bӓeᓕne->new();
+ undef $obj;
+ is($x, 1);
+
+ $obj = DESTROY_MRO_Bӓeᓕne_χḻɖ->new();
+ undef $obj;
+ is($x, 2);
+}
+
+# Dynamic DESTROY
+{
+ my $x = 0;
+ my $obj;
+
+ {
+ package DESTROY_MRO_Ｄჷ및;
+ sub new { bless {} => shift }
+
+ package DESTROY_MRO_Ｄჷ및_χḻɖ;
+ our @ISA = qw/DESTROY_MRO_Ｄჷ및/;
+ }
+
+ $obj = DESTROY_MRO_Ｄჷ및->new();
+ undef $obj;
+ is($x, 0);
+
+ $obj = DESTROY_MRO_Ｄჷ및_χḻɖ->new();
+ undef $obj;
+ is($x, 0);
+
+ no warnings 'once';
+ *DESTROY_MRO_Ｄჷ및::DESTROY = sub { $x++ };
+
+ $obj = DESTROY_MRO_Ｄჷ및->new();
+ undef $obj;
+ is($x, 1);
+
+ $obj = DESTROY_MRO_Ｄჷ및_χḻɖ->new();
+ undef $obj;
+ is($x, 2);
+}
+
+# clearing @ISA in different ways
+# some are destructive to the package, hence the new
+# package name each time
+{
+ no warnings 'uninitialized';
+ {
+ package ᛁ앛ଌᛠ;
+ our @ISA = qw/ｘｘ ƳƳ ƶƶ/;
+ }
+ # baseline
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ'),[qw/ᛁ앛ଌᛠ ｘｘ ƳƳ ƶƶ/]));
+
+ # this looks dumb, but it preserves existing behavior for compatibility
+ # (undefined @ISA elements treated as "main")
+ $ᛁ앛ଌᛠ::ISA[1] = undef;
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ'),[qw/ᛁ앛ଌᛠ ｘｘ main ƶƶ/]));
+
+ # undef the array itself
+ undef @ᛁ앛ଌᛠ::ISA;
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ'),[qw/ᛁ앛ଌᛠ/]));
+
+ # Now, clear more than one package's @ISA at once
+ {
+ package ᛁ앛ଌᛠ1;
+ our @ISA = qw/ＷẆ ｘｘ/;
+
+ package ᛁ앛ଌᛠ2;
+ our @ISA = qw/ƳƳ ƶƶ/;
+ }
+ # baseline
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ1'),[qw/ᛁ앛ଌᛠ1 ＷẆ ｘｘ/]));
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ2'),[qw/ᛁ앛ଌᛠ2 ƳƳ ƶƶ/]));
+ (@ᛁ앛ଌᛠ1::ISA, @ᛁ앛ଌᛠ2::ISA) = ();
+
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ1'),[qw/ᛁ앛ଌᛠ1/]));
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ2'),[qw/ᛁ앛ଌᛠ2/]));
+
+ # [perl #49564] This is a pretty obscure way of clearing @ISA but
+ # it tests a regression that affects XS code calling av_clear too.
+ {
+ package ᛁ앛ଌᛠ3;
+ our @ISA = qw/ＷẆ ｘｘ/;
+ }
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ3'),[qw/ᛁ앛ଌᛠ3 ＷẆ ｘｘ/]));
+ {
+ package ᛁ앛ଌᛠ3;
+ reset 'I';
+ }
+ ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ3'),[qw/ᛁ앛ଌᛠ3/]));
+}
+
+# Check that recursion bails out "cleanly" in a variety of cases
+# (as opposed to say, bombing the interpreter or something)
+{
+ my @recurse_codes = (
+ '@MRO_ഋ1::ISA = "MRO_ഋ2"; @MRO_ഋ2::ISA = "MRO_ഋ1";',
+ '@MRO_ഋ3::ISA = "MRO_ഋ4"; push(@MRO_ഋ4::ISA, "MRO_ഋ3");',
+ '@MRO_ഋ5::ISA = "MRO_ഋ6"; @MRO_ഋ6::ISA = qw/ｘｘ MRO_ഋ5 ƳƳ/;',
+ '@MRO_ഋ7::ISA = "MRO_ഋ8"; push(@MRO_ഋ8::ISA, qw/ｘｘ MRO_ഋ7 ƳƳ/)',
+ );
+ foreach my $code (@recurse_codes) {
+ eval $code;
+ ok($@ =~ /Recursive inheritance detected/);
+ }
+}
+
+# Check that SUPER caches get invalidated correctly
+{
+ {
+ package ｽṔઍR텟ʇ;
+ sub new { bless {} => shift }
+ sub ຟઓ { $_[1]+1 }
+
+ package ｽṔઍR텟ʇ::MᶤƉ;
+ our @ISA = 'ｽṔઍR텟ʇ';
+
+ package ｽṔઍR텟ʇ::킫;
+ our @ISA = 'ｽṔઍR텟ʇ::MᶤƉ';
+ sub ຟઓ { my $s = shift; $s->SUPER::ຟઓ(@_) }
+
+ package ｽṔઍR텟ʇ::렙ﷰए;
+ sub ຟઓ { $_[1]+3 }
+ }
+
+ my $stk_obj = ｽṔઍR텟ʇ::킫->new();
+ is($stk_obj->ຟઓ(1), 2);
+ { no warnings 'redefine';
+ *ｽṔઍR텟ʇ::ຟઓ = sub { $_[1]+2 };
+ }
+ is($stk_obj->ຟઓ(2), 4);
+ @ｽṔઍR텟ʇ::MᶤƉ::ISA = 'ｽṔઍR텟ʇ::렙ﷰए';
+ is($stk_obj->ຟઓ(3), 6);
+}
+
+{
+ {
+ # assigning @ISA via arrayref to globref RT 60220
+ package ᛔ1;
+ sub new { bless {}, shift }
+
+ package ᛔ2;
+ }
+ *{ᛔ2::ISA} = [ 'ᛔ1' ];
+ my $foo = ᛔ2->new;
+ ok(!eval { $foo->ɓᛅƘ }, "no ɓᛅƘ method");
+ no warnings 'once'; # otherwise it'll bark about ᛔ1::ɓᛅƘ used only once
+ *{ᛔ1::ɓᛅƘ} = sub { "[ɓᛅƘ]" };
+ is(scalar eval { $foo->ɓᛅƘ }, "[ɓᛅƘ]", "can ɓᛅƘ now");
+ is $@, '';
+}
+
+{
+ # assigning @ISA via arrayref then modifying it RT 72866
+ {
+ package ㄑ1;
+ sub Ｆஓ { }
+
+ package ㄑ2;
+ sub ƚ { }
+
+ package ㄑ3;
+ }
+ push @ㄑ3::ISA, "ㄑ1";
+ can_ok("ㄑ3", "Ｆஓ");
+ *ㄑ3::ISA = [];
+ push @ㄑ3::ISA, "ㄑ1";
+ can_ok("ㄑ3", "Ｆஓ");
+ *ㄑ3::ISA = [];
+ push @ㄑ3::ISA, "ㄑ2";
+ can_ok("ㄑ3", "ƚ");
+ ok(!ㄑ3->can("Ｆஓ"), "can't call Ｆஓ method any longer");
+}
+
+{
+ # test mro::method_changed_in
+ my $count = mro::get_pkg_gen("MRO_அ");
+ mro::method_changed_in("MRO_அ");
+ my $count_new = mro::get_pkg_gen("MRO_அ");
+
+ is($count_new, $count + 1);
+}
+
+{
+ # test if we can call mro::invalidate_all_method_caches;
+ eval {
+ mro::invalidate_all_method_caches();
+ };
+ is($@, "");
+}
+
+{
+ # @main::ISA
+ no warnings 'once';
+ @main::ISA = 'პᛅeȵᛏ';
+ my $output = '';
+ *პᛅeȵᛏ::ど = sub { $output .= 'პᛅeȵᛏ' };
+ *პᛅeȵᛏ2::ど = sub { $output .= 'პᛅeȵᛏ2' };
+ main->ど;
+ @main::ISA = 'პᛅeȵᛏ2';
+ main->ど;
+ is $output, 'პᛅeȵᛏპᛅeȵᛏ2', '@main::ISA is magical';
+}
+
+{
+ # Undefining *ISA, then modifying @ISA
+ # This broke Class::Trait. See [perl #79024].
+ {package Class::Trait::Base}
+ no strict 'refs';
+ undef *{"एxṰர::ʦፖㄡsȨ::ISA"};
+ 'एxṰர::ʦፖㄡsȨ'->isa('Class::Trait::Base'); # cache the mro
+ unshift @{"एxṰர::ʦፖㄡsȨ::ISA"}, 'Class::Trait::Base';
+ ok 'एxṰர::ʦፖㄡsȨ'->isa('Class::Trait::Base'),
+ 'a isa b after undef *a::ISA and @a::ISA modification';
+}
+
+{
+ # Deleting $package::{ISA}
+ # Broken in 5.10.0; fixed in 5.13.7
+ @BḼᵑtｈ::ISA = 'Bલdḏ';
+ delete $BḼᵑtｈ::{ISA};
+ ok !BḼᵑtｈ->isa("Bલdḏ"), 'delete $package::{ISA}';
+}
+
+{
+ # Undefining stashes
+ @ᖫᕃㄒṭ::ISA = "ᖮw잍";
+ @ᖮw잍::ISA = "ሲঌએ";
+ undef %ᖮw잍::;
+ ok !ᖫᕃㄒṭ->isa('ሲঌએ'), 'undef %package:: updates subclasses';
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+require q(./test.pl); plan(tests => 7);
+
+{
+ package BaseTest;
+ use strict;
+ use warnings;
+ use mro 'c3';
+
+ package OverloadingTest;
+ use strict;
+ use warnings;
+ use mro 'c3';
+ use base 'BaseTest';
+ use overload '""' => sub { ref(shift) . " stringified" },
+ fallback => 1;
+
+ sub new { bless {} => shift }
+
+ package InheritingFromOverloadedTest;
+ use strict;
+ use warnings;
+ use base 'OverloadingTest';
+ use mro 'c3';
+}
+
+my $x = InheritingFromOverloadedTest->new();
+isa_ok($x, 'InheritingFromOverloadedTest');
+
+my $y = OverloadingTest->new();
+isa_ok($y, 'OverloadingTest');
+
+is("$x", 'InheritingFromOverloadedTest stringified', '... got the right value when stringifing');
+is("$y", 'OverloadingTest stringified', '... got the right value when stringifing');
+
+ok(($y eq 'OverloadingTest stringified'), '... eq was handled correctly');
+
+my $result;
+eval {
+ $result = $x eq 'InheritingFromOverloadedTest stringified'
+};
+ok(!$@, '... this should not throw an exception');
+ok($result, '... and we should get the true value');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 12);
+
+=pod
+
+This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
+
+ --- --- ---
+Level 5 8 | A | 9 | B | A | C | (More General)
+ --- --- --- V
+ \ | / |
+ \ | / |
+ \ | / |
+ \ | / |
+ --- |
+Level 4 7 | D | |
+ --- |
+ / \ |
+ / \ |
+ --- --- |
+Level 3 4 | G | 6 | E | |
+ --- --- |
+ | | |
+ | | |
+ --- --- |
+Level 2 3 | H | 5 | F | |
+ --- --- |
+ \ / | |
+ \ / | |
+ \ | |
+ / \ | |
+ / \ | |
+ --- --- |
+Level 1 1 | J | 2 | I | |
+ --- --- |
+ \ / |
+ \ / |
+ --- v
+Level 0 0 | K | (More Specialized)
+ ---
+
+
+0123456789A
+KJIHGFEDABC
+
+=cut
+
+{
+ package 텟Ṱ::ᐊ; use mro 'c3';
+
+ package 텟Ṱ::ḅ; use mro 'c3';
+
+ package 텟Ṱ::ȼ; use mro 'c3';
+
+ package 텟Ṱ::Ḏ; use mro 'c3';
+ use base qw/텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ/;
+
+ package 텟Ṱ::Ӭ; use mro 'c3';
+ use base qw/텟Ṱ::Ḏ/;
+
+ package 텟Ṱ::Ḟ; use mro 'c3';
+ use base qw/텟Ṱ::Ӭ/;
+ sub testmèth { "wrong" }
+
+ package 텟Ṱ::ḡ; use mro 'c3';
+ use base qw/텟Ṱ::Ḏ/;
+
+ package 텟Ṱ::Ḣ; use mro 'c3';
+ use base qw/텟Ṱ::ḡ/;
+
+ package 텟Ṱ::ᶦ; use mro 'c3';
+ use base qw/텟Ṱ::Ḣ 텟Ṱ::Ḟ/;
+ sub testmèth { "right" }
+
+ package 텟Ṱ::Ｊ; use mro 'c3';
+ use base qw/텟Ṱ::Ḟ/;
+
+ package 텟Ṱ::Ḵ; use mro 'c3';
+ use base qw/텟Ṱ::Ｊ 텟Ṱ::ᶦ/;
+ sub testmèth { shift->next::method }
+}
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ᐊ'),
+ [ qw(텟Ṱ::ᐊ) ]
+), '... got the right C3 merge order for 텟Ṱ::ᐊ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ḅ'),
+ [ qw(텟Ṱ::ḅ) ]
+), '... got the right C3 merge order for 텟Ṱ::ḅ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ȼ'),
+ [ qw(텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::ȼ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḏ'),
+ [ qw(텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::Ḏ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ӭ'),
+ [ qw(텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::Ӭ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḟ'),
+ [ qw(텟Ṱ::Ḟ 텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::Ḟ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ḡ'),
+ [ qw(텟Ṱ::ḡ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::ḡ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḣ'),
+ [ qw(텟Ṱ::Ḣ 텟Ṱ::ḡ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::Ḣ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ᶦ'),
+ [ qw(텟Ṱ::ᶦ 텟Ṱ::Ḣ 텟Ṱ::ḡ 텟Ṱ::Ḟ 텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::ᶦ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ｊ'),
+ [ qw(텟Ṱ::Ｊ 텟Ṱ::Ḟ 텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::Ｊ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḵ'),
+ [ qw(텟Ṱ::Ḵ 텟Ṱ::Ｊ 텟Ṱ::ᶦ 텟Ṱ::Ḣ 텟Ṱ::ḡ 텟Ṱ::Ḟ 텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right C3 merge order for 텟Ṱ::Ḵ');
+
+is(텟Ṱ::Ḵ->testmèth(), "right", 'next::method working ok');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 11);
+
+=pod
+
+This example is taken from: http://rt.cpan.org/Public/Bug/Display.html?id=20879
+
+ --- --- ---
+Level 5 8 | A | 9 | B | A | C | (More General)
+ --- --- --- V
+ \ | / |
+ \ | / |
+ \ | / |
+ \ | / |
+ --- |
+Level 4 7 | D | |
+ --- |
+ / \ |
+ / \ |
+ --- --- |
+Level 3 4 | G | 6 | E | |
+ --- --- |
+ | | |
+ | | |
+ --- --- |
+Level 2 3 | H | 5 | F | |
+ --- --- |
+ \ / | |
+ \ / | |
+ \ | |
+ / \ | |
+ / \ | |
+ --- --- |
+Level 1 1 | J | 2 | I | |
+ --- --- |
+ \ / |
+ \ / |
+ --- v
+Level 0 0 | K | (More Specialized)
+ ---
+
+
+0123456789A
+KJIHGFEDABC
+
+=cut
+
+{
+ package 텟Ṱ::ᐊ; use mro 'dfs';
+
+ package 텟Ṱ::ḅ; use mro 'dfs';
+
+ package 텟Ṱ::ȼ; use mro 'dfs';
+
+ package 텟Ṱ::Ḏ; use mro 'dfs';
+ use base qw/텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ/;
+
+ package 텟Ṱ::Ӭ; use mro 'dfs';
+ use base qw/텟Ṱ::Ḏ/;
+
+ package 텟Ṱ::Ḟ; use mro 'dfs';
+ use base qw/텟Ṱ::Ӭ/;
+
+ package 텟Ṱ::ḡ; use mro 'dfs';
+ use base qw/텟Ṱ::Ḏ/;
+
+ package 텟Ṱ::Ḣ; use mro 'dfs';
+ use base qw/텟Ṱ::ḡ/;
+
+ package 텟Ṱ::ᶦ; use mro 'dfs';
+ use base qw/텟Ṱ::Ḣ 텟Ṱ::Ḟ/;
+
+ package 텟Ṱ::Ｊ; use mro 'dfs';
+ use base qw/텟Ṱ::Ḟ/;
+
+ package 텟Ṱ::Ḵ; use mro 'dfs';
+ use base qw/텟Ṱ::Ｊ 텟Ṱ::ᶦ/;
+}
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ᐊ'),
+ [ qw(텟Ṱ::ᐊ) ]
+), '... got the right DFS merge order for 텟Ṱ::ᐊ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ḅ'),
+ [ qw(텟Ṱ::ḅ) ]
+), '... got the right DFS merge order for 텟Ṱ::ḅ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ȼ'),
+ [ qw(텟Ṱ::ȼ) ]
+), '... got the right DFS merge order for 텟Ṱ::ȼ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḏ'),
+ [ qw(텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right DFS merge order for 텟Ṱ::Ḏ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ӭ'),
+ [ qw(텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right DFS merge order for 텟Ṱ::Ӭ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḟ'),
+ [ qw(텟Ṱ::Ḟ 텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right DFS merge order for 텟Ṱ::Ḟ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ḡ'),
+ [ qw(텟Ṱ::ḡ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right DFS merge order for 텟Ṱ::ḡ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḣ'),
+ [ qw(텟Ṱ::Ḣ 텟Ṱ::ḡ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right DFS merge order for 텟Ṱ::Ḣ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::ᶦ'),
+ [ qw(텟Ṱ::ᶦ 텟Ṱ::Ḣ 텟Ṱ::ḡ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ 텟Ṱ::Ḟ 텟Ṱ::Ӭ) ]
+), '... got the right DFS merge order for 텟Ṱ::ᶦ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ｊ'),
+ [ qw(텟Ṱ::Ｊ 텟Ṱ::Ḟ 텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ) ]
+), '... got the right DFS merge order for 텟Ṱ::Ｊ');
+
+ok(eq_array(
+ mro::get_linear_isa('텟Ṱ::Ḵ'),
+ [ qw(텟Ṱ::Ḵ 텟Ṱ::Ｊ 텟Ṱ::Ḟ 텟Ṱ::Ӭ 텟Ṱ::Ḏ 텟Ṱ::ᐊ 텟Ṱ::ḅ 텟Ṱ::ȼ 텟Ṱ::ᶦ 텟Ṱ::Ḣ 텟Ṱ::ḡ) ]
+), '... got the right DFS merge order for 텟Ṱ::Ḵ');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 1);
+
+=pod
+
+This example is taken from the inheritance graph of DBIx::Class::Core in DBIx::Class v0.07002:
+(No ASCII art this time, this graph is insane)
+
+The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
+
+=cut
+
+{
+ package Ẋẋ::ḐʙIＸ::Cl았::Coﾚ; use mro 'c3';
+ our @ISA = qw/
+ Ẋẋ::ḐʙIＸ::Cl았::ᓭᚱi알ḭźɜ::Sᑐ랍lえ
+ Ẋẋ::ḐʙIＸ::Cl았::Ĭⁿᰒ텣올움ᶮ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ
+ Ẋẋ::ḐʙIＸ::Cl았::ᛕķ::Ạuต
+ Ẋẋ::ḐʙIＸ::Cl았::ᛕķ
+ Ẋẋ::ḐʙIＸ::Cl았::ﾛẈ
+ Ẋẋ::ḐʙIＸ::Cl았::ResultSourceProxy::탑lẹ
+ Ẋẋ::ḐʙIＸ::Cl았::ᚪc엤ȭઋᶢऋouꩇ
+ /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::Ĭⁿᰒ텣올움ᶮ; use mro 'c3';
+ our @ISA = qw/ Ẋẋ::ḐʙIＸ::Cl았::ﾛẈ /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::ﾛẈ; use mro 'c3';
+ our @ISA = qw/ Ẋẋ::ḐʙIＸ::Cl았 /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았; use mro 'c3';
+ our @ISA = qw/
+ Ẋẋ::ḐʙIＸ::Cl았::촘폰en팃엗
+ xx::Cl았::닽Ӕ::앛쳇sᚖ
+ /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ; use mro 'c3';
+ our @ISA = qw/
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::헬pḜrＳ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::앛쳇sᚖ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::찻찯eᚪtЁnʂ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::Pr오xᐇMeᖪ옫ś
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::밧え
+ Ẋẋ::ḐʙIＸ::Cl았
+ /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::헬pḜrＳ; use mro 'c3';
+ our @ISA = qw/
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::핫ᛗƳ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::핫ᶱn
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::бl옹sTȭ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::ᛗᓆ톰ẰᚿẎ
+ /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::Pr오xᐇMeᖪ옫ś; use mro 'c3';
+ our @ISA = qw/ Ẋẋ::ḐʙIＸ::Cl았 /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::밧え; use mro 'c3';
+ our @ISA = qw/ Ẋẋ::ḐʙIＸ::Cl았 /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::ᛕķ::Ạuต; use mro 'c3';
+ our @ISA = qw/ Ẋẋ::ḐʙIＸ::Cl았 /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::ᛕķ; use mro 'c3';
+ our @ISA = qw/ Ẋẋ::ḐʙIＸ::Cl았::ﾛẈ /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::ResultSourceProxy::탑lẹ; use mro 'c3';
+ our @ISA = qw/
+ Ẋẋ::ḐʙIＸ::Cl았::ᚪc엤ȭઋᶢऋouꩇ
+ Ẋẋ::ḐʙIＸ::Cl았::ResultSourceProxy
+ /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::ResultSourceProxy; use mro 'c3';
+ our @ISA = qw/ Ẋẋ::ḐʙIＸ::Cl았 /;
+
+ package xx::Cl았::닽Ӕ::앛쳇sᚖ; our @ISA = (); use mro 'c3';
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::핫ᛗƳ; our @ISA = (); use mro 'c3';
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::핫ᶱn; our @ISA = (); use mro 'c3';
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::бl옹sTȭ; our @ISA = (); use mro 'c3';
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::ᛗᓆ톰ẰᚿẎ; our @ISA = (); use mro 'c3';
+ package Ẋẋ::ḐʙIＸ::Cl았::촘폰en팃엗; our @ISA = (); use mro 'c3';
+ package Ẋẋ::ḐʙIＸ::Cl았::ᚪc엤ȭઋᶢऋouꩇ; our @ISA = (); use mro 'c3';
+ package Ẋẋ::ḐʙIＸ::Cl았::ᓭᚱi알ḭźɜ::Sᑐ랍lえ; our @ISA = (); use mro 'c3';
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::앛쳇sᚖ; our @ISA = (); use mro 'c3';
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::찻찯eᚪtЁnʂ; our @ISA = (); use mro 'c3';
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ẋẋ::ḐʙIＸ::Cl았::Coﾚ'),
+ [qw/
+ Ẋẋ::ḐʙIＸ::Cl았::Coﾚ
+ Ẋẋ::ḐʙIＸ::Cl았::ᓭᚱi알ḭźɜ::Sᑐ랍lえ
+ Ẋẋ::ḐʙIＸ::Cl았::Ĭⁿᰒ텣올움ᶮ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::헬pḜrＳ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::핫ᛗƳ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::핫ᶱn
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::бl옹sTȭ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::ᛗᓆ톰ẰᚿẎ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::앛쳇sᚖ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::찻찯eᚪtЁnʂ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::Pr오xᐇMeᖪ옫ś
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::밧え
+ Ẋẋ::ḐʙIＸ::Cl았::ᛕķ::Ạuต
+ Ẋẋ::ḐʙIＸ::Cl았::ᛕķ
+ Ẋẋ::ḐʙIＸ::Cl았::ﾛẈ
+ Ẋẋ::ḐʙIＸ::Cl았::ResultSourceProxy::탑lẹ
+ Ẋẋ::ḐʙIＸ::Cl았::ᚪc엤ȭઋᶢऋouꩇ
+ Ẋẋ::ḐʙIＸ::Cl았::ResultSourceProxy
+ Ẋẋ::ḐʙIＸ::Cl았
+ Ẋẋ::ḐʙIＸ::Cl았::촘폰en팃엗
+ xx::Cl았::닽Ӕ::앛쳇sᚖ
+ /]
+), '... got the right C3 merge order for Ẋẋ::ḐʙIＸ::Cl았::Core');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 1);
+
+=pod
+
+This example is taken from the inheritance graph of DBIx::Class::Coﾚ in DBIx::Class v0.07002:
+(No ASCII art this time, this graph is insane)
+
+The xx:: prefixes are just to be sure these bogus declarations never stomp on real ones
+
+=cut
+
+{
+ package Ẋẋ::ḐʙIＸ::Cl았::Coﾚ; use mro 'dfs';
+ our @ISA = qw/
+ Ẋẋ::ḐʙIＸ::Cl았::ᓭᚱi알ḭźɜ::Sᑐ랍lえ
+ Ẋẋ::ḐʙIＸ::Cl았::Ĭⁿᰒ텣올움ᶮ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ
+ Ẋẋ::ḐʙIＸ::Cl았::ᛕķ::Ạuต
+ Ẋẋ::ḐʙIＸ::Cl았::ᛕķ
+ Ẋẋ::ḐʙIＸ::Cl았::ﾛẈ
+ Ẋẋ::ḐʙIＸ::Cl았::ResultSourceProxy::탑lẹ
+ Ẋẋ::ḐʙIＸ::Cl았::ᚪc엤ȭઋᶢऋouꩇ
+ /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::Ĭⁿᰒ텣올움ᶮ; use mro 'dfs';
+ our @ISA = qw/ Ẋẋ::ḐʙIＸ::Cl았::ﾛẈ /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::ﾛẈ; use mro 'dfs';
+ our @ISA = qw/ Ẋẋ::ḐʙIＸ::Cl았 /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았; use mro 'dfs';
+ our @ISA = qw/
+ Ẋẋ::ḐʙIＸ::Cl았::촘폰en팃엗
+ xx::Cl았::닽Ӕ::앛쳇sᚖ
+ /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ; use mro 'dfs';
+ our @ISA = qw/
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::헬pḜrＳ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::앛쳇sᚖ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::찻찯eᚪtЁnʂ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::Pr오xᐇMeᖪ옫ś
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::밧え
+ Ẋẋ::ḐʙIＸ::Cl았
+ /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::헬pḜrＳ; use mro 'dfs';
+ our @ISA = qw/
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::핫ᛗƳ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::핫ᶱn
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::бl옹sTȭ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::ᛗᓆ톰ẰᚿẎ
+ /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::Pr오xᐇMeᖪ옫ś; use mro 'dfs';
+ our @ISA = qw/ Ẋẋ::ḐʙIＸ::Cl았 /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::밧え; use mro 'dfs';
+ our @ISA = qw/ Ẋẋ::ḐʙIＸ::Cl았 /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::ᛕķ::Ạuต; use mro 'dfs';
+ our @ISA = qw/ Ẋẋ::ḐʙIＸ::Cl았 /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::ᛕķ; use mro 'dfs';
+ our @ISA = qw/ Ẋẋ::ḐʙIＸ::Cl았::ﾛẈ /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::ResultSourceProxy::탑lẹ; use mro 'dfs';
+ our @ISA = qw/
+ Ẋẋ::ḐʙIＸ::Cl았::ᚪc엤ȭઋᶢऋouꩇ
+ Ẋẋ::ḐʙIＸ::Cl았::ResultSourceProxy
+ /;
+
+ package Ẋẋ::ḐʙIＸ::Cl았::ResultSourceProxy; use mro 'dfs';
+ our @ISA = qw/ Ẋẋ::ḐʙIＸ::Cl았 /;
+
+ package xx::Cl았::닽Ӕ::앛쳇sᚖ; our @ISA = (); use mro 'dfs';
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::핫ᛗƳ; our @ISA = (); use mro 'dfs';
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::핫ᶱn; our @ISA = (); use mro 'dfs';
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::бl옹sTȭ; our @ISA = (); use mro 'dfs';
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::ᛗᓆ톰ẰᚿẎ; our @ISA = (); use mro 'dfs';
+ package Ẋẋ::ḐʙIＸ::Cl았::촘폰en팃엗; our @ISA = (); use mro 'dfs';
+ package Ẋẋ::ḐʙIＸ::Cl았::ᚪc엤ȭઋᶢऋouꩇ; our @ISA = (); use mro 'dfs';
+ package Ẋẋ::ḐʙIＸ::Cl았::ᓭᚱi알ḭźɜ::Sᑐ랍lえ; our @ISA = (); use mro 'dfs';
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::앛쳇sᚖ; our @ISA = (); use mro 'dfs';
+ package Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::찻찯eᚪtЁnʂ; our @ISA = (); use mro 'dfs';
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ẋẋ::ḐʙIＸ::Cl았::Coﾚ'),
+ [qw/
+ Ẋẋ::ḐʙIＸ::Cl았::Coﾚ
+ Ẋẋ::ḐʙIＸ::Cl았::ᓭᚱi알ḭźɜ::Sᑐ랍lえ
+ Ẋẋ::ḐʙIＸ::Cl았::Ĭⁿᰒ텣올움ᶮ
+ Ẋẋ::ḐʙIＸ::Cl았::ﾛẈ
+ Ẋẋ::ḐʙIＸ::Cl았
+ Ẋẋ::ḐʙIＸ::Cl았::촘폰en팃엗
+ xx::Cl았::닽Ӕ::앛쳇sᚖ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::헬pḜrＳ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::핫ᛗƳ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::핫ᶱn
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::бl옹sTȭ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::ᛗᓆ톰ẰᚿẎ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::앛쳇sᚖ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::찻찯eᚪtЁnʂ
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::Pr오xᐇMeᖪ옫ś
+ Ẋẋ::ḐʙIＸ::Cl았::렐aチ온ሺṖ::밧え
+ Ẋẋ::ḐʙIＸ::Cl았::ᛕķ::Ạuต
+ Ẋẋ::ḐʙIＸ::Cl았::ᛕķ
+ Ẋẋ::ḐʙIＸ::Cl았::ResultSourceProxy::탑lẹ
+ Ẋẋ::ḐʙIＸ::Cl았::ᚪc엤ȭઋᶢऋouꩇ
+ Ẋẋ::ḐʙIＸ::Cl았::ResultSourceProxy
+ /]
+), '... got the right DFS merge order for Ẋẋ::ḐʙIＸ::Cl았::Coﾚ');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 1);
+
+require mro;
+
+=pod
+
+This example is take from: http://www.python.org/2.3/mro.html
+
+"Serious order disagreement" # From Guido
+class O: pass
+class X(O): pass
+class Y(O): pass
+class A(X,Y): pass
+class B(Y,X): pass
+try:
+ class Z(A,B): pass #creates Z(A,B) in Python 2.2
+except TypeError:
+ pass # Z(A,B) cannot be created in Python 2.3
+
+=cut
+
+{
+ package ẋ;
+
+ package Ƴ;
+
+ package ẋƳ;
+ our @ISA = ('ẋ', 'Ƴ');
+
+ package Ƴẋ;
+ our @ISA = ('Ƴ', 'ẋ');
+
+ package Ȥ;
+ our @ISA = ('ẋƳ', 'Ƴẋ');
+}
+
+eval { mro::get_linear_isa('Ȥ', 'c3') };
+like($@, qr/^Inconsistent /, '... got the right error with an inconsistent hierarchy');
--- /dev/null
+#!./perl
+
+BEGIN { chdir 't'; @INC = '../lib'; require './test.pl' }
+
+use utf8;
+use open qw( :utf8 :std );
+
+plan 12;
+
+@ฟ옥ʮ::ISA = "ᶶ";
+*ຜ옥ㄏ::ISA = *ฟ옥ʮ::ISA;
+@ฟ옥ʮ::ISA = "Ｂᐊㄗ";
+
+ok 'ฟ옥ʮ'->isa("Ｂᐊㄗ"),
+ 'isa after another stash has claimed the @ISA via glob assignment';
+ok 'ຜ옥ㄏ'->isa("Ｂᐊㄗ"),
+ 'isa on the stash that claimed the @ISA via glob assignment';
+ok !ฟ옥ʮ->isa("ᶶ"),
+ '!isa when another stash has claimed the @ISA via glob assignment';
+ok !ຜ옥ㄏ->isa("ᶶ"),
+ '!isa on the stash that claimed the @ISA via glob assignment';
+
+@ฟ옥ʮ::ISA = "ᶶ";
+*ฟ옥ʮ::ISA = ["Ｂᐊㄗ"];
+
+ok 'ฟ옥ʮ'->isa("Ｂᐊㄗ"),
+ 'isa after glob-to-ref assignment when *ISA is shared';
+ok 'ຜ옥ㄏ'->isa("Ｂᐊㄗ"),
+ 'isa after glob-to-ref assignment on another stash when *ISA is shared';
+ok !ฟ옥ʮ->isa("ᶶ"),
+ '!isa after glob-to-ref assignment when *ISA is shared';
+ok !ຜ옥ㄏ->isa("ᶶ"),
+ '!isa after glob-to-ref assignment on another stash when *ISA is shared';
+
+@ᕘ::ISA = "ᶶ";
+*ጶ::ISA = \@ᕘ::ISA;
+@ᕘ::ISA = "Ｂᐊㄗ";
+
+ok 'ᕘ'->isa("Ｂᐊㄗ"),
+ 'isa after another stash has claimed the @ISA via ref-to-glob assignment';
+ok 'ጶ'->isa("Ｂᐊㄗ"),
+ 'isa on the stash that claimed the @ISA via ref-to-glob assignment';
+ok !ᕘ->isa("ᶶ"),
+ '!isa when another stash has claimed the @ISA via ref-to-glob assignment';
+ok !ጶ->isa("ᶶ"),
+ '!isa on the stash that claimed the @ISA via ref-to-glob assignment';
--- /dev/null
+#!perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require "./test.pl";
+}
+
+use strict;
+use utf8;
+use open qw( :utf8 :std );
+
+plan 'no_plan';
+
+# package klonk doesn't have a stash.
+
+package 캎oẃ;
+use mro 'c3';
+
+# No parents
+
+package urḲḵｋ;
+use mro 'c3';
+
+# 1 parent
+@urḲḵｋ::ISA = 'kഌoんḰ';
+
+package к;
+use mro 'c3';
+
+# 2 parents
+@urḲḵｋ::ISA = ('kഌoんḰ', '캎oẃ');
+
+package ṭ화ckэ;
+use mro 'c3';
+
+# No parents, has @ISA
+@ṭ화ckэ::ISA = ();
+
+package Źzzzዟᑉ;
+use mro 'c3';
+
+@Źzzzዟᑉ::ISA = ('ṭ화ckэ', '캎oẃ');
+
+package Ẁ함Ｍ;
+use mro 'c3';
+
+@Ẁ함Ｍ::ISA = ('캎oẃ', 'ṭ화ckэ');
+
+package main;
+
+my %expect =
+ (
+ kഌoんḰ => [qw(kഌoんḰ)],
+ urḲḵｋ => [qw(urḲḵｋ kഌoんḰ 캎oẃ)],
+ 캎oẃ => [qw(캎oẃ)],
+ к => [qw(к)],
+ ṭ화ckэ => [qw(ṭ화ckэ)],
+ Źzzzዟᑉ => [qw(Źzzzዟᑉ ṭ화ckэ 캎oẃ)],
+ Ẁ함Ｍ => [qw(Ẁ함Ｍ 캎oẃ ṭ화ckэ)],
+ );
+
+foreach my $package (qw(kഌoんḰ urḲḵｋ 캎oẃ к ṭ화ckэ Źzzzዟᑉ Ẁ함Ｍ)) {
+ my $ref = bless [], $package;
+ my $isa = $expect{$package};
+ is("@{mro::get_linear_isa($package)}", "@$isa", "\@ISA for $package");
+
+ foreach my $class ($package, @$isa, 'UNIVERSAL') {
+ isa_ok($ref, $class, $package);
+ }
+}
--- /dev/null
+#!perl -w
+
+BEGIN {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ require "./test.pl";
+}
+
+use strict;
+use utf8;
+use open qw( :utf8 :std );
+
+plan 'no_plan';
+
+# package klonk doesn't have a stash.
+
+package 캎oẃ;
+
+# No parents
+
+package urḲḵｋ;
+
+# 1 parent
+@urḲḵｋ::ISA = 'kഌoんḰ';
+
+package к;
+
+# 2 parents
+@urḲḵｋ::ISA = ('kഌoんḰ', '캎oẃ');
+
+package ṭ화ckэ;
+
+# No parents, has @ISA
+@ṭ화ckэ::ISA = ();
+
+package Źzzzዟᑉ;
+
+@Źzzzዟᑉ::ISA = ('ṭ화ckэ', '캎oẃ');
+
+package Ẁ함Ｍ;
+
+@Ẁ함Ｍ::ISA = ('캎oẃ', 'ṭ화ckэ');
+
+package main;
+
+require mro;
+
+my %expect =
+ (
+ kഌoんḰ => [qw(kഌoんḰ)],
+ urḲḵｋ => [qw(urḲḵｋ kഌoんḰ 캎oẃ)],
+ 캎oẃ => [qw(캎oẃ)],
+ к => [qw(к)],
+ ṭ화ckэ => [qw(ṭ화ckэ)],
+ Źzzzዟᑉ => [qw(Źzzzዟᑉ ṭ화ckэ 캎oẃ)],
+ Ẁ함Ｍ => [qw(Ẁ함Ｍ 캎oẃ ṭ화ckэ)],
+ );
+
+foreach my $package (qw(kഌoんḰ urḲḵｋ 캎oẃ к ṭ화ckэ Źzzzዟᑉ Ẁ함Ｍ)) {
+ my $ref = bless [], $package;
+ my $isa = $expect{$package};
+ is("@{mro::get_linear_isa($package)}", "@$isa", "\@ISA for $package");
+
+ foreach my $class ($package, @$isa, 'UNIVERSAL') {
+ isa_ok($ref, $class, $package);
+ }
+}
--- /dev/null
+#!./perl
+
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ require q(./test.pl);
+}
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+plan(tests => 24);
+
+use mro;
+
+sub i {
+ my @args = @_;
+ @_
+ = (
+ join(" ", sort @{mro::get_isarev $args[0]}),
+ join(" ", sort @args[1..$#args-1]),
+ pop @args
+ );
+ goto &is;
+}
+
+# Basic isarev updating, when @ISA changes
+@팟tРṉ::ISA = "B옫yპt::ぅงலҬ";
+@S추ঋ::ISA = "B옫yპt::ぅงலҬ";
+@B옫yპt::ぅงலҬ::ISA = "B옫yპt";
+i B옫yპt => qw [ B옫yპt::ぅงலҬ 팟tРṉ S추ঋ ],
+ 'subclasses and subsubclasses are added to isarev';
+@팟tРṉ::ISA = ();
+i B옫yპt => qw [ B옫yპt::ぅงலҬ S추ঋ ],
+ 'single deletion from isarev';
+@B옫yპt::ぅงலҬ::ISA = ();
+i B옫yპt => qw [ ], 'recursive deletion from isarev';
+ # except underneath it is not actually recursive
+
+
+# More complicated tests that move packages around
+
+@훗ㄎએỲ::ISA = "독";
+@독::ISA = "ㄘა읻";
+@ວlƑ::ISA = "ㄘა읻";
+@솜ｪ::ƀ란ƌ::ᚿamㅔ::ISA = "독::ㄅ";
+@독::ㄅ::ISA = "TﾚӔṪ";
+@Frȇe::팀ẽ::ISA = "TﾚӔṪ";
+@Ｍy촐ꡙʳ::ISA = "독::ցളŔ::Leaʇhㄦ";
+@독::ցളŔ::Leaʇhㄦ::ISA = "ցളŔ";
+@AŇℴtḫeᕃ::ցളŔ::ISA = "ցളŔ";
+*팈ዕ:: = *독::;
+delete $::{"독::"};
+i ㄘა읻=>qw[ ວlƑ 팈ዕ ],
+ "deleting a stash elem updates isarev entries";
+i TﾚӔṪ=>qw[ Frȇe::팀ẽ 팈ዕ::ㄅ ],
+ "deleting a nested stash elem updates isarev entries";
+i ցളŔ=>qw[ AŇℴtḫeᕃ::ցളŔ 팈ዕ::ցളŔ::Leaʇhㄦ ],
+ "deleting a doubly nested stash elem updates isarev entries";
+
+@ごଅｔ::ISA = "ぅงலҬ";
+@ごଅｔ::DଐɾẎ::ISA = "ごଅｔ";
+@ごଅｔ::DଐɾẎ::Ⱦ옥ゲᕟƃᚒḠ::ISA = "ごଅｔ::DଐɾẎ";
+@웨ɪrƌ::ጢᶯᵷ::ISA = "ｇ";
+*ｇ:: = *ごଅｔ::;
+i ごଅｔ => qw[ ごଅｔ::DଐɾẎ ごଅｔ::DଐɾẎ::Ⱦ옥ゲᕟƃᚒḠ 웨ɪrƌ::ጢᶯᵷ ],
+ "isarev includes subclasses of aliases";
+delete $::{"ｇ::"};
+i ぅงலҬ => qw[ ごଅｔ ごଅｔ::DଐɾẎ ごଅｔ::DଐɾẎ::Ⱦ옥ゲᕟƃᚒḠ ],
+ "deleting an alias to a package updates isarev entries";
+i"ごଅｔ" => qw[ ごଅｔ::DଐɾẎ ごଅｔ::DଐɾẎ::Ⱦ옥ゲᕟƃᚒḠ ],
+ "deleting an alias to a package updates isarev entries of nested stashes";
+i"ごଅｔ::DଐɾẎ" => qw[ ごଅｔ::DଐɾẎ::Ⱦ옥ゲᕟƃᚒḠ ],
+ "deleting an stash alias updates isarev entries of doubly nested stashes";
+i ｇ => qw [ 웨ɪrƌ::ጢᶯᵷ ],
+ "subclasses of the deleted alias become part of its isarev";
+
+@챂린ẽ::ISA = "Hഓf엗::맘말";
+@챂린ẽ::DଐɾẎ::ISA = "챂린ẽ";
+@챂린ẽ::DଐɾẎ::Obｪʶ핫l::ISA = "챂린ẽ::DଐɾẎ";
+@ẂhaƮᵋቭȓ::ISA = "챂린ẽ";
+*챂릳:: = *챂린ẽ::;
+*챂린ẽ:: = *ㄔɘvレ::;
+i"Hഓf엗::맘말" => qw[ 챂릳 ],
+ "replacing a stash updates isarev entries";
+i ㄔɘvレ => qw[ 챂릳::DଐɾẎ ẂhaƮᵋቭȓ ],
+ "replacing nested stashes updates isarev entries";
+
+@ᛑiስアsઍ::ｪᔦ::ISA = "ᛑiስアsઍ";
+@ᛑiስアsઍ::ｪᔦ::Iṇᚠctĭo웃::ISA = "ᛑiስアsઍ::ｪᔦ";
+@Kㄦat옻onj운ctᝁヸቲᔈ::ISA = "ᛑiስアsઍ::Opɥt할및::Iṇᚠctĭo웃";
+*ᛑiስアsઍ::Opɥt할및:: = *ᛑiስアsઍ::ｪᔦ::;
+{package 솜e_란돔_new_symbol::Iṇᚠctĭo웃} # autovivify
+*ᛑiስアsઍ::Opɥt할및:: = *솜e_란돔_new_symbol::;
+i ᛑiስアsઍ => qw[ ᛑiስアsઍ::ｪᔦ ᛑiስアsઍ::ｪᔦ::Iṇᚠctĭo웃 ],
+ "replacing an alias of a stash updates isarev entries";
+i"ᛑiስアsઍ::ｪᔦ" => qw[ ᛑiስアsઍ::ｪᔦ::Iṇᚠctĭo웃 ],
+ "replacing an alias of a stash containing another updates isarev entries";
+i"솜e_란돔_new_symbol::Iṇᚠctĭo웃" => qw[ Kㄦat옻onj운ctᝁヸቲᔈ ],
+ "replacing an alias updates isarev of stashes nested in the replacement";
+
+# Globs ending with :: have autovivified stashes in them by default. We
+# want one without a stash.
+undef *Eṁpｔᔾ::;
+@눌Ļ::ISA = "Eṁpｔᔾ";
+@눌Ļ::눌Ļ::ISA = "Eṁpｔᔾ::Eṁpｔᔾ";
+{package ዚlcᕻ::Eṁpｔᔾ} # autovivify it
+*Eṁpｔᔾ:: = *ዚlcᕻ::;
+i ዚlcᕻ => qw[ 눌Ļ ], "assigning to an empty spot updates isarev";
+i"ዚlcᕻ::Eṁpｔᔾ" => qw[ 눌Ļ::눌Ļ ],
+ "assigning to an empty spot updates isarev of nested packages";
+
+# Classes inheriting from multiple classes that get moved in a single
+# assignment.
+@ᕘ::ISA = ("ᵇ", "ᵇ::ᵇ");
+{package अ::ᵇ}
+my $अ = \%अ::; # keep a ref
+*अ:: = 'whatever'; # clobber it
+*ᵇ:: = $अ; # assign to two superclasses of ᕘ at the same time
+# There should be no अ::ᵇ isarev entry.
+i"अ::ᵇ" => qw [], 'assigning to two superclasses at the same time';
+ok !ᕘ->isa("अ::ᵇ"),
+ "A class must not inherit from its superclass’s former name";
+
+# undeffing globs
+@α::ISA = 'β';
+$_ = \*α::ISA; # hang on to the glob
+undef *α::ISA;
+i β => qw [], "undeffing an ISA glob deletes isarev entries";
+@aᙇ::ISA = '붘ㆉ';
+$_ = \*aᙇ::ISA;
+undef *aᙇ::;
+i 붘ㆉ => qw [], "undeffing a package glob deletes isarev entries";
+
+# Package aliasing/clobbering when the clobbered package has grandchildren
+# by inheritance.
+@Ƚ::ISA = 'ภɵ';
+@숩Ȼl았A::ISA = "숩Ȼl았Ƃ";
+@숩Ȼl았Ƃ::ISA = "Ƚ";
+*Ƚ:: = *bᚪᶼ::;
+i ภɵ => qw [],
+ 'clobbering a class w/multiple layers of subclasses updates its parent';
+
+@ᖭ랕::ISA = 'S민';
+%ᖭ랕:: = ();
+i S민 => qw [], '%Package:: list assignment';
--- /dev/null
+#!./perl
+
+use utf8;
+use open qw( :utf8 :std );
+use strict;
+use warnings;
+no warnings 'redefine'; # we do a lot of this
+no warnings 'prototype'; # we do a lot of this
+
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+require './test.pl';
+
+{
+ package MC텟ᵀ::Bࡎᶓ;
+ sub ᕘ { return $_[1]+1 };
+
+ package MC텟ᵀ::ድ리ᭉᛞ;
+ our @ISA = qw/MC텟ᵀ::Bࡎᶓ/;
+
+ package Ƒｏｏ; our @ƑＯＯ = qw//;
+}
+
+# These are various ways of re-defining MC텟ᵀ::Bࡎᶓ::ᕘ and checking whether the method is cached when it shouldn't be
+my @testsubs = (
+ sub { is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 1); },
+ sub { eval 'sub MC텟ᵀ::Bࡎᶓ::ᕘ { return $_[1]+2 }'; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 2); },
+ sub { eval 'sub MC텟ᵀ::Bࡎᶓ::ᕘ($) { return $_[1]+3 }'; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 3); },
+ sub { eval 'sub MC텟ᵀ::Bࡎᶓ::ᕘ($) { 4 }'; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 4); },
+ sub { *MC텟ᵀ::Bࡎᶓ::ᕘ = sub { $_[1]+5 }; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 5); },
+ sub { local *MC텟ᵀ::Bࡎᶓ::ᕘ = sub { $_[1]+6 }; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 6); },
+ sub { is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 5); },
+ sub { sub FFF { $_[1]+7 }; local *MC텟ᵀ::Bࡎᶓ::ᕘ = *FFF; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 7); },
+ sub { is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 5); },
+ sub { sub DḊƋ { $_[1]+8 }; *MC텟ᵀ::Bࡎᶓ::ᕘ = *DḊƋ; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 8); },
+ sub { *ǎᔆɗＦ::앗ｄƑ = sub { $_[1]+9 }; *MC텟ᵀ::Bࡎᶓ::ᕘ = \&ǎᔆɗＦ::앗ｄƑ; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 9); },
+ sub { undef *MC텟ᵀ::Bࡎᶓ::ᕘ; eval { MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0) }; like($@, qr/locate object method/); },
+ sub { eval "sub MC텟ᵀ::Bࡎᶓ::ᕘ($);"; *MC텟ᵀ::Bࡎᶓ::ᕘ = \&ǎᔆɗＦ::앗ｄƑ; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 9); },
+ sub { *Xƴƶ = sub { $_[1]+10 }; ${MC텟ᵀ::Bࡎᶓ::}{ᕘ} = \&Xƴƶ; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 10); },
+ sub { ${MC텟ᵀ::Bࡎᶓ::}{ᕘ} = sub { $_[1]+11 }; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 11); },
+
+ sub { undef *MC텟ᵀ::Bࡎᶓ::ᕘ; eval { MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0) }; like($@, qr/locate object method/); },
+ sub { eval 'package MC텟ᵀ::Bࡎᶓ; sub ᕘ { $_[1]+12 }'; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 12); },
+ sub { eval 'package ᛎᛎᛎ; sub ᕘ { $_[1]+13 }'; *MC텟ᵀ::Bࡎᶓ::ᕘ = \&ᛎᛎᛎ::ᕘ; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 13); },
+ sub { ${MC텟ᵀ::Bࡎᶓ::}{ᕘ} = sub { $_[1]+14 }; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 14); },
+ # 5.8.8 fails this one
+ sub { undef *{MC텟ᵀ::Bࡎᶓ::}; eval { MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0) }; like($@, qr/locate object method/); },
+ sub { eval 'package MC텟ᵀ::Bࡎᶓ; sub ᕘ { $_[1]+15 }'; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 15); },
+ sub { undef %{MC텟ᵀ::Bࡎᶓ::}; eval { MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0) }; like($@, qr/locate object method/); },
+ sub { eval 'package MC텟ᵀ::Bࡎᶓ; sub ᕘ { $_[1]+16 }'; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 16); },
+ sub { %{MC텟ᵀ::Bࡎᶓ::} = (); eval { MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0) }; like($@, qr/locate object method/); },
+ sub { eval 'package MC텟ᵀ::Bࡎᶓ; sub ᕘ { $_[1]+17 }'; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 17); },
+ # 5.8.8 fails this one too
+#TODO: This fails due to the tokenizer not being clean, rather than mro.
+ sub { *{MC텟ᵀ::Bࡎᶓ::} = *{Ƒｏｏ::}; eval { MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0) }; like($@, qr/locate object method/); },
+ sub { *MC텟ᵀ::ድ리ᭉᛞ::ᕘ = \&MC텟ᵀ::Bࡎᶓ::ᕘ; eval { MC텟ᵀ::ድ리ᭉᛞ::ᕘ(0,0) }; ok(!$@); undef *MC텟ᵀ::ድ리ᭉᛞ::ᕘ },
+ sub { eval 'package MC텟ᵀ::Bࡎᶓ; sub ᕘ { $_[1]+18 }'; is(MC텟ᵀ::ድ리ᭉᛞ->ᕘ(0), 18); },
+);
+
+plan(tests => scalar(@testsubs));
+
+$_->() for (@testsubs);
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use NEXT;
+use utf8;
+use open qw( :utf8 :std );
+
+require './test.pl';
+plan(tests => 4);
+
+{
+ package ᕘ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+
+ sub fಓ { 'ᕘ::fಓ' }
+
+ package Fᶽ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+ use base 'ᕘ';
+
+ sub fಓ { 'Fᶽ::fಓ => ' . (shift)->next::method }
+
+ package Bᛆ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+ use base 'ᕘ';
+
+ sub fಓ { 'Bᛆ::fಓ => ' . (shift)->next::method }
+
+ package Baᕃ;
+ use strict;
+ use warnings;
+
+ use base 'Bᛆ', 'Fᶽ';
+
+ sub fಓ { 'Baᕃ::fಓ => ' . (shift)->NEXT::fಓ }
+}
+
+is(ᕘ->fಓ, 'ᕘ::fಓ', '... got the right value from ᕘ->fಓ');
+is(Fᶽ->fಓ, 'Fᶽ::fಓ => ᕘ::fಓ', '... got the right value from Fᶽ->fಓ');
+is(Bᛆ->fಓ, 'Bᛆ::fಓ => ᕘ::fಓ', '... got the right value from Bᛆ->fಓ');
+
+is(Baᕃ->fಓ, 'Baᕃ::fಓ => Bᛆ::fಓ => Fᶽ::fಓ => ᕘ::fಓ', '... got the right value using NEXT in a subclass of a C3 class');
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+BEGIN { chdir 't'; require q(./test.pl); @INC = qw "../lib lib" }
+
+use utf8;
+use open qw( :utf8 :std );
+
+plan(tests => 12);
+
+{
+
+ {
+ package ᕘ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+ sub new { bless {}, $_[0] }
+ sub ƚ { 'ᕘ::ƚ' }
+ }
+
+ # call the submethod in the direct instance
+
+ my $foo = ᕘ->new();
+ isa_ok($foo, 'ᕘ');
+
+ can_ok($foo, 'ƚ');
+ is($foo->ƚ(), 'ᕘ::ƚ', '... got the right return value');
+
+ # fail calling it from a subclass
+
+ {
+ package Baɾ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+ our @ISA = ('ᕘ');
+ }
+
+ my $bar = Baɾ->new();
+ isa_ok($bar, 'Baɾ');
+ isa_ok($bar, 'ᕘ');
+
+ # test it working with with Sub::Name
+ SKIP: {
+ eval 'use Sub::Name';
+ skip("Sub::Name is required for this test", 3) if $@;
+
+ my $m = sub { (shift)->next::method() };
+ Sub::Name::subname('Baɾ::ƚ', $m);
+ {
+ no strict 'refs';
+ *{'Baɾ::ƚ'} = $m;
+ }
+
+ can_ok($bar, 'ƚ');
+ my $value = eval { $bar->ƚ() };
+ ok(!$@, '... calling ƚ() succeeded') || diag $@;
+ is($value, 'ᕘ::ƚ', '... got the right return value too');
+ }
+
+ # test it failing without Sub::Name
+ {
+ package બʑ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+ our @ISA = ('ᕘ');
+ }
+
+ my $baz = બʑ->new();
+ isa_ok($baz, 'બʑ');
+ isa_ok($baz, 'ᕘ');
+
+ {
+ my $m = sub { (shift)->next::method() };
+ {
+ no strict 'refs';
+ *{'બʑ::ƚ'} = $m;
+ }
+
+ eval { $baz->ƚ() };
+ ok($@, '... calling ƚ() with next::method failed') || diag $@;
+ }
+
+ # Test with non-existing class (used to segfault)
+ {
+ package Qűx;
+ use mro;
+ sub fਓ { No::Such::Class->next::can }
+ }
+
+ eval { Qűx->fਓ() };
+ is($@, '', "->next::can on non-existing package name");
+
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+require q(./test.pl); plan(tests => 4);
+
+use mro;
+
+{
+ package PṞoxᚤ;
+ our @ISA = qw//;
+ sub next_prxᔬ { goto &next::method }
+ sub maybe_prxᔬ { goto &maybe::next::method }
+ sub can_prxᔬ { goto &next::can }
+
+ package Ⱦ밧ᶟ;
+ our @ISA = qw//;
+ sub ᕗ { 42 }
+ sub Ƚ { 24 }
+ # বẔ doesn't exist intentionally
+ sub ʠঊₓ { 242 }
+
+ package ᵗ톺;
+ our @ISA = qw/Ⱦ밧ᶟ/;
+ sub ᕗ { shift->PṞoxᚤ::next_prxᔬ() }
+ sub Ƚ { shift->PṞoxᚤ::maybe_prxᔬ() }
+ sub বẔ { shift->PṞoxᚤ::maybe_prxᔬ() }
+ sub ʠঊₓ { shift->PṞoxᚤ::can_prxᔬ()->() }
+}
+
+is(ᵗ톺->ᕗ, 42, 'proxy next::method via goto');
+is(ᵗ톺->Ƚ, 24, 'proxy maybe::next::method via goto');
+ok(!ᵗ톺->বẔ, 'proxy maybe::next::method via goto with no method');
+is(ᵗ톺->ʠঊₓ, 242, 'proxy next::can via goto');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+require q(./test.pl); plan(tests => 2);
+
+=pod
+
+This tests the successful handling of a next::method call from within an
+anonymous subroutine.
+
+=cut
+
+{
+ package ㅏ;
+ use mro 'c3';
+
+ sub ᕘ {
+ return 'ㅏ::ᕘ';
+ }
+
+ sub Ḃᛆ {
+ return 'ㅏ::Ḃᛆ';
+ }
+}
+
+{
+ package Ḃ;
+ use base 'ㅏ';
+ use mro 'c3';
+
+ sub ᕘ {
+ my $code = sub {
+ return 'Ḃ::ᕘ => ' . (shift)->next::method();
+ };
+ return (shift)->$code;
+ }
+
+ sub Ḃᛆ {
+ my $code1 = sub {
+ my $code2 = sub {
+ return 'Ḃ::Ḃᛆ => ' . (shift)->next::method();
+ };
+ return (shift)->$code2;
+ };
+ return (shift)->$code1;
+ }
+}
+
+is(Ḃ->ᕘ, "Ḃ::ᕘ => ㅏ::ᕘ",
+ 'method resolved inside anonymous sub');
+
+is(Ḃ->Ḃᛆ, "Ḃ::Ḃᛆ => ㅏ::Ḃᛆ",
+ 'method resolved inside nested anonymous subs');
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 1);
+
+=pod
+
+This tests the use of an eval{} block to wrap a next::method call.
+
+=cut
+
+{
+ package అ;
+ use mro 'c3';
+
+ sub ຟǫ {
+ die 'అ::ຟǫ died';
+ return 'అ::ຟǫ succeeded';
+ }
+}
+
+{
+ package ｂ;
+ use base 'అ';
+ use mro 'c3';
+
+ sub ຟǫ {
+ eval {
+ return 'ｂ::ຟǫ => ' . (shift)->next::method();
+ };
+
+ if ($@) {
+ return $@;
+ }
+ }
+}
+
+like(ｂ->ຟǫ,
+ qr/^అ::ຟǫ died/u,
+ 'method resolved inside eval{}');
+
+
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 5);
+
+=pod
+
+This tests the classic diamond inheritance pattern.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Diӑmond_A;
+ use mro 'c3';
+ sub 헬ฬ { 'Diӑmond_A::헬ฬ' }
+ sub fಓ { 'Diӑmond_A::fಓ' }
+}
+{
+ package Diӑmond_B;
+ use base 'Diӑmond_A';
+ use mro 'c3';
+ sub fಓ { 'Diӑmond_B::fಓ => ' . (shift)->next::method() }
+}
+{
+ package Diӑmond_C;
+ use mro 'c3';
+ use base 'Diӑmond_A';
+
+ sub 헬ฬ { 'Diӑmond_C::헬ฬ => ' . (shift)->next::method() }
+ sub fಓ { 'Diӑmond_C::fಓ => ' . (shift)->next::method() }
+}
+{
+ package Diӑmond_D;
+ use base ('Diӑmond_B', 'Diӑmond_C');
+ use mro 'c3';
+
+ sub fಓ { 'Diӑmond_D::fಓ => ' . (shift)->next::method() }
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Diӑmond_D'),
+ [ qw(Diӑmond_D Diӑmond_B Diӑmond_C Diӑmond_A) ]
+), '... got the right MRO for Diӑmond_D');
+
+is(Diӑmond_D->헬ฬ, 'Diӑmond_C::헬ฬ => Diӑmond_A::헬ฬ', '... method resolved itself as expected');
+
+is(Diӑmond_D->can('헬ฬ')->('Diӑmond_D'),
+ 'Diӑmond_C::헬ฬ => Diӑmond_A::헬ฬ',
+ '... can(method) resolved itself as expected');
+
+is(UNIVERSAL::can("Diӑmond_D", '헬ฬ')->('Diӑmond_D'),
+ 'Diӑmond_C::헬ฬ => Diӑmond_A::헬ฬ',
+ '... can(method) resolved itself as expected');
+
+is(Diӑmond_D->fಓ,
+ 'Diӑmond_D::fಓ => Diӑmond_B::fಓ => Diӑmond_C::fಓ => Diӑmond_A::fಓ',
+ '... method fಓ resolved itself as expected');
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+require q(./test.pl); plan(tests => 10);
+
+use utf8;
+use open qw( :utf8 :std );
+
+=pod
+
+This tests the classic diamond inheritance pattern.
+
+ <A>
+ / \
+<B> <C>
+ \ /
+ <D>
+
+=cut
+
+{
+ package Ｄiᚪၚd_A;
+ use mro 'c3';
+ sub ᴮaȐ { 'Ｄiᚪၚd_A::ᴮaȐ' }
+ sub 바ź { 'Ｄiᚪၚd_A::바ź' }
+}
+{
+ package Ｄiᚪၚd_B;
+ use base 'Ｄiᚪၚd_A';
+ use mro 'c3';
+ sub 바ź { 'Ｄiᚪၚd_B::바ź => ' . (shift)->next::method() }
+}
+{
+ package Ｄiᚪၚd_C;
+ use mro 'c3';
+ use base 'Ｄiᚪၚd_A';
+ sub ᕘ { 'Ｄiᚪၚd_C::ᕘ' }
+ sub buƵ { 'Ｄiᚪၚd_C::buƵ' }
+
+ sub woｚ { 'Ｄiᚪၚd_C::woｚ' }
+ sub maᐇbʚ { 'Ｄiᚪၚd_C::maᐇbʚ' }
+}
+{
+ package Ｄiᚪၚd_D;
+ use base ('Ｄiᚪၚd_B', 'Ｄiᚪၚd_C');
+ use mro 'c3';
+ sub ᕘ { 'Ｄiᚪၚd_D::ᕘ => ' . (shift)->next::method() }
+ sub ᴮaȐ { 'Ｄiᚪၚd_D::ᴮaȐ => ' . (shift)->next::method() }
+ sub buƵ { 'Ｄiᚪၚd_D::buƵ => ' . (shift)->바ź() }
+ sub fuz { 'Ｄiᚪၚd_D::fuz => ' . (shift)->next::method() }
+
+ sub woｚ { 'Ｄiᚪၚd_D::woｚ can => ' . ((shift)->next::can() ? 1 : 0) }
+ sub noz { 'Ｄiᚪၚd_D::noz can => ' . ((shift)->next::can() ? 1 : 0) }
+
+ sub maᐇbʚ { 'Ｄiᚪၚd_D::maᐇbʚ => ' . ((shift)->maybe::next::method() || 0) }
+ sub ᒧyベ { 'Ｄiᚪၚd_D::ᒧyベ => ' . ((shift)->maybe::next::method() || 0) }
+
+}
+
+ok(eq_array(
+ mro::get_linear_isa('Ｄiᚪၚd_D'),
+ [ qw(Ｄiᚪၚd_D Ｄiᚪၚd_B Ｄiᚪၚd_C Ｄiᚪၚd_A) ]
+), '... got the right MRO for Ｄiᚪၚd_D');
+
+is(Ｄiᚪၚd_D->ᕘ, 'Ｄiᚪၚd_D::ᕘ => Ｄiᚪၚd_C::ᕘ', '... skipped B and went to C correctly');
+is(Ｄiᚪၚd_D->ᴮaȐ, 'Ｄiᚪၚd_D::ᴮaȐ => Ｄiᚪၚd_A::ᴮaȐ', '... skipped B & C and went to A correctly');
+is(Ｄiᚪၚd_D->바ź, 'Ｄiᚪၚd_B::바ź => Ｄiᚪၚd_A::바ź', '... called B method, skipped C and went to A correctly');
+is(Ｄiᚪၚd_D->buƵ, 'Ｄiᚪၚd_D::buƵ => Ｄiᚪၚd_B::바ź => Ｄiᚪၚd_A::바ź', '... called D method dispatched to , different method correctly');
+TODO: {
+ local our $TODO = "Warnings aren't clean yet";
+ eval { Ｄiᚪၚd_D->fuz };
+ like($@, qr/^No next::method 'fuz' found for Ｄiᚪၚd_D/u, '... cannot re-dispatch to a method which is not there');
+}
+is(Ｄiᚪၚd_D->woｚ, 'Ｄiᚪၚd_D::woｚ can => 1', '... can re-dispatch figured out correctly');
+is(Ｄiᚪၚd_D->noz, 'Ｄiᚪၚd_D::noz can => 0', '... cannot re-dispatch figured out correctly');
+
+is(Ｄiᚪၚd_D->maᐇbʚ, 'Ｄiᚪၚd_D::maᐇbʚ => Ｄiᚪၚd_C::maᐇbʚ', '... redispatched D to C when it exists');
+is(Ｄiᚪၚd_D->ᒧyベ, 'Ｄiᚪၚd_D::ᒧyベ => 0', '... quietly failed redispatch from D');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+
+use utf8;
+use open qw( :utf8 :std );
+
+require q(./test.pl); plan(tests => 7);
+
+{
+ package 밧e텟ʇ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+
+ package Ov에rꪩࡃᛝＴeŝṱ;
+ use strict;
+ use warnings;
+ use mro 'c3';
+ use base '밧e텟ʇ';
+ use overload '""' => sub { ref(shift) . " stringified" },
+ fallback => 1;
+
+ sub ネᚹ { bless {} => shift }
+
+ package 읺ҎꀀḮṆᵷꜰ롬ᵕveŔŁoad엗텟ᵵ;
+ use strict;
+ use warnings;
+ use base 'Ov에rꪩࡃᛝＴeŝṱ';
+ use mro 'c3';
+}
+
+my $x = 읺ҎꀀḮṆᵷꜰ롬ᵕveŔŁoad엗텟ᵵ->ネᚹ();
+isa_ok($x, '읺ҎꀀḮṆᵷꜰ롬ᵕveŔŁoad엗텟ᵵ');
+
+my $y = Ov에rꪩࡃᛝＴeŝṱ->ネᚹ();
+isa_ok($y, 'Ov에rꪩࡃᛝＴeŝṱ');
+
+is("$x", '읺ҎꀀḮṆᵷꜰ롬ᵕveŔŁoad엗텟ᵵ stringified', '... got the right value when stringifing');
+is("$y", 'Ov에rꪩࡃᛝＴeŝṱ stringified', '... got the right value when stringifing');
+
+ok(($y eq 'Ov에rꪩࡃᛝＴeŝṱ stringified'), '... eq was handled correctly');
+
+my $result;
+eval {
+ $result = $x eq '읺ҎꀀḮṆᵷꜰ롬ᵕveŔŁoad엗텟ᵵ stringified'
+};
+ok(!$@, '... this should not throw an exception');
+ok($result, '... and we should get the true value');
+
--- /dev/null
+#!./perl
+
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ require q(./test.pl);
+}
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+plan(tests => 52);
+
+{
+ package Ｎeẁ;
+ use strict;
+ use warnings;
+
+ package ऑlㄉ;
+ use strict;
+ use warnings;
+
+ {
+ no strict 'refs';
+ *{'ऑlㄉ::'} = *{'Ｎeẁ::'};
+ }
+}
+
+ok (ऑlㄉ->isa(Ｎeẁ::), 'ऑlㄉ inherits from Ｎeẁ');
+ok (Ｎeẁ->isa(ऑlㄉ::), 'Ｎeẁ inherits from ऑlㄉ');
+
+isa_ok (bless ({}, ऑlㄉ::), Ｎeẁ::, 'ऑlㄉ object');
+isa_ok (bless ({}, Ｎeẁ::), ऑlㄉ::, 'Ｎeẁ object');
+
+
+# Test that replacing a package by assigning to an existing glob
+# invalidates the isa caches
+for(
+ {
+ name => 'assigning a glob to a glob',
+ code => '$life_raft = $::{"ｌㅔf::"}; *ｌㅔf:: = $::{"릭Ⱶᵀ::"}',
+ },
+ {
+ name => 'assigning a string to a glob',
+ code => '$life_raft = $::{"ｌㅔf::"}; *ｌㅔf:: = "릭Ⱶᵀ::"',
+ },
+ {
+ name => 'assigning a stashref to a glob',
+ code => '$life_raft = \%ｌㅔf::; *ｌㅔf:: = \%릭Ⱶᵀ::',
+ },
+) {
+my $prog = q~
+ BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+ use utf8;
+ use open qw( :utf8 :std );
+
+ @숩cਲꩋ::ISA = "ｌㅔf";
+ @ｌㅔf::ISA = "톺ĺФț";
+
+ sub 톺ĺФț::Ｓᑊeಅḱ { "Woof!" }
+ sub ᴖ릭ᚽʇ::Ｓᑊeಅḱ { "Bow-wow!" }
+
+ my $thing = bless [], "숩cਲꩋ";
+
+ # mro_package_moved needs to know to skip non-globs
+ $릭Ⱶᵀ::{"ᚷꝆエcƙ::"} = 3;
+
+ @릭Ⱶᵀ::ISA = 'ᴖ릭ᚽʇ';
+ my $life_raft;
+ __code__;
+
+ print $thing->Ｓᑊeಅḱ, "\n";
+
+ undef $life_raft;
+ print $thing->Ｓᑊeಅḱ, "\n";
+ ~ =~ s\__code__\$$_{code}\r; #\
+utf8::encode($prog);
+ fresh_perl_is
+ $prog,
+ "Bow-wow!\nBow-wow!\n",
+ {},
+ "replacing packages by $$_{name} updates isa caches";
+}
+
+# Similar test, but with nested packages
+#
+# 톺ĺФț (Woof) ᴖ릭ᚽʇ (Bow-wow)
+# | |
+# ｌㅔf::Side <- 릭Ⱶᵀ::Side
+# |
+# 숩cਲꩋ
+#
+# This test assigns 릭Ⱶᵀ:: to ｌㅔf::, indirectly making ｌㅔf::Side an
+# alias to 릭Ⱶᵀ::Side (following the arrow in the diagram).
+for(
+ {
+ name => 'assigning a glob to a glob',
+ code => '$life_raft = $::{"ｌㅔf::"}; *ｌㅔf:: = $::{"릭Ⱶᵀ::"}',
+ },
+ {
+ name => 'assigning a string to a glob',
+ code => '$life_raft = $::{"ｌㅔf::"}; *ｌㅔf:: = "릭Ⱶᵀ::"',
+ },
+ {
+ name => 'assigning a stashref to a glob',
+ code => '$life_raft = \%ｌㅔf::; *ｌㅔf:: = \%릭Ⱶᵀ::',
+ },
+) {
+ my $prog = q~
+ BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+ use utf8;
+ use open qw( :utf8 :std );
+ @숩cਲꩋ::ISA = "ｌㅔf::Side";
+ @ｌㅔf::Side::ISA = "톺ĺФț";
+
+ sub 톺ĺФț::Ｓᑊeಅḱ { "Woof!" }
+ sub ᴖ릭ᚽʇ::Ｓᑊeಅḱ { "Bow-wow!" }
+
+ my $thing = bless [], "숩cਲꩋ";
+
+ @릭Ⱶᵀ::Side::ISA = 'ᴖ릭ᚽʇ';
+ my $life_raft;
+ __code__;
+
+ print $thing->Ｓᑊeಅḱ, "\n";
+
+ undef $life_raft;
+ print $thing->Ｓᑊeಅḱ, "\n";
+ ~ =~ s\__code__\$$_{code}\r;
+ utf8::encode($prog);
+
+ fresh_perl_is
+ $prog,
+ "Bow-wow!\nBow-wow!\n",
+ {},
+ "replacing nested packages by $$_{name} updates isa caches";
+}
+
+# Another nested package test, in which the isa cache needs to be reset on
+# the subclass of a package that does not exist.
+#
+# Parenthesized packages do not exist.
+#
+# ɵűʇㄦ::인ንʵ ( cฬnए::인ንʵ )
+# | |
+# Ｌфť R익hȚ
+#
+# ɵűʇㄦ -> cฬnए
+#
+# This test assigns ɵűʇㄦ:: to cฬnए::, making cฬnए::인ንʵ an alias to
+# ɵűʇㄦ::인ንʵ.
+#
+# Then we also run the test again, but without ɵűʇㄦ::인ንʵ
+for(
+ {
+ name => 'assigning a glob to a glob',
+ code => '*cฬnए:: = *ɵűʇㄦ::',
+ },
+ {
+ name => 'assigning a string to a glob',
+ code => '*cฬnए:: = "ɵűʇㄦ::"',
+ },
+ {
+ name => 'assigning a stashref to a glob',
+ code => '*cฬnए:: = \%ɵűʇㄦ::',
+ },
+) {
+ for my $tail ('인ንʵ', '인ንʵ::', '인ንʵ:::', '인ንʵ::::') {
+ my $prog = q~
+ BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+ use utf8;
+ use open qw( :utf8 :std );
+ use Encode ();
+
+ if (grep /\P{ASCII}/, @ARGV) {
+ @ARGV = map { Encode::decode("UTF-8", $_) } @ARGV;
+ }
+
+ my $tail = shift;
+ @Ｌфť::ISA = "ɵűʇㄦ::$tail";
+ @R익hȚ::ISA = "cฬnए::$tail";
+ bless [], "ɵűʇㄦ::$tail"; # autovivify the stash
+
+ __code__;
+
+ print "ok 1", "\n" if Ｌфť->isa("cฬnए::$tail");
+ print "ok 2", "\n" if R익hȚ->isa("ɵűʇㄦ::$tail");
+ print "ok 3", "\n" if R익hȚ->isa("cฬnए::$tail");
+ print "ok 4", "\n" if Ｌфť->isa("ɵűʇㄦ::$tail");
+ ~ =~ s\__code__\$$_{code}\r;
+ utf8::encode($prog);
+ fresh_perl_is
+ $prog,
+ "ok 1\nok 2\nok 3\nok 4\n",
+ { args => [$tail] },
+ "replacing nonexistent nested packages by $$_{name} updates isa caches"
+ ." ($tail)";
+
+ # Same test but with the subpackage autovivified after the assignment
+ $prog = q~
+ BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+ use utf8;
+ use open qw( :utf8 :std );
+ use Encode ();
+
+ if (grep /\P{ASCII}/, @ARGV) {
+ @ARGV = map { Encode::decode("UTF-8", $_) } @ARGV;
+ }
+
+ my $tail = shift;
+ @Ｌфť::ISA = "ɵűʇㄦ::$tail";
+ @R익hȚ::ISA = "cฬnए::$tail";
+
+ __code__;
+
+ bless [], "ɵűʇㄦ::$tail";
+
+ print "ok 1", "\n" if Ｌфť->isa("cฬnए::$tail");
+ print "ok 2", "\n" if R익hȚ->isa("ɵűʇㄦ::$tail");
+ print "ok 3", "\n" if R익hȚ->isa("cฬnए::$tail");
+ print "ok 4", "\n" if Ｌфť->isa("ɵűʇㄦ::$tail");
+ ~ =~ s\__code__\$$_{code}\r;
+ utf8::encode($prog);
+ fresh_perl_is
+ $prog,
+ "ok 1\nok 2\nok 3\nok 4\n",
+ { args => [$tail] },
+ "Giving nonexistent packages multiple effective names by $$_{name}"
+ . " ($tail)";
+ }
+}
+
+no warnings; # temporary; there seems to be a scoping bug, as this does not
+ # work when placed in the blocks below
+
+# Test that deleting stash elements containing
+# subpackages also invalidates the isa cache.
+# Maybe this does not belong in package_aliases.t, but it is closely
+# related to the tests immediately preceding.
+{
+ @ቹऋ::ISA = ("Cuȓ", "ฮﾝᛞ");
+ @Cuȓ::ISA = "Hyḹ앛Ҭテ";
+
+ sub Hyḹ앛Ҭテ::Ｓᑊeಅḱ { "Arff!" }
+ sub ฮﾝᛞ::Ｓᑊeಅḱ { "Woof!" }
+
+ my $pet = bless [], "ቹऋ";
+
+ my $life_raft = delete $::{'Cuȓ::'};
+
+ is $pet->Ｓᑊeಅḱ, 'Woof!',
+ 'deleting a stash from its parent stash invalidates the isa caches';
+
+ undef $life_raft;
+ is $pet->Ｓᑊeಅḱ, 'Woof!',
+ 'the deleted stash is gone completely when freed';
+}
+# Same thing, but with nested packages
+{
+ @펱ᑦ::ISA = ("Cuȓȓ::Cuȓȓ::Cuȓȓ", "ɥwn");
+ @Cuȓȓ::Cuȓȓ::Cuȓȓ::ISA = "lȺt랕ᚖ";
+
+ sub lȺt랕ᚖ::Ｓᑊeಅḱ { "Arff!" }
+ sub ɥwn::Ｓᑊeಅḱ { "Woof!" }
+
+ my $pet = bless [], "펱ᑦ";
+
+ my $life_raft = delete $::{'Cuȓȓ::'};
+
+ is $pet->Ｓᑊeಅḱ, 'Woof!',
+ 'deleting a stash from its parent stash resets caches of substashes';
+
+ undef $life_raft;
+ is $pet->Ｓᑊeಅḱ, 'Woof!',
+ 'the deleted substash is gone completely when freed';
+}
+
+# [perl #77358]
+my $prog = q~#!perl -w
+ BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+ }
+ use utf8;
+ use open qw( :utf8 :std );
+ @펱ᑦ::ISA = "T잌ዕ";
+ @T잌ዕ::ISA = "Bᛆヶṝ";
+
+ sub Bᛆヶṝ::Ｓᑊeಅḱ { print "Woof!\n" }
+ sub lȺt랕ᚖ::Ｓᑊeಅḱ { print "Bow-wow!\n" }
+
+ my $pet = bless [], "펱ᑦ";
+
+ $pet->Ｓᑊeಅḱ;
+
+ sub ດƓ::Ｓᑊeಅḱ { print "Hello.\n" } # strange ດƓ!
+ @ດƓ::ISA = 'lȺt랕ᚖ';
+ *T잌ዕ:: = delete $::{'ດƓ::'};
+
+ $pet->Ｓᑊeಅḱ;
+ ~;
+utf8::encode($prog);
+fresh_perl_is
+ $prog,
+ "Woof!\nHello.\n",
+ { stderr => 1 },
+ "Assigning a nameless package over one w/subclasses updates isa caches";
+
+# mro_package_moved needs to make a distinction between replaced and
+# assigned stashes when keeping track of what it has seen so far.
+no warnings; {
+ no strict 'refs';
+
+ sub ʉ::bᓗnǩ::bᓗnǩ::ພo { "bbb" }
+ sub ᵛeↄl움::ພo { "lasrevinu" }
+ @ݏ엗Ƚeᵬૐᵖ::ISA = qw 'ພo::bᓗnǩ::bᓗnǩ ᵛeↄl움';
+ *ພo::ବㄗ:: = *ʉ::bᓗnǩ::; # now ʉ::bᓗnǩ:: is on both sides
+ *ພo:: = *ʉ::; # here ʉ::bᓗnǩ:: is both deleted and added
+ *ʉ:: = *ቦᵕ::; # now it is only known as ພo::bᓗnǩ::
+
+ # At this point, before the bug was fixed, %ພo::bᓗnǩ::bᓗnǩ:: ended
+ # up with no effective name, allowing it to be deleted without updating
+ # its subclassesâ\80\99 caches.
+
+ my $accum = '';
+
+ $accum .= 'ݏ엗Ƚeᵬૐᵖ'->ພo; # bbb
+ delete ${"ພo::bᓗnǩ::"}{"bᓗnǩ::"};
+ $accum .= 'ݏ엗Ƚeᵬૐᵖ'->ພo; # bbb (Oops!)
+ @ݏ엗Ƚeᵬૐᵖ::ISA = @ݏ엗Ƚeᵬૐᵖ::ISA;
+ $accum .= 'ݏ엗Ƚeᵬૐᵖ'->ພo; # lasrevinu
+
+ is $accum, 'bbblasrevinulasrevinu',
+ 'nested classes deleted & added simultaneously';
+}
+use warnings;
+
+# mro_package_moved needs to check for self-referential packages.
+# This broke Text::Template [perl #78362].
+watchdog 3;
+*ᕘ:: = \%::;
+*Aᶜme::Mῌ::Aᶜme:: = \*Aᶜme::; # indirect self-reference
+pass("mro_package_moved and self-referential packages");
+
+# Deleting a glob whose name does not indicate its location in the symbol
+# table but which nonetheless *is* in the symbol table.
+{
+ no strict refs=>;
+ no warnings;
+ @ოƐ::mഒrェ::ISA = "foᚒ";
+ sub foᚒ::ວmᑊ { "aoeaa" }
+ *ťວ:: = *ოƐ::;
+ delete $::{"ოƐ::"};
+ @C힐dᒡl았::ISA = 'ťວ::mഒrェ';
+ my $accum = 'C힐dᒡl았'->ວmᑊ . '-';
+ my $life_raft = delete ${"ťວ::"}{"mഒrェ::"};
+ $accum .= eval { 'C힐dᒡl았'->ວmᑊ } // '<undef>';
+ is $accum, 'aoeaa-<undef>',
+ 'Deleting globs whose loc in the symtab differs from gv_fullname'
+}
+
+# Pathological test for undeffing a stash that has an alias.
+*ᵍh엞:: = *ኔƞ::;
+@숩cਲꩋ::ISA = 'ᵍh엞';
+undef %ᵍh엞::;
+sub F렐ᛔ::ວmᑊ { "clumpren" }
+eval '
+ $ኔƞ::whatever++;
+ @ኔƞ::ISA = "F렐ᛔ";
+';
+is eval { '숩cਲꩋ'->ວmᑊ }, 'clumpren',
+ 'Changes to @ISA after undef via original name';
+undef %ᵍh엞::;
+eval '
+ $ᵍh엞::whatever++;
+ @ᵍh엞::ISA = "F렐ᛔ";
+';
+is eval { '숩cਲꩋ'->ວmᑊ }, 'clumpren',
+ 'Changes to @ISA after undef via alias';
+
+
+# Packages whose containing stashes have aliases must lose all names cor-
+# responding to that container when detached.
+{
+ {package śmᛅḙ::በɀ} # autovivify
+ *pḢ린ᚷ:: = *śmᛅḙ::; # śmᛅḙ::በɀ now also named pḢ린ᚷ::በɀ
+ *본:: = delete $śmᛅḙ::{"በɀ::"};
+ # In 5.13.7, it has now lost its śmᛅḙ::በɀ name (reverting to pḢ린ᚷ::በɀ
+ # as the effective name), and gained 본 as an alias.
+ # In 5.13.8, both śmᛅḙ::በɀ *and* pḢ린ᚷ::በɀ names are deleted.
+
+ # Make some methods
+ no strict 'refs';
+ *{"pḢ린ᚷ::በɀ::fฤmᛈ"} = sub { "hello" };
+ sub Ｆルmፕṟ::fฤmᛈ { "good bye" };
+
+ @ᵇるᣘ킨::ISA = qw "본 Ｆルmፕṟ"; # now wrongly inherits from pḢ린ᚷ::በɀ
+
+ is fฤmᛈ ᵇるᣘ킨, "good bye",
+ 'detached stashes lose all names corresponding to the containing stash';
+}
+
+# Crazy edge cases involving packages ending with a single :
+@촐oン::ISA = 'ᚖგ:'; # pun intended!
+bless [], "ᚖგ:"; # autovivify the stash
+ok "촐oン"->isa("ᚖგ:"), 'class isa "class:"';
+{ no strict 'refs'; *{"ᚖგ:::"} = *ᚖგ:: }
+ok "촐oン"->isa("ᚖგ"),
+ 'isa(ᕘ) when inheriting from "class:" which is an alias for ᕘ';
+{
+ no warnings;
+ # The next line of code is *not* normative. If the structure changes,
+ # this line needs to change, too.
+ my $ᕘ = delete $ᚖგ::{":"};
+ ok !촐oン->isa("ᚖგ"),
+ 'class that isa "class:" no longer isa ᕘ if "class:" has been deleted';
+}
+@촐oン::ISA = ':';
+bless [], ":";
+ok "촐oン"->isa(":"), 'class isa ":"';
+{ no strict 'refs'; *{":::"} = *ፑňṪu앝ȋ온:: }
+ok "촐oン"->isa("ፑňṪu앝ȋ온"),
+ 'isa(ᕘ) when inheriting from ":" which is an alias for ᕘ';
+@촐oン::ISA = 'ᚖგ:';
+bless [], "ᚖგ:";
+{
+ no strict 'refs';
+ my $life_raft = \%{"ᚖგ:::"};
+ *{"ᚖგ:::"} = \%ᚖგ::;
+ ok "촐oン"->isa("ᚖგ"),
+ 'isa(ᕘ) when inheriting from "class:" after hash-to-glob assignment';
+}
+@촐oン::ISA = 'ŏ:';
+bless [], "ŏ:";
+{
+ no strict 'refs';
+ my $life_raft = \%{"ŏ:::"};
+ *{"ŏ:::"} = "ᚖგ::";
+ ok "촐oン"->isa("ᚖგ"),
+ 'isa(ᕘ) when inheriting from "class:" after string-to-glob assignment';
+}
+=cut
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+
+chdir 't' if -d 't';
+require q(./test.pl); plan(tests => 7);
+
+require mro;
+
+{
+ package ᕘ;
+ our @ISA = qw//;
+}
+
+ok(!mro::get_pkg_gen('레알ឭ되s놑Eξsᴛ'),
+ "pkg_gen 0 for non-existent pkg");
+
+my $f_gen = mro::get_pkg_gen('ᕘ');
+ok($f_gen > 0, 'ᕘ pkg_gen > 0');
+
+{
+ no warnings 'once';
+ *ᕘ::ᕘ_Ƒ운ℭ = sub { 123 };
+}
+my $new_f_gen = mro::get_pkg_gen('ᕘ');
+ok($new_f_gen > $f_gen, 'ᕘ pkg_gen incs for methods');
+$f_gen = $new_f_gen;
+
+@ᕘ::ISA = qw/Bar/;
+$new_f_gen = mro::get_pkg_gen('ᕘ');
+ok($new_f_gen > $f_gen, 'ᕘ pkg_gen incs for @ISA');
+
+undef %ᕘ::;
+is(mro::get_pkg_gen('ᕘ'), 1, "pkg_gen 1 for undef %Pkg::");
+
+delete $::{"ᕘ::"};
+is(mro::get_pkg_gen('ᕘ'), 0, 'pkg_gen 0 for delete $::{Pkg::}');
+
+delete $::{"ㄑଊｘ::"};
+push @ㄑଊｘ::ISA, "Woot"; # should not segfault
+ok(1, "No segfault on modification of ISA in a deleted stash");
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+use utf8;
+use open qw( :utf8 :std );
+
+require './test.pl';
+
+plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM};
+plan(tests => 8);
+
+require mro;
+
+=pod
+
+These are like the 010_complex_merge_classless test,
+but an infinite loop has been made in the heirarchy,
+to test that we can fail cleanly instead of going
+into an infinite loop
+
+=cut
+
+# initial setup, everything sane
+{
+ package ƙ;
+ use mro 'c3';
+ our @ISA = qw/ᶨ ィ/;
+ package ᶨ;
+ use mro 'c3';
+ our @ISA = qw/ｆ/;
+ package ィ;
+ use mro 'c3';
+ our @ISA = qw/ʰ ｆ/;
+ package ʰ;
+ use mro 'c3';
+ our @ISA = qw/ᶢ/;
+ package ᶢ;
+ use mro 'c3';
+ our @ISA = qw/ᛞ/;
+ package ｆ;
+ use mro 'c3';
+ our @ISA = qw/ǝ/;
+ package ǝ;
+ use mro 'c3';
+ our @ISA = qw/ᛞ/;
+ package ᛞ;
+ use mro 'c3';
+ our @ISA = qw/Ạ Ｂ ʗ/;
+ package ʗ;
+ use mro 'c3';
+ our @ISA = qw//;
+ package Ｂ;
+ use mro 'c3';
+ our @ISA = qw//;
+ package Ạ;
+ use mro 'c3';
+ our @ISA = qw//;
+}
+
+# A series of 8 aberations that would cause infinite loops,
+# each one undoing the work of the previous
+my @loopies = (
+ sub { @ǝ::ISA = qw/ｆ/ },
+ sub { @ǝ::ISA = qw/ᛞ/; @ʗ::ISA = qw/ｆ/ },
+ sub { @ʗ::ISA = qw//; @Ạ::ISA = qw/ƙ/ },
+ sub { @Ạ::ISA = qw//; @ᶨ::ISA = qw/ｆ ƙ/ },
+ sub { @ᶨ::ISA = qw/ｆ/; @ʰ::ISA = qw/ƙ ᶢ/ },
+ sub { @ʰ::ISA = qw/ᶢ/; @Ｂ::ISA = qw/Ｂ/ },
+ sub { @Ｂ::ISA = qw//; @ƙ::ISA = qw/ƙ ᶨ ィ/ },
+ sub { @ƙ::ISA = qw/ᶨ ィ/; @ᛞ::ISA = qw/Ạ ʰ Ｂ ʗ/ },
+);
+
+foreach my $loopy (@loopies) {
+ eval {
+ local $SIG{ALRM} = sub { die "ALRMTimeout" };
+ alarm(3);
+ $loopy->();
+ mro::get_linear_isa('ƙ', 'c3');
+ };
+
+ if(my $err = $@) {
+ if($err =~ /ALRMTimeout/) {
+ ok(0, "Loop terminated by SIGALRM");
+ }
+ elsif($err =~ /Recursive inheritance detected/) {
+ ok(1, "Graceful exception thrown");
+ }
+ else {
+ ok(0, "Unrecognized exception: $err");
+ }
+ }
+ else {
+ ok(0, "Infinite loop apparently succeeded???");
+ }
+}
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+BEGIN {
+ unless (-d 'blib') {
+ chdir 't' if -d 't';
+ @INC = '../lib';
+ }
+}
+use utf8;
+use open qw( :utf8 :std );
+
+require './test.pl';
+
+plan(skip_all => "Your system has no SIGALRM") if !exists $SIG{ALRM};
+plan(tests => 8);
+
+=pod
+
+These are like the 010_complex_merge_classless test,
+but an infinite loop has been made in the heirarchy,
+to test that we can fail cleanly instead of going
+into an infinite loop
+
+=cut
+
+# initial setup, everything sane
+{
+ package ƙ;
+ our @ISA = qw/ᶨ ィ/;
+ package ᶨ;
+ our @ISA = qw/ｆ/;
+ package ィ;
+ our @ISA = qw/ʰ ｆ/;
+ package ʰ;
+ our @ISA = qw/ᶢ/;
+ package ᶢ;
+ our @ISA = qw/ᛞ/;
+ package ｆ;
+ our @ISA = qw/ǝ/;
+ package ǝ;
+ our @ISA = qw/ᛞ/;
+ package ᛞ;
+ our @ISA = qw/Ạ Ｂ ʗ/;
+ package ʗ;
+ our @ISA = qw//;
+ package Ｂ;
+ our @ISA = qw//;
+ package Ạ;
+ our @ISA = qw//;
+}
+
+# A series of 8 aberations that would cause infinite loops,
+# each one undoing the work of the previous
+my @loopies = (
+ sub { @ǝ::ISA = qw/ｆ/ },
+ sub { @ǝ::ISA = qw/ᛞ/; @ʗ::ISA = qw/ｆ/ },
+ sub { @ʗ::ISA = qw//; @Ạ::ISA = qw/ƙ/ },
+ sub { @Ạ::ISA = qw//; @ᶨ::ISA = qw/ｆ ƙ/ },
+ sub { @ᶨ::ISA = qw/ｆ/; @ʰ::ISA = qw/ƙ ᶢ/ },
+ sub { @ʰ::ISA = qw/ᶢ/; @Ｂ::ISA = qw/Ｂ/ },
+ sub { @Ｂ::ISA = qw//; @ƙ::ISA = qw/ƙ ᶨ ィ/ },
+ sub { @ƙ::ISA = qw/ᶨ ィ/; @ᛞ::ISA = qw/Ạ ʰ Ｂ ʗ/ },
+);
+
+foreach my $loopy (@loopies) {
+ eval {
+ local $SIG{ALRM} = sub { die "ALRMTimeout" };
+ alarm(3);
+ $loopy->();
+ mro::get_linear_isa('ƙ', 'dfs');
+ };
+
+ if(my $err = $@) {
+ if($err =~ /ALRMTimeout/) {
+ ok(0, "Loop terminated by SIGALRM");
+ }
+ elsif($err =~ /Recursive inheritance detected/) {
+ ok(1, "Graceful exception thrown");
+ }
+ else {
+ ok(0, "Unrecognized exception: $err");
+ }
+ }
+ else {
+ ok(0, "Infinite loop apparently succeeded???");
+ }
+}
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+require q(./test.pl); plan(tests => 1);
+
+=pod
+
+example taken from: L<http://www.opendylan.org/books/drm/Method_Dispatch>
+
+ 옵젳Ṯ
+ ^
+ |
+ ᓕᵮꡠＦᚖᶭ
+ ^ ^
+ / \
+ SㄣチenŦ 빞엗ᱞ
+ ^ ^
+ | |
+ ᕟ텔li겐ț Hʉ만ӫ읻
+ ^ ^
+ \ /
+ ቩᓪ찬
+
+ define class <SㄣチenŦ> (<ᓕᵮꡠＦᚖᶭ>) end class;
+ define class <빞엗ᱞ> (<ᓕᵮꡠＦᚖᶭ>) end class;
+ define class <ᕟ텔li겐ț> (<SㄣチenŦ>) end class;
+ define class <Hʉ만ӫ읻> (<빞엗ᱞ>) end class;
+ define class <ቩᓪ찬> (<ᕟ텔li겐ț>, <Hʉ만ӫ읻>) end class;
+
+=cut
+
+{
+ package 옵젳Ṯ;
+ use mro 'c3';
+
+ package ᓕᵮꡠＦᚖᶭ;
+ use mro 'c3';
+ use base '옵젳Ṯ';
+
+ package SㄣチenŦ;
+ use mro 'c3';
+ use base 'ᓕᵮꡠＦᚖᶭ';
+
+ package 빞엗ᱞ;
+ use mro 'c3';
+ use base 'ᓕᵮꡠＦᚖᶭ';
+
+ package ᕟ텔li겐ț;
+ use mro 'c3';
+ use base 'SㄣチenŦ';
+
+ package Hʉ만ӫ읻;
+ use mro 'c3';
+ use base '빞엗ᱞ';
+
+ package ቩᓪ찬;
+ use mro 'c3';
+ use base ('ᕟ텔li겐ț', 'Hʉ만ӫ읻');
+}
+
+ok(eq_array(
+ mro::get_linear_isa('ቩᓪ찬'),
+ [ qw(ቩᓪ찬 ᕟ텔li겐ț SㄣチenŦ Hʉ만ӫ읻 빞엗ᱞ ᓕᵮꡠＦᚖᶭ 옵젳Ṯ) ]
+), '... got the right MRO for the ቩᓪ찬 Dylan Example');
--- /dev/null
+#!./perl
+
+use strict;
+use warnings;
+use utf8;
+use open qw( :utf8 :std );
+require q(./test.pl); plan(tests => 1);
+
+
+=pod
+
+example taken from: L<http://www.opendylan.org/books/drm/Method_Dispatch>
+
+ 옵젳Ṯ
+ ^
+ |
+ ᓕᵮꡠＦᚖᶭ
+ ^ ^
+ / \
+ SㄣチenŦ 빞엗ᱞ
+ ^ ^
+ | |
+ ᕟ텔li겐ț Hʉ만ӫ읻
+ ^ ^
+ \ /
+ ቩᓪ찬
+
+ define class <SㄣチenŦ> (<life-form>) end class;
+ define class <빞엗ᱞ> (<life-form>) end class;
+ define class <ᕟ텔li겐ț> (<SㄣチenŦ>) end class;
+ define class <Hʉ만ӫ읻> (<빞엗ᱞ>) end class;
+ define class <ቩᓪ찬> (<ᕟ텔li겐ț>, <Hʉ만ӫ읻>) end class;
+
+=cut
+
+{
+ package 옵젳Ṯ;
+ use mro 'dfs';
+
+ package ᓕᵮꡠＦᚖᶭ;
+ use mro 'dfs';
+ use base '옵젳Ṯ';
+
+ package SㄣチenŦ;
+ use mro 'dfs';
+ use base 'ᓕᵮꡠＦᚖᶭ';
+
+ package 빞엗ᱞ;
+ use mro 'dfs';
+ use base 'ᓕᵮꡠＦᚖᶭ';
+
+ package ᕟ텔li겐ț;
+ use mro 'dfs';
+ use base 'SㄣチenŦ';
+
+ package Hʉ만ӫ읻;
+ use mro 'dfs';
+ use base '빞엗ᱞ';
+
+ package ቩᓪ찬;
+ use mro 'dfs';
+ use base ('ᕟ텔li겐ț', 'Hʉ만ӫ읻');
+}
+
+ok(eq_array(
+ mro::get_linear_isa('ቩᓪ찬'),
+ [ qw(ቩᓪ찬 ᕟ텔li겐ț SㄣチenŦ ᓕᵮꡠＦᚖᶭ 옵젳Ṯ Hʉ만ӫ읻 빞엗ᱞ) ]
+), '... got the right MRO for the ቩᓪ찬 Dylan Example');
}
else if (ck_uni)
check_uni();
- if (s < send)
- *d = *s++;
- d[1] = '\0';
+ if (s < send) {
+ if (UTF) {
+ const STRLEN skip = UTF8SKIP(s);
+ STRLEN i;
+ d[skip] = '\0';
+ for ( i = 0; i < skip; i++ )
+ d[i] = *s++;
+ }
+ else {
+ *d = *s++;
+ d[1] = '\0';
+ }
+ }
if (*d == '^' && *s && isCONTROLVAR(*s)) {
*d = toCTRL(*s);
s++;
}
}
if (isIDFIRST_lazy_if(d,UTF)) {
- d++;
+ d += UTF8SKIP(d);
if (UTF) {
char *end = s;
while ((end < send && isALNUM_lazy_if(end,UTF)) || *end == ':') {
https://perl5.git.perl.org / perl5.git / commitdiff