t/mro/package_aliases.t

   1 #!./perl
   2
   3 BEGIN {
   4     unless (-d 'blib') {
   5         chdir 't' if -d 't';
   6         @INC = '../lib';
   7     }
   8     require q(./test.pl);
   9 }
  10
  11 use strict;
  12 use warnings;
  13 plan(tests => 52);
  14
  15 {
  16     package New;
  17     use strict;
  18     use warnings;
  19
  20     package Old;
  21     use strict;
  22     use warnings;
  23
  24     {
  25       no strict 'refs';
  26       *{'Old::'} = *{'New::'};
  27     }
  28 }
  29
  30 ok (Old->isa (New::), 'Old inherits from New');
  31 ok (New->isa (Old::), 'New inherits from Old');
  32
  33 object_ok (bless ({}, Old::), New::, 'Old object');
  34 object_ok (bless ({}, New::), Old::, 'New object');
  35
  36
  37 # Test that replacing a package by assigning to an existing glob
  38 # invalidates the isa caches
  39 for(
  40  {
  41    name => 'assigning a glob to a glob',
  42    code => '$life_raft = $::{"Left::"}; *Left:: = $::{"Right::"}',
  43  },
  44  {
  45    name => 'assigning a string to a glob',
  46    code => '$life_raft = $::{"Left::"}; *Left:: = "Right::"',
  47  },
  48  {
  49    name => 'assigning a stashref to a glob',
  50    code => '$life_raft = \%Left::; *Left:: = \%Right::',
  51  },
  52 ) {
  53  fresh_perl_is
  54    q~
  55      @Subclass::ISA = "Left";
  56      @Left::ISA = "TopLeft";
  57
  58      sub TopLeft::speak { "Woof!" }
  59      sub TopRight::speak { "Bow-wow!" }
  60
  61      my $thing = bless [], "Subclass";
  62
  63      # mro_package_moved needs to know to skip non-globs
  64      $Right::{"gleck::"} = 3;
  65
  66      @Right::ISA = 'TopRight';
  67      my $life_raft;
  68     __code__;
  69
  70      print $thing->speak, "\n";
  71
  72      undef $life_raft;
  73      print $thing->speak, "\n";
  74    ~ =~ s\__code__\$$_{code}\r,
  75   "Bow-wow!\nBow-wow!\n",
  76    {},
  77   "replacing packages by $$_{name} updates isa caches";
  78 }
  79
  80 # Similar test, but with nested packages
  81 #
  82 #  TopLeft (Woof)    TopRight (Bow-wow)
  83 #      |                 |
  84 #  Left::Side   <-   Right::Side
  85 #      |
  86 #   Subclass
  87 #
  88 # This test assigns Right:: to Left::, indirectly making Left::Side an
  89 # alias to Right::Side (following the arrow in the diagram).
  90 for(
  91  {
  92    name => 'assigning a glob to a glob',
  93    code => '$life_raft = $::{"Left::"}; *Left:: = $::{"Right::"}',
  94  },
  95  {
  96    name => 'assigning a string to a glob',
  97    code => '$life_raft = $::{"Left::"}; *Left:: = "Right::"',
  98  },
  99  {
 100    name => 'assigning a stashref to a glob',
 101    code => '$life_raft = \%Left::; *Left:: = \%Right::',
 102  },
 103 ) {
 104  fresh_perl_is
 105    q~
 106      @Subclass::ISA = "Left::Side";
 107      @Left::Side::ISA = "TopLeft";
 108
 109      sub TopLeft::speak { "Woof!" }
 110      sub TopRight::speak { "Bow-wow!" }
 111
 112      my $thing = bless [], "Subclass";
 113
 114      @Right::Side::ISA = 'TopRight';
 115      my $life_raft;
 116     __code__;
 117
 118      print $thing->speak, "\n";
 119
 120      undef $life_raft;
 121      print $thing->speak, "\n";
 122    ~ =~ s\__code__\$$_{code}\r,
 123   "Bow-wow!\nBow-wow!\n",
 124    {},
 125   "replacing nested packages by $$_{name} updates isa caches";
 126 }
 127
 128 # Another nested package test, in which the isa cache needs to be reset on
 129 # the subclass of a package that does not exist.
 130 #
 131 # Parenthesized packages do not exist.
 132 #
 133 #  outer::inner    ( clone::inner )
 134 #       |                 |
 135 #     left              right
 136 #
 137 #        outer  ->  clone
 138 #
 139 # This test assigns outer:: to clone::, making clone::inner an alias to
 140 # outer::inner.
 141 #
 142 # Then we also run the test again, but without outer::inner
 143 for(
 144  {
 145    name => 'assigning a glob to a glob',
 146    code => '*clone:: = *outer::',
 147  },
 148  {
 149    name => 'assigning a string to a glob',
 150    code => '*clone:: = "outer::"',
 151  },
 152  {
 153    name => 'assigning a stashref to a glob',
 154    code => '*clone:: = \%outer::',
 155  },
 156 ) {
 157  for my $tail ('inner', 'inner::', 'inner:::', 'inner::::') {
 158   fresh_perl_is
 159     q~
 160       my $tail = shift;
 161       @left::ISA = "outer::$tail";
 162       @right::ISA = "clone::$tail";
 163       bless [], "outer::$tail"; # autovivify the stash
 164
 165      __code__;
 166
 167       print "ok 1", "\n" if left->isa("clone::$tail");
 168       print "ok 2", "\n" if right->isa("outer::$tail");
 169       print "ok 3", "\n" if right->isa("clone::$tail");
 170       print "ok 4", "\n" if left->isa("outer::$tail");
 171     ~ =~ s\__code__\$$_{code}\r,
 172    "ok 1\nok 2\nok 3\nok 4\n",
 173     { args => [$tail] },
 174    "replacing nonexistent nested packages by $$_{name} updates isa caches"
 175      ." ($tail)";
 176
 177   # Same test but with the subpackage autovivified after the assignment
 178   fresh_perl_is
 179     q~
 180       my $tail = shift;
 181       @left::ISA = "outer::$tail";
 182       @right::ISA = "clone::$tail";
 183
 184      __code__;
 185
 186       bless [], "outer::$tail";
 187
 188       print "ok 1", "\n" if left->isa("clone::$tail");
 189       print "ok 2", "\n" if right->isa("outer::$tail");
 190       print "ok 3", "\n" if right->isa("clone::$tail");
 191       print "ok 4", "\n" if left->isa("outer::$tail");
 192     ~ =~ s\__code__\$$_{code}\r,
 193    "ok 1\nok 2\nok 3\nok 4\n",
 194     { args => [$tail] },
 195    "Giving nonexistent packages multiple effective names by $$_{name}"
 196      . " ($tail)";
 197  }
 198 }
 199
 200 no warnings; # temporary; there seems to be a scoping bug, as this does not
 201              # work when placed in the blocks below
 202
 203 # Test that deleting stash elements containing
 204 # subpackages also invalidates the isa cache.
 205 # Maybe this does not belong in package_aliases.t, but it is closely
 206 # related to the tests immediately preceding.
 207 {
 208  @Pet::ISA = ("Cur", "Hound");
 209  @Cur::ISA = "Hylactete";
 210
 211  sub Hylactete::speak { "Arff!" }
 212  sub Hound::speak { "Woof!" }
 213
 214  my $pet = bless [], "Pet";
 215
 216  my $life_raft = delete $::{'Cur::'};
 217
 218  is $pet->speak, 'Woof!',
 219   'deleting a stash from its parent stash invalidates the isa caches';
 220
 221  undef $life_raft;
 222  is $pet->speak, 'Woof!',
 223   'the deleted stash is gone completely when freed';
 224 }
 225 # Same thing, but with nested packages
 226 {
 227  @Pett::ISA = ("Curr::Curr::Curr", "Hownd");
 228  @Curr::Curr::Curr::ISA = "Latrator";
 229
 230  sub Latrator::speak { "Arff!" }
 231  sub Hownd::speak { "Woof!" }
 232
 233  my $pet = bless [], "Pett";
 234
 235  my $life_raft = delete $::{'Curr::'};
 236
 237  is $pet->speak, 'Woof!',
 238   'deleting a stash from its parent stash resets caches of substashes';
 239
 240  undef $life_raft;
 241  is $pet->speak, 'Woof!',
 242   'the deleted substash is gone completely when freed';
 243 }
 244
 245 # [perl #77358]
 246 fresh_perl_is
 247    q~#!perl -w
 248      @Pet::ISA = "Tike";
 249      @Tike::ISA = "Barker";
 250
 251      sub Barker::speak { print "Woof!\n" }
 252      sub Latrator::speak { print "Bow-wow!\n" }
 253
 254      my $pet = bless [], "Pet";
 255
 256      $pet->speak;
 257
 258      sub Dog::speak { print "Hello.\n" } # strange dog!
 259      @Dog::ISA = 'Latrator';
 260      *Tike:: = delete $::{'Dog::'};
 261
 262      $pet->speak;
 263    ~,
 264   "Woof!\nHello.\n",
 265    { stderr => 1 },
 266   "Assigning a nameless package over one w/subclasses updates isa caches";
 267
 268 # mro_package_moved needs to make a distinction between replaced and
 269 # assigned stashes when keeping track of what it has seen so far.
 270 no warnings; {
 271     no strict 'refs';
 272
 273     sub bar::blonk::blonk::phoo { "bbb" }
 274     sub veclum::phoo { "lasrevinu" }
 275     @feedlebomp::ISA = qw 'phoo::blonk::blonk veclum';
 276     *phoo::baz:: = *bar::blonk::;   # now bar::blonk:: is on both sides
 277     *phoo:: = *bar::;         # here bar::blonk:: is both deleted and added
 278     *bar:: = *boo::;          # now it is only known as phoo::blonk::
 279
 280     # At this point, before the bug was fixed, %phoo::blonk::blonk:: ended
 281     # up with no effective name, allowing it to be deleted without updating
 282     # its subclasses’ caches.
 283
 284     my $accum = '';
 285
 286     $accum .= 'feedlebomp'->phoo;          # bbb
 287     delete ${"phoo::blonk::"}{"blonk::"};
 288     $accum .= 'feedlebomp'->phoo;          # bbb (Oops!)
 289     @feedlebomp::ISA = @feedlebomp::ISA;
 290     $accum .= 'feedlebomp'->phoo;          # lasrevinu
 291
 292     is $accum, 'bbblasrevinulasrevinu',
 293       'nested classes deleted & added simultaneously';
 294 }
 295 use warnings;
 296
 297 # mro_package_moved needs to check for self-referential packages.
 298 # This broke Text::Template [perl #78362].
 299 watchdog 3;
 300 *foo:: = \%::;
 301 *Acme::META::Acme:: = \*Acme::; # indirect self-reference
 302 pass("mro_package_moved and self-referential packages");
 303
 304 # Deleting a glob whose name does not indicate its location in the symbol
 305 # table but which nonetheless *is* in the symbol table.
 306 {
 307     no strict refs=>;
 308     no warnings;
 309     @one::more::ISA = "four";
 310     sub four::womp { "aoeaa" }
 311     *two:: = *one::;
 312     delete $::{"one::"};
 313     @Childclass::ISA = 'two::more';
 314     my $accum = 'Childclass'->womp . '-';
 315     my $life_raft = delete ${"two::"}{"more::"};
 316     $accum .= eval { 'Childclass'->womp } // '<undef>';
 317     is $accum, 'aoeaa-<undef>',
 318      'Deleting globs whose loc in the symtab differs from gv_fullname'
 319 }
 320
 321 # Pathological test for undeffing a stash that has an alias.
 322 *Ghelp:: = *Neen::;
 323 @Subclass::ISA = 'Ghelp';
 324 undef %Ghelp::;
 325 sub Frelp::womp { "clumpren" }
 326 eval '
 327   $Neen::whatever++;
 328   @Neen::ISA = "Frelp";
 329 ';
 330 is eval { 'Subclass'->womp }, 'clumpren',
 331  'Changes to @ISA after undef via original name';
 332 undef %Ghelp::;
 333 eval '
 334   $Ghelp::whatever++;
 335   @Ghelp::ISA = "Frelp";
 336 ';
 337 is eval { 'Subclass'->womp }, 'clumpren',
 338  'Changes to @ISA after undef via alias';
 339
 340
 341 # Packages whose containing stashes have aliases must lose all names cor-
 342 # responding to that container when detached.
 343 {
 344  {package smare::baz} # autovivify
 345  *phring:: = *smare::;  # smare::baz now also named phring::baz
 346  *bonk:: = delete $smare::{"baz::"};
 347  # In 5.13.7, it has now lost its smare::baz name (reverting to phring::baz
 348  # as the effective name), and gained bonk as an alias.
 349  # In 5.13.8, both smare::baz *and* phring::baz names are deleted.
 350
 351  # Make some methods
 352  no strict 'refs';
 353  *{"phring::baz::frump"} = sub { "hello" };
 354  sub frumper::frump { "good bye" };
 355
 356  @brumkin::ISA = qw "bonk frumper"; # now wrongly inherits from phring::baz
 357
 358  is frump brumkin, "good bye",
 359   'detached stashes lose all names corresponding to the containing stash';
 360 }
 361
 362 # Crazy edge cases involving packages ending with a single :
 363 @Colon::ISA = 'Organ:'; # pun intended!
 364 bless [], "Organ:"; # autovivify the stash
 365 ok "Colon"->isa("Organ:"), 'class isa "class:"';
 366 { no strict 'refs'; *{"Organ:::"} = *Organ:: }
 367 ok "Colon"->isa("Organ"),
 368  'isa(foo) when inheriting from "class:" which is an alias for foo';
 369 {
 370  no warnings;
 371  # The next line of code is *not* normative. If the structure changes,
 372  # this line needs to change, too.
 373  my $foo = delete $Organ::{":"};
 374  ok !Colon->isa("Organ"),
 375   'class that isa "class:" no longer isa foo if "class:" has been deleted';
 376 }
 377 @Colon::ISA = ':';
 378 bless [], ":";
 379 ok "Colon"->isa(":"), 'class isa ":"';
 380 { no strict 'refs'; *{":::"} = *Punctuation:: }
 381 ok "Colon"->isa("Punctuation"),
 382  'isa(foo) when inheriting from ":" which is an alias for foo';
 383 @Colon::ISA = 'Organ:';
 384 bless [], "Organ:";
 385 {
 386  no strict 'refs';
 387  my $life_raft = \%{"Organ:::"};
 388  *{"Organ:::"} = \%Organ::;
 389  ok "Colon"->isa("Organ"),
 390   'isa(foo) when inheriting from "class:" after hash-to-glob assignment';
 391 }
 392 @Colon::ISA = 'O:';
 393 bless [], "O:";
 394 {
 395  no strict 'refs';
 396  my $life_raft = \%{"O:::"};
 397  *{"O:::"} = "Organ::";
 398  ok "Colon"->isa("Organ"),
 399   'isa(foo) when inheriting from "class:" after string-to-glob assignment';
 400 }
 401
 402