make base.pm more strict about nonexistent module check

4 files changed, 72 insertions, 3 deletions

diff --git a/dist/base/MANIFEST b/dist/base/MANIFEST
index da973e0a06..cdf1fdbc80 100644
--- a/dist/base/MANIFEST
+++ b/dist/base/MANIFEST
@@ -11,6 +11,7 @@ t/fields-5_8_0.t
 t/fields-base.t
 t/fields.t
 t/isa.t
+t/lib/Broken.pm
 t/lib/Dummy.pm
 t/lib/HasSigDie.pm
 t/sigdie.t
diff --git a/dist/base/lib/base.pm b/dist/base/lib/base.pm
index 4c4b1d2c88..24f7e5cd6d 100644
--- a/dist/base/lib/base.pm
+++ b/dist/base/lib/base.pm
@@ -55,6 +55,23 @@ else {
     }
 }
 
+if ($] < 5.008) {
+    *_module_to_filename = sub {
+        (my $fn = $_[0]) =~ s!::!/!g;
+        $fn .= '.pm';
+        return $fn;
+    }
+}
+else {
+    *_module_to_filename = sub {
+        (my $fn = $_[0]) =~ s!::!/!g;
+        $fn .= '.pm';
+        utf8::encode($fn);
+        return $fn;
+    }
+}
+
+
 sub import {
     my $class = shift;
 
@@ -78,7 +95,10 @@ sub import {
             my $sigdie;
             {
                 local $SIG{__DIE__};
-                eval "require $base";
+                my $fn = _module_to_filename($base);
+                my $file = __FILE__;
+                my $line = __LINE__ + 1;
+                eval { require $fn };
                 # Only ignore "Can't locate" errors from our eval require.
                 # Other fatal errors (syntax etc) must be reported.
                 #
@@ -87,7 +107,8 @@ sub import {
                 # probably be using parent.pm, which doesn't try to
                 # guess whether require is needed or failed,
                 # see [perl #118561]
-                die if $@ && $@ !~ /^Can't locate .*? at \(eval /;
+                die if $@ && $@ !~ /^Can't locate \Q$fn\E .*? at \Q$file\E line \Q$line\E\.\n\z/s
+                          || $@ =~ /Compilation failed in require at \Q$file\E line \Q$line\E\.\n\z/;
                 unless (%{"$base\::"}) {
                     require Carp;
                     local $" = " ";
diff --git a/dist/base/t/base.t b/dist/base/t/base.t
index 6fb24ea308..0bbb5be947 100644
--- a/dist/base/t/base.t
+++ b/dist/base/t/base.t
@@ -1,7 +1,7 @@
 #!/usr/bin/perl -w
 
 use strict;
-use Test::More tests => 11;
+use Test::More tests => 15;
 
 use_ok('base');
 
@@ -81,3 +81,43 @@ like( $@, qr/^Base class package "reallyReAlLyNotexists" is empty\./,
     eval q{ use base 'Schlozhauer' };
     ::is( $@, '', 'Can coexist with a FIELDS constant' );
 }
+
+{
+    use lib 't/lib';
+    package UsingBroken;
+    eval q{use base 'Broken';};
+    ::like( $@, qr/^Can't locate ThisModuleDoesNotExist\.pm/,
+        'base fails to compile by loading nonexistent module');
+}
+
+SKIP: {
+    skip "unicode not supported on perl $]", 2 if $] < 5.008;
+    eval q{
+        package UsingUnicode;
+        my $base = "M\N{U+00D8}dule";
+        no strict 'refs';
+        *{"${base}::foo"} = sub {};
+        eval q{use base $base;};
+        ::is( $@, '', 'nonexistent unicode module allowed');
+    };
+
+    eval q{
+        package UsingUtf8;
+        my $base = "M\N{U+00D8}dule";
+        utf8::encode($base);
+        no strict 'refs';
+        *{"${base}::foo"} = sub {};
+        eval q{use base $base;};
+        ::is( $@, '', 'nonexistent utf8 module allowed');
+    };
+}
+
+{
+    package WithHostileINC;
+    local @INC = (@INC, "a\nb");
+    my $base = "NonExistentModule";
+    no strict 'refs';
+    *{"${base}::foo"} = sub {};
+    eval q{use base $base;};
+    ::is( $@, '', 'nonexistent module allowed when @INC has hostile entries');
+}
diff --git a/dist/base/t/lib/Broken.pm b/dist/base/t/lib/Broken.pm
new file mode 100644
index 0000000000..4d9474abc6
--- /dev/null
+++ b/dist/base/t/lib/Broken.pm
@@ -0,0 +1,7 @@
+package Broken;
+
+sub i_exist { 1 }
+
+eval "require ThisModuleDoesNotExist;" or die $@;
+
+1;