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 => 27);
  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 isa_ok (bless ({}, Old::), New::, 'Old object');
  34 isa_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  fresh_perl_is
 158    q~
 159      @left::ISA = 'outer::inner';
 160      @right::ISA = 'clone::inner';
 161      {package outer::inner}
 162
 163     __code__;
 164
 165      print "ok 1", "\n" if left->isa("clone::inner");
 166      print "ok 2", "\n" if right->isa("outer::inner");
 167    ~ =~ s\__code__\$$_{code}\r,
 168   "ok 1\nok 2\n",
 169    {},
 170   "replacing nonexistent nested packages by $$_{name} updates isa caches";
 171
 172  # Same test but with the subpackage autovivified after the assignment
 173  fresh_perl_is
 174    q~
 175      @left::ISA = 'outer::inner';
 176      @right::ISA = 'clone::inner';
 177
 178     __code__;
 179
 180      eval q{package outer::inner};
 181
 182      print "ok 1", "\n" if left->isa("clone::inner");
 183      print "ok 2", "\n" if right->isa("outer::inner");
 184    ~ =~ s\__code__\$$_{code}\r,
 185   "ok 1\nok 2\n",
 186    {},
 187   "Giving nonexistent packages multiple effective names by $$_{name}";
 188 }
 189
 190 no warnings; # temporary; there seems to be a scoping bug, as this does not
 191              # work when placed in the blocks below
 192
 193 # Test that deleting stash elements containing
 194 # subpackages also invalidates the isa cache.
 195 # Maybe this does not belong in package_aliases.t, but it is closely
 196 # related to the tests immediately preceding.
 197 {
 198  @Pet::ISA = ("Cur", "Hound");
 199  @Cur::ISA = "Hylactete";
 200
 201  sub Hylactete::speak { "Arff!" }
 202  sub Hound::speak { "Woof!" }
 203
 204  my $pet = bless [], "Pet";
 205
 206  my $life_raft = delete $::{'Cur::'};
 207
 208  is $pet->speak, 'Woof!',
 209   'deleting a stash from its parent stash invalidates the isa caches';
 210
 211  undef $life_raft;
 212  is $pet->speak, 'Woof!',
 213   'the deleted stash is gone completely when freed';
 214 }
 215 # Same thing, but with nested packages
 216 {
 217  @Pett::ISA = ("Curr::Curr::Curr", "Hownd");
 218  @Curr::Curr::Curr::ISA = "Latrator";
 219
 220  sub Latrator::speak { "Arff!" }
 221  sub Hownd::speak { "Woof!" }
 222
 223  my $pet = bless [], "Pett";
 224
 225  my $life_raft = delete $::{'Curr::'};
 226
 227  is $pet->speak, 'Woof!',
 228   'deleting a stash from its parent stash resets caches of substashes';
 229
 230  undef $life_raft;
 231  is $pet->speak, 'Woof!',
 232   'the deleted substash is gone completely when freed';
 233 }
 234
 235 # [perl #77358]
 236 fresh_perl_is
 237    q~#!perl -w
 238      @Pet::ISA = "Tike";
 239      @Tike::ISA = "Barker";
 240
 241      sub Barker::speak { print "Woof!\n" }
 242      sub Latrator::speak { print "Bow-wow!\n" }
 243
 244      my $pet = bless [], "Pet";
 245
 246      $pet->speak;
 247
 248      sub Dog::speak { print "Hello.\n" } # strange dog!
 249      @Dog::ISA = 'Latrator';
 250      *Tike:: = delete $::{'Dog::'};
 251
 252      $pet->speak;
 253    ~,
 254   "Woof!\nHello.\n",
 255    { stderr => 1 },
 256   "Assigning a nameless package over one w/subclasses updates isa caches";
 257
 258 # mro_package_moved needs to make a distinction between replaced and
 259 # assigned stashes when keeping track of what it has seen so far.
 260 no warnings; {
 261     no strict 'refs';
 262
 263     sub bar::blonk::blonk::phoo { "bbb" }
 264     sub veclum::phoo { "lasrevinu" }
 265     @feedlebomp::ISA = qw 'phoo::blonk::blonk veclum';
 266     *phoo::baz:: = *bar::blonk::;   # now bar::blonk:: is on both sides
 267     *phoo:: = *bar::;         # here bar::blonk:: is both deleted and added
 268     *bar:: = *boo::;          # now it is only known as phoo::blonk::
 269
 270     # At this point, before the bug was fixed, %phoo::blonk::blonk:: ended
 271     # up with no effective name, allowing it to be deleted without updating
 272     # its subclasses’ caches.
 273
 274     my $accum = '';
 275
 276     $accum .= 'feedlebomp'->phoo;          # bbb
 277     delete ${"phoo::blonk::"}{"blonk::"};
 278     $accum .= 'feedlebomp'->phoo;          # bbb (Oops!)
 279     @feedlebomp::ISA = @feedlebomp::ISA;
 280     $accum .= 'feedlebomp'->phoo;          # lasrevinu
 281
 282     is $accum, 'bbblasrevinulasrevinu',
 283       'nested classes deleted & added simultaneously';
 284 }
 285 use warnings;
 286
 287 # mro_package_moved needs to check for self-referential packages.
 288 # This broke Text::Template [perl #78362].
 289 watchdog 3;
 290 *foo:: = \%::;
 291 *Acme::META::Acme:: = \*Acme::; # indirect self-reference
 292 pass("mro_package_moved and self-referential packages");
 293
 294 # Deleting a glob whose name does not indicate its location in the symbol
 295 # table but which nonetheless *is* in the symbol table.
 296 {
 297     no strict refs=>;
 298     no warnings;
 299     @one::more::ISA = "four";
 300     sub four::womp { "aoeaa" }
 301     *two:: = *one::;
 302     delete $::{"one::"};
 303     @Childclass::ISA = 'two::more';
 304     my $accum = 'Childclass'->womp . '-';
 305     my $life_raft = delete ${"two::"}{"more::"};
 306     $accum .= eval { 'Childclass'->womp } // '<undef>';
 307     is $accum, 'aoeaa-<undef>',
 308      'Deleting globs whose loc in the symtab differs from gv_fullname'
 309 }
 310
 311 # Pathological test for undeffing a stash that has an alias.
 312 *Ghelp:: = *Neen::;
 313 @Subclass::ISA = 'Ghelp';
 314 undef %Ghelp::;
 315 sub Frelp::womp { "clumpren" }
 316 eval '
 317   $Neen::whatever++;
 318   @Neen::ISA = "Frelp";
 319 ';
 320 is eval { 'Subclass'->womp }, 'clumpren',
 321  'Changes to @ISA after undef via original name';
 322 undef %Ghelp::;
 323 eval '
 324   $Ghelp::whatever++;
 325   @Ghelp::ISA = "Frelp";
 326 ';
 327 is eval { 'Subclass'->womp }, 'clumpren',
 328  'Changes to @ISA after undef via alias';
 329
 330
 331 # Packages whose containing stashes have aliases must lose all names cor-
 332 # responding to that container when detached.
 333 {
 334  {package smare::baz} # autovivify
 335  *phring:: = *smare::;  # smare::baz now also named phring::baz
 336  *bonk:: = delete $smare::{"baz::"};
 337  # In 5.13.7, it has now lost its smare::baz name (reverting to phring::baz
 338  # as the effective name), and gained bonk as an alias.
 339  # In 5.13.8, both smare::baz *and* phring::baz names are deleted.
 340
 341  # Make some methods
 342  no strict 'refs';
 343  *{"phring::baz::frump"} = sub { "hello" };
 344  sub frumper::frump { "good bye" };
 345
 346  @brumkin::ISA = qw "bonk frumper"; # now wrongly inherits from phring::baz
 347
 348  is frump brumkin, "good bye",
 349   'detached stashes lose all names corresponding to the containing stash';
 350 }