| 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 | } |