t/mro/basic_utf8.t

   1 #!./perl
   2
   3 use utf8;
   4 use open qw( :utf8 :std );
   5 use strict;
   6 use warnings;
   7
   8 BEGIN { require q(./test.pl); } plan(tests => 53);
   9
  10 require 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
  27 my @MFO_ᚠ_DFS = qw/MRO_ᚠ MRO_ｄ MRO_அ MRO_ɓ MRO_ᶝ MRO_ɛ/;
  28 my @MFO_ᚠ_C3 = qw/MRO_ᚠ MRO_ｄ MRO_ɛ MRO_அ MRO_ɓ MRO_ᶝ/;
  29 is(mro::get_mro('MRO_ᚠ'), 'dfs');
  30 ok(eq_array(
  31     mro::get_linear_isa('MRO_ᚠ'), \@MFO_ᚠ_DFS
  32 ));
  33
  34 ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'dfs'), \@MFO_ᚠ_DFS));
  35 ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'c3'), \@MFO_ᚠ_C3));
  36 eval{mro::get_linear_isa('MRO_ᚠ', 'C3')};
  37 like($@, qr/^Invalid mro name: 'C3'/);
  38
  39 mro::set_mro('MRO_ᚠ', 'c3');
  40 is(mro::get_mro('MRO_ᚠ'), 'c3');
  41 ok(eq_array(
  42     mro::get_linear_isa('MRO_ᚠ'), \@MFO_ᚠ_C3
  43 ));
  44
  45 ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'dfs'), \@MFO_ᚠ_DFS));
  46 ok(eq_array(mro::get_linear_isa('MRO_ᚠ', 'c3'), \@MFO_ᚠ_C3));
  47 eval{mro::get_linear_isa('MRO_ᚠ', 'C3')};
  48 like($@, qr/^Invalid mro name: 'C3'/);
  49
  50 ok(!mro::is_universal('MRO_ɓ'));
  51
  52 @UNIVERSAL::ISA = qw/MRO_ᚠ/;
  53 ok(mro::is_universal('MRO_ɓ'));
  54
  55 @UNIVERSAL::ISA = ();
  56 ok(!mro::is_universal('MRO_ᚠ'));
  57 ok(!mro::is_universal('MRO_ɓ'));
  58
  59 # is_universal, get_mro, and get_linear_isa should
  60 # handle non-existent packages sanely
  61 ok(!mro::is_universal('Does_Not_Exist'));
  62 is(mro::get_mro('Also_Does_Not_Exist'), 'dfs');
  63 ok(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_Teﬆ옽ḦРꤷsӭ;
  73     sub 텟ₜꖢᶯcƧ { return 321 }
  74     package MRO_Ɯ; our @ISA = qw/MRO_ҭṣṱबꗻ/;
  75 }
  76 *MRO_ᕡ::ISA = *MRO_Ɯ::ISA;
  77 is(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 }