[perl #88132] broken ISA lookup after aliasing packages ending with ::

gv_fetchpvn_flags did not always assign a name to a return HV ending
with ::. This would result in code in various places skipping certain
‘stashes’ (in quotes because nameless HVs are technically not stashes)
because they were nameless when they should not have been.

So sometimes ISA caches would end up being out of date, as in the test
cases posted with [perl #88132] (and incorporated into this patch).

This commit fixes that by changing the parsing of glob names.

Formerly, a :: was not considered a package separator if it came imme-
diately after a ::. So foo:::: would become foo::/:: (with the final
:: considered a regular stash entry, not a ‘stash’ stash entry) and
foo:::::: would become foo::/:::/:.

Now a :: is always a package separator. So *foo::::bar is accessible
via $foo::{"::"}{bar} and *$foo:::::: via $foo::{"::"}{"::"}.

This happens to fix [perl #88134] as well.

diff --git a/gv.c b/gv.c
index 2abe418..7741af3 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -1066,7 +1066,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
                return NULL;
 
            len = name_cursor - name;
-           if (len > 0) {
+           if (name_cursor > nambeg) { /* Skip for initial :: or ' */
                const char *key;
                if (*name_cursor == ':') {
                    key = name;
@@ -1109,8 +1109,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags,
 
            if (*name_cursor == ':')
                name_cursor++;
-           name_cursor++;
-           name = name_cursor;
+           name = name_cursor+1;
            if (name == name_end)
                return gv
                    ? gv : MUTABLE_GV(*hv_fetchs(PL_defstash, "main::", TRUE));

diff --git a/t/mro/package_aliases.t b/t/mro/package_aliases.t
index bf90429..3fa3d6c 100644 (file)
--- a/t/mro/package_aliases.t
+++ b/t/mro/package_aliases.t
@@ -10,7 +10,7 @@ BEGIN {
 
 use strict;
 use warnings;
-plan(tests => 27);
+plan(tests => 39);
 
 {
     package New;
@@ -154,37 +154,47 @@ for(
    code => '*clone:: = \%outer::',
  },
 ) {
- fresh_perl_is
-   q~
-     @left::ISA = 'outer::inner';
-     @right::ISA = 'clone::inner';
-     {package outer::inner}
-
-    __code__;
-
-     print "ok 1", "\n" if left->isa("clone::inner");
-     print "ok 2", "\n" if right->isa("outer::inner");
-   ~ =~ s\__code__\$$_{code}\r,
-  "ok 1\nok 2\n",
-   {},
-  "replacing nonexistent nested packages by $$_{name} updates isa caches";
-
- # Same test but with the subpackage autovivified after the assignment
- fresh_perl_is
-   q~
-     @left::ISA = 'outer::inner';
-     @right::ISA = 'clone::inner';
-
-    __code__;
-
-     eval q{package outer::inner};
-
-     print "ok 1", "\n" if left->isa("clone::inner");
-     print "ok 2", "\n" if right->isa("outer::inner");
-   ~ =~ s\__code__\$$_{code}\r,
-  "ok 1\nok 2\n",
-   {},
-  "Giving nonexistent packages multiple effective names by $$_{name}";
+ for my $tail ('inner', 'inner::', 'inner::::') {
+  fresh_perl_is
+    q~
+      my $tail = shift;
+      @left::ISA = "outer::$tail";
+      @right::ISA = "clone::$tail";
+      eval "package outer::$tail";
+
+     __code__;
+
+      print "ok 1", "\n" if left->isa("clone::$tail");
+      print "ok 2", "\n" if right->isa("outer::$tail");
+      print "ok 3", "\n" if right->isa("clone::$tail");
+      print "ok 4", "\n" if left->isa("outer::$tail");
+    ~ =~ s\__code__\$$_{code}\r,
+   "ok 1\nok 2\nok 3\nok 4\n",
+    { args => [$tail] },
+   "replacing nonexistent nested packages by $$_{name} updates isa caches"
+     ." ($tail)";
+
+  # Same test but with the subpackage autovivified after the assignment
+  fresh_perl_is
+    q~
+      my $tail = shift;
+      @left::ISA = "outer::$tail";
+      @right::ISA = "clone::$tail";
+
+     __code__;
+
+      eval qq{package outer::$tail};
+
+      print "ok 1", "\n" if left->isa("clone::$tail");
+      print "ok 2", "\n" if right->isa("outer::$tail");
+      print "ok 3", "\n" if right->isa("clone::$tail");
+      print "ok 4", "\n" if left->isa("outer::$tail");
+    ~ =~ s\__code__\$$_{code}\r,
+   "ok 1\nok 2\nok 3\nok 4\n",
+    { args => [$tail] },
+   "Giving nonexistent packages multiple effective names by $$_{name}"
+     . " ($tail)";
+ }
 }
 
 no warnings; # temporary; there seems to be a scoping bug, as this does not

diff --git a/t/op/stash.t b/t/op/stash.t
index 9a84b5a..1bd6c70 100644 (file)
--- a/t/op/stash.t
+++ b/t/op/stash.t
@@ -7,7 +7,7 @@ BEGIN {
 
 BEGIN { require "./test.pl"; }
 
-plan( tests => 53 );
+plan( tests => 54 );
 
 # Used to segfault (bug #15479)
 fresh_perl_like(
@@ -304,3 +304,11 @@ fresh_perl_is(
       "setting stash name during undef has no effect";
 }
 
+# [perl #88134] incorrect package structure
+{
+    package Bear::;
+    sub baz{1}
+    package main;
+    ok eval { Bear::::baz() },
+     'packages ending with :: are self-consistent';
+}