1#!./perl 2 3use utf8; 4use open qw( :utf8 :std ); 5use strict; 6use warnings; 7 8BEGIN { require q(./test.pl); } plan(tests => 53); 9 10require mro; 11 12{ 13 package MRO_அ; 14 our @ISA = qw//; 15 package MRO_ɓ; 16 our @ISA = qw//; 17 package MRO_ᶝ; 18 our @ISA = qw//; 19 package MRO_ｄ; 20 our @ISA = qw/MRO_அ MRO_ɓ MRO_ᶝ/; 21 package MRO_ɛ; 22 our @ISA = qw/MRO_அ MRO_ɓ MRO_ᶝ/; 23 package MRO_ᚠ; 24 our @ISA = qw/MRO_ｄ MRO_ɛ/; 25} 26 27my @MFO_ᚠ_DFS = qw/MRO_ᚠ MRO_ｄ MRO_அ MRO_ɓ MRO_ᶝ MRO_ɛ/; 28my @MFO_ᚠ_C3 = qw/MRO_ᚠ MRO_ｄ MRO_ɛ MRO_அ MRO_ɓ MRO_ᶝ/; 29is(mro::get_mro('MRO_ᚠ'), 'dfs'); 30ok(eq_array( 31 mro::get_linear_isa('MRO_ᚠ'), \@MFO_ᚠ_DFS 32)); 33 34ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'dfs'), \@MFO_ᚠ_DFS)); 35ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'c3'), \@MFO_ᚠ_C3)); 36eval{mro::get_linear_isa('MRO_ᚠ', 'C3')}; 37like($@, qr/^Invalid mro name: 'C3'/); 38 39mro::set_mro('MRO_ᚠ', 'c3'); 40is(mro::get_mro('MRO_ᚠ'), 'c3'); 41ok(eq_array( 42 mro::get_linear_isa('MRO_ᚠ'), \@MFO_ᚠ_C3 43)); 44 45ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'dfs'), \@MFO_ᚠ_DFS)); 46ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'c3'), \@MFO_ᚠ_C3)); 47eval{mro::get_linear_isa('MRO_ᚠ', 'C3')}; 48like($@, qr/^Invalid mro name: 'C3'/); 49 50ok(!mro::is_universal('MRO_ɓ')); 51 52@UNIVERSAL::ISA = qw/MRO_ᚠ/; 53ok(mro::is_universal('MRO_ɓ')); 54 55@UNIVERSAL::ISA = (); 56ok(!mro::is_universal('MRO_ᚠ')); 57ok(!mro::is_universal('MRO_ɓ')); 58 59# is_universal, get_mro, and get_linear_isa should 60# handle non-existent packages sanely 61ok(!mro::is_universal('Does_Not_Exist')); 62is(mro::get_mro('Also_Does_Not_Exist'), 'dfs'); 63ok(eq_array( 64 mro::get_linear_isa('Does_Not_Exist_Three'), 65 [qw/Does_Not_Exist_Three/] 66)); 67 68# Assigning @ISA via globref 69{ 70 package MRO_ҭṣṱबꗻ; 71 sub 텟tf운ꜿ { return 123 } 72 package MRO_Test옽ḦРꤷsӭ; 73 sub 텟ₜꖢᶯcƧ { return 321 } 74 package MRO_Ɯ; our @ISA = qw/MRO_ҭṣṱबꗻ/; 75} 76*MRO_ᕡ::ISA = *MRO_Ɯ::ISA; 77is(eval { MRO_ᕡ->텟tf운ꜿ() }, 123); 78 79# XXX TODO (when there's a way to backtrack through a glob's aliases) 80# push(@MRO_M::ISA, 'MRO_TestOtherBase'); 81# is(eval { MRO_N->testfunctwo() }, 321); 82 83# Simple DESTROY Baseline 84{ 85 my $x = 0; 86 my $obj; 87 88 { 89 package DESTROY_MRO_Bӓeᓕne; 90 sub new { bless {} => shift } 91 sub DESTROY { $x++ } 92 93 package DESTROY_MRO_Bӓeᓕne_χḻɖ; 94 our @ISA = qw/DESTROY_MRO_Bӓeᓕne/; 95 } 96 97 $obj = DESTROY_MRO_Bӓeᓕne->new(); 98 undef $obj; 99 is($x, 1); 100 101 $obj = DESTROY_MRO_Bӓeᓕne_χḻɖ->new(); 102 undef $obj; 103 is($x, 2); 104} 105 106# Dynamic DESTROY 107{ 108 my $x = 0; 109 my $obj; 110 111 { 112 package DESTROY_MRO_Ｄჷ및; 113 sub new { bless {} => shift } 114 115 package DESTROY_MRO_Ｄჷ및_χḻɖ; 116 our @ISA = qw/DESTROY_MRO_Ｄჷ및/; 117 } 118 119 $obj = DESTROY_MRO_Ｄჷ및->new(); 120 undef $obj; 121 is($x, 0); 122 123 $obj = DESTROY_MRO_Ｄჷ및_χḻɖ->new(); 124 undef $obj; 125 is($x, 0); 126 127 no warnings 'once'; 128 *DESTROY_MRO_Ｄჷ및::DESTROY = sub { $x++ }; 129 130 $obj = DESTROY_MRO_Ｄჷ및->new(); 131 undef $obj; 132 is($x, 1); 133 134 $obj = DESTROY_MRO_Ｄჷ및_χḻɖ->new(); 135 undef $obj; 136 is($x, 2); 137} 138 139# clearing @ISA in different ways 140# some are destructive to the package, hence the new 141# package name each time 142{ 143 no warnings 'uninitialized'; 144 { 145 package ᛁ앛ଌᛠ; 146 our @ISA = qw/ｘｘ ƳƳ ƶƶ/; 147 } 148 # baseline 149 ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ'),[qw/ᛁ앛ଌᛠ ｘｘ ƳƳ ƶƶ/])); 150 151 # this looks dumb, but it preserves existing behavior for compatibility 152 # (undefined @ISA elements treated as "main") 153 $ᛁ앛ଌᛠ::ISA[1] = undef; 154 ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ'),[qw/ᛁ앛ଌᛠ ｘｘ main ƶƶ/])); 155 156 # undef the array itself 157 undef @ᛁ앛ଌᛠ::ISA; 158 ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ'),[qw/ᛁ앛ଌᛠ/])); 159 160 # Now, clear more than one package's @ISA at once 161 { 162 package ᛁ앛ଌᛠ1; 163 our @ISA = qw/ＷẆ ｘｘ/; 164 165 package ᛁ앛ଌᛠ2; 166 our @ISA = qw/ƳƳ ƶƶ/; 167 } 168 # baseline 169 ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ1'),[qw/ᛁ앛ଌᛠ1 ＷẆ ｘｘ/])); 170 ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ2'),[qw/ᛁ앛ଌᛠ2 ƳƳ ƶƶ/])); 171 (@ᛁ앛ଌᛠ1::ISA, @ᛁ앛ଌᛠ2::ISA) = (); 172 173 ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ1'),[qw/ᛁ앛ଌᛠ1/])); 174 ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ2'),[qw/ᛁ앛ଌᛠ2/])); 175 176 # [perl #49564] This is a pretty obscure way of clearing @ISA but 177 # it tests a regression that affects XS code calling av_clear too. 178 { 179 package ᛁ앛ଌᛠ3; 180 our @ISA = qw/ＷẆ ｘｘ/; 181 } 182 ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ3'),[qw/ᛁ앛ଌᛠ3 ＷẆ ｘｘ/])); 183 { 184 package ᛁ앛ଌᛠ3; 185 reset 'I'; 186 } 187 ok(eq_array(mro::get_linear_isa('ᛁ앛ଌᛠ3'),[qw/ᛁ앛ଌᛠ3/])); 188} 189 190# Check that recursion bails out "cleanly" in a variety of cases 191# (as opposed to say, bombing the interpreter or something) 192{ 193 my @recurse_codes = ( 194 '@MRO_ഋ1::ISA = "MRO_ഋ2"; @MRO_ഋ2::ISA = "MRO_ഋ1";', 195 '@MRO_ഋ3::ISA = "MRO_ഋ4"; push(@MRO_ഋ4::ISA, "MRO_ഋ3");', 196 '@MRO_ഋ5::ISA = "MRO_ഋ6"; @MRO_ഋ6::ISA = qw/ｘｘ MRO_ഋ5 ƳƳ/;', 197 '@MRO_ഋ7::ISA = "MRO_ഋ8"; push(@MRO_ഋ8::ISA, qw/ｘｘ MRO_ഋ7 ƳƳ/)', 198 ); 199 foreach my $code (@recurse_codes) { 200 eval $code; 201 ok($@ =~ /Recursive inheritance detected/); 202 } 203} 204 205# Check that SUPER caches get invalidated correctly 206{ 207 { 208 package ｽṔઍR텟ʇ; 209 sub new { bless {} => shift } 210 sub ຟઓ { $_[1]+1 } 211 212 package ｽṔઍR텟ʇ::MᶤƉ; 213 our @ISA = 'ｽṔઍR텟ʇ'; 214 215 package ｽṔઍR텟ʇ::킫; 216 our @ISA = 'ｽṔઍR텟ʇ::MᶤƉ'; 217 sub ຟઓ { my $s = shift; $s->SUPER::ຟઓ(@_) } 218 219 package ｽṔઍR텟ʇ::렙ﷰए; 220 sub ຟઓ { $_[1]+3 } 221 } 222 223 my $stk_obj = ｽṔઍR텟ʇ::킫->new(); 224 is($stk_obj->ຟઓ(1), 2); 225 { no warnings 'redefine'; 226 *ｽṔઍR텟ʇ::ຟઓ = sub { $_[1]+2 }; 227 } 228 is($stk_obj->ຟઓ(2), 4); 229 @ｽṔઍR텟ʇ::MᶤƉ::ISA = 'ｽṔઍR텟ʇ::렙ﷰए'; 230 is($stk_obj->ຟઓ(3), 6); 231} 232 233{ 234 { 235 # assigning @ISA via arrayref to globref RT 60220 236 package ᛔ1; 237 sub new { bless {}, shift } 238 239 package ᛔ2; 240 } 241 *{ᛔ2::ISA} = [ 'ᛔ1' ]; 242 my $foo = ᛔ2->new; 243 ok(!eval { $foo->ɓᛅƘ }, "no ɓᛅƘ method"); 244 no warnings 'once'; # otherwise it'll bark about ᛔ1::ɓᛅƘ used only once 245 *{ᛔ1::ɓᛅƘ} = sub { "[ɓᛅƘ]" }; 246 is(scalar eval { $foo->ɓᛅƘ }, "[ɓᛅƘ]", "can ɓᛅƘ now"); 247 is $@, ''; 248} 249 250{ 251 # assigning @ISA via arrayref then modifying it RT 72866 252 { 253 package ㄑ1; 254 sub Ｆஓ { } 255 256 package ㄑ2; 257 sub ƚ { } 258 259 package ㄑ3; 260 } 261 push @ㄑ3::ISA, "ㄑ1"; 262 can_ok("ㄑ3", "Ｆஓ"); 263 *ㄑ3::ISA = []; 264 push @ㄑ3::ISA, "ㄑ1"; 265 can_ok("ㄑ3", "Ｆஓ"); 266 *ㄑ3::ISA = []; 267 push @ㄑ3::ISA, "ㄑ2"; 268 can_ok("ㄑ3", "ƚ"); 269 ok(!ㄑ3->can("Ｆஓ"), "can't call Ｆஓ method any longer"); 270} 271 272{ 273 # test mro::method_changed_in 274 my $count = mro::get_pkg_gen("MRO_அ"); 275 mro::method_changed_in("MRO_அ"); 276 my $count_new = mro::get_pkg_gen("MRO_அ"); 277 278 is($count_new, $count + 1); 279} 280 281{ 282 # test if we can call mro::invalidate_all_method_caches; 283 eval { 284 mro::invalidate_all_method_caches(); 285 }; 286 is($@, ""); 287} 288 289{ 290 # @main::ISA 291 no warnings 'once'; 292 @main::ISA = 'პᛅeȵᛏ'; 293 my $output = ''; 294 *პᛅeȵᛏ::ど = sub { $output .= 'პᛅeȵᛏ' }; 295 *პᛅeȵᛏ2::ど = sub { $output .= 'პᛅeȵᛏ2' }; 296 main->ど; 297 @main::ISA = 'პᛅeȵᛏ2'; 298 main->ど; 299 is $output, 'პᛅeȵᛏპᛅeȵᛏ2', '@main::ISA is magical'; 300} 301 302{ 303 # Undefining *ISA, then modifying @ISA 304 # This broke Class::Trait. See [perl #79024]. 305 {package Class::Trait::Base} 306 no strict 'refs'; 307 undef *{"एxṰர::ʦፖㄡsȨ::ISA"}; 308 'एxṰர::ʦፖㄡsȨ'->isa('Class::Trait::Base'); # cache the mro 309 unshift @{"एxṰர::ʦፖㄡsȨ::ISA"}, 'Class::Trait::Base'; 310 ok 'एxṰர::ʦፖㄡsȨ'->isa('Class::Trait::Base'), 311 'a isa b after undef *a::ISA and @a::ISA modification'; 312} 313 314{ 315 # Deleting $package::{ISA} 316 # Broken in 5.10.0; fixed in 5.13.7 317 @BḼᵑtｈ::ISA = 'Bલdḏ'; 318 delete $BḼᵑtｈ::{ISA}; 319 ok !BḼᵑtｈ->isa("Bલdḏ"), 'delete $package::{ISA}'; 320} 321 322{ 323 # Undefining stashes 324 @ᖫᕃㄒṭ::ISA = "ᖮw잍"; 325 @ᖮw잍::ISA = "ሲঌએ"; 326 undef %ᖮw잍::; 327 ok !ᖫᕃㄒṭ->isa('ሲঌએ'), 'undef %package:: updates subclasses'; 328} 329