make 'require ::Foo::Bar' die

Originally, 'require ::Foo::Bar' would try to load /Foo/Bar.pm.

The previous commit changed it so that  ::Foo::Bar mapped to Foo::Bar,
and so loaded Foo/Bar.pm in the @INC path.

This commit takes the different approach of, instead of mapping, making
any bareword require that starts with '::' into an error instead.

It introduces a new error message:

    $ perl -e'require ::Foo::Bar'
    Bareword in require must not start with a double-colon: "::Foo::Bar"
    $

See the thread at:
    http://www.nntp.perl.org/group/perl.perl5.porters/2012/07/msg189909.html

( I originally used '"::"' rather than 'a double-colon', but that
made the message a bit unpenetrable:

    Bareword in require must not start with "::": "::Foo::Bar"
)

diff --git a/ext/XS-APItest/t/load-module.t b/ext/XS-APItest/t/load-module.t
index 303025f..dfb4f3c 100644 (file)
--- a/ext/XS-APItest/t/load-module.t
+++ b/ext/XS-APItest/t/load-module.t
@@ -23,33 +23,34 @@ is(eval { load_module(PERL_LOADMOD_NOIMPORT, 'less', 0.03); 1}, 1,
    "expect load_module() not to fail");
 
 for (["", qr!\ABareword in require maps to empty filename!],
-     ["::", qr!\ABareword in require maps to empty filename!],
-     ["::::", qr!\ABareword in require maps to disallowed filename "/\.pm"!],
-     ["::/", qr!\ABareword in require maps to disallowed filename "/\.pm"!],
-     ["::/WOOSH", qr!\ABareword in require maps to disallowed filename "/WOOSH\.pm"!],
+     ["::", qr!\ABareword in require must not start with a double-colon: "::"!],
+     ["::::", qr!\ABareword in require must not start with a double-colon: "::::"!],
+     ["::/", qr!\ABareword in require must not start with a double-colon: "::/!],
+     ["/", qr!\ABareword in require maps to disallowed filename "/\.pm"!],
+     ["::/WOOSH", qr!\ABareword in require must not start with a double-colon: "::/WOOSH!],
      [".WOOSH", qr!\ABareword in require maps to disallowed filename "\.WOOSH\.pm"!],
-     ["::.WOOSH", qr!\ABareword in require maps to disallowed filename "\.WOOSH\.pm"!],
+     ["::.WOOSH", qr!\ABareword in require must not start with a double-colon: "::.WOOSH!],
      ["WOOSH::.sock", qr!\ABareword in require contains "/\."!],
-     ["::WOOSH::.sock", qr!\ABareword in require contains "/\."!],
-     ["::WOOSH/.sock", qr!\ABareword in require contains "/\."!],
-     ["::WOOSH/..sock", qr!\ABareword in require contains "/\."!],
-     ["::WOOSH/../sock", qr!\ABareword in require contains "/\."!],
-     ["::WOOSH::..::sock", qr!\ABareword in require contains "/\."!],
-     ["::WOOSH::.::sock", qr!\ABareword in require contains "/\."!],
-     ["::WOOSH::./sock", qr!\ABareword in require contains "/\."!],
-     ["::WOOSH/./sock", qr!\ABareword in require contains "/\."!],
-     ["::WOOSH/.::sock", qr!\ABareword in require contains "/\."!],
-     ["::WOOSH/..::sock", qr!\ABareword in require contains "/\."!],
-     ["::WOOSH::../sock", qr!\ABareword in require contains "/\."!],
-     ["::WOOSH::../..::sock", qr!\ABareword in require contains "/\."!],
-     ["::WOOSH\0sock", qr!\ACan't locate WOOSH\\0sock.pm:!],
+     ["WOOSH::.sock", qr!\ABareword in require contains "/\."!],
+     ["WOOSH/.sock", qr!\ABareword in require contains "/\."!],
+     ["WOOSH/..sock", qr!\ABareword in require contains "/\."!],
+     ["WOOSH/../sock", qr!\ABareword in require contains "/\."!],
+     ["WOOSH::..::sock", qr!\ABareword in require contains "/\."!],
+     ["WOOSH::.::sock", qr!\ABareword in require contains "/\."!],
+     ["WOOSH::./sock", qr!\ABareword in require contains "/\."!],
+     ["WOOSH/./sock", qr!\ABareword in require contains "/\."!],
+     ["WOOSH/.::sock", qr!\ABareword in require contains "/\."!],
+     ["WOOSH/..::sock", qr!\ABareword in require contains "/\."!],
+     ["WOOSH::../sock", qr!\ABareword in require contains "/\."!],
+     ["WOOSH::../..::sock", qr!\ABareword in require contains "/\."!],
+     ["WOOSH\0sock", qr!\ACan't locate WOOSH\\0sock.pm:!],
     ) {
     my ($module, $error) = @$_;
     my $module2 = $module; # load_module mangles its first argument
     no warnings 'syscalls';
     is(eval { load_module(PERL_LOADMOD_NOIMPORT, $module); 1}, undef,
        "expect load_module() for '$module2' to fail");
-    like($@, $error);
+    like($@, $error, "check expected error for $module2");
 }
 
 done_testing();

diff --git a/op.c b/op.c
index 9e69444..93205fe 100644 (file)
--- a/op.c
+++ b/op.c
@@ -10629,10 +10629,8 @@ Perl_ck_require(pTHX_ OP *o)
            len = SvCUR(sv);
            end = s + len;
             /* treat ::foo::bar as foo::bar */
-            if (len >= 2 && s[0] == ':' && s[1] == ':') {
-                Move(s+2, s, len - 2, char);
-                end -= 2;
-            }
+            if (len >= 2 && s[0] == ':' && s[1] == ':')
+                DIE(aTHX_ "Bareword in require must not start with a double-colon: \"%s\"\n", s);
             if (s == end)
                 DIE(aTHX_ "Bareword in require maps to empty filename");
 

diff --git a/pod/perldiag.pod b/pod/perldiag.pod
index 2aac10e..b949729 100644 (file)
--- a/pod/perldiag.pod
+++ b/pod/perldiag.pod
@@ -538,11 +538,17 @@ The C<strict> pragma is useful in avoiding such errors.
 
 =item Bareword in require maps to disallowed filename "%s"
 
+
 (F) The bareword form of require has been invoked with a filename which could
 not have been generated by a valid bareword permitted by the parser. You
 shouldn't be able to get this error from Perl code, but XS code may throw it
 if it passes an invalid module name to C<Perl_load_module>.
 
+=item Bareword in require must not start with a double-colon: "%s"
+
+(F) In C<require Bare::Word>, the bareword is not allowed to start with a
+double-colon. Write C<require ::Foo::Bar> as  C<require Foo::Bar> instead.
+
 =item Bareword "%s" not allowed while "strict subs" in use
 
 (F) With "strict subs" in use, a bareword is only allowed as a

diff --git a/t/comp/require.t b/t/comp/require.t
index 99dd578..c4889bb 100644 (file)
--- a/t/comp/require.t
+++ b/t/comp/require.t
@@ -34,7 +34,7 @@ if (grep -e, @files_to_delete) {
 
 my $Is_EBCDIC = (ord('A') == 193) ? 1 : 0;
 my $Is_UTF8   = (${^OPEN} || "") =~ /:utf8/;
-my $total_tests = 59;
+my $total_tests = 58;
 if ($Is_EBCDIC || $Is_UTF8) { $total_tests -= 3; }
 print "1..$total_tests\n";
 
@@ -205,9 +205,9 @@ $foo = eval  {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
 @foo = eval  {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
        eval  {require bleah}; delete $INC{"bleah.pm"}; ++$::i;
 
-eval {require ::bleah};
-print "# $@\nnot " if $@;
-print "ok ",++$i," - require ::bleah; is equivalent to require bleah;\n";
+eval 'require ::bleah;';
+print "# $@\nnot " unless $@ =~ /^Bareword in require must not start with a double-colon:/;
+print "ok ", $i," - require ::bleah is banned\n";
 
 # Test for fix of RT #24404 : "require $scalar" may load a directory
 my $r = "threads";

diff --git a/t/op/require_errors.t b/t/op/require_errors.t
index 0696d05..3744f14 100644 (file)
--- a/t/op/require_errors.t
+++ b/t/op/require_errors.t
@@ -26,13 +26,15 @@ for my $file ($nonfile, ' ') {
        "correct error message for require '$file'";
 }
 
-for my $file ($nonfile, "::$nonfile") {
-    eval "require $file";
-    $file =~ s/^:://;
+eval "require $nonfile";
 
-    like $@, qr/^Can't locate $nonfile\.pm in \@INC \(you may need to install the $nonfile module\) \(\@INC contains: @INC\) at/,
+like $@, qr/^Can't locate $nonfile\.pm in \@INC \(you may need to install the $nonfile module\) \(\@INC contains: @INC\) at/,
         "correct error message for require $nonfile";
-}
+
+eval "require ::$nonfile";
+
+like $@, qr/^Bareword in require must not start with a double-colon:/,
+        "correct error message for require ::$nonfile";
 
 eval {
     require "$nonfile.ph";