require should die if a file exists but can't be read.

See [perl #113422]. If a file exists but there's an error opening it,
we throw an exception and disregard the rest of @INC.

diff --git a/pp_ctl.c b/pp_ctl.c
index 8940324..f9e4935 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3690,7 +3690,7 @@ PP(pp_require)
        tryname = name;
        tryrsfp = doopen_pm(sv);
     }
-    if (!tryrsfp) {
+    if (!tryrsfp && !(errno == EACCES && path_is_absolute(name))) {
        AV * const ar = GvAVn(PL_incgv);
        I32 i;
 #ifdef VMS
@@ -3882,9 +3882,14 @@ PP(pp_require)
                        }
                        break;
                    }
-                   else if (errno == EMFILE)
-                       /* no point in trying other paths if out of handles */
-                       break;
+                    else if (errno == EMFILE || errno == EACCES) {
+                        /* no point in trying other paths if out of handles;
+                         * on the other hand, if we couldn't open one of the
+                         * files, then going on with the search could lead to
+                         * unexpected results; see perl #113422
+                         */
+                        break;
+                    }
                  }
                }
            }
@@ -3893,7 +3898,7 @@ PP(pp_require)
     sv_2mortal(namesv);
     if (!tryrsfp) {
        if (PL_op->op_type == OP_REQUIRE) {
-           if(errno == EMFILE) {
+           if(errno == EMFILE || errno == EACCES) {
                /* diag_listed_as: Can't locate %s */
                DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
            } else {

diff --git a/t/op/require_errors.t b/t/op/require_errors.t
index 8f5a26c..bd6c750 100644 (file)
--- a/t/op/require_errors.t
+++ b/t/op/require_errors.t
@@ -7,7 +7,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan(tests => 4);
+plan(tests => 6);
 
 my $nonfile = tempfile();
 
@@ -34,6 +34,52 @@ like $@, qr/^Can't locate $nonfile\.h in \@INC \(change \.h to \.ph maybe\?\) \(
 eval 'require <foom>';
 like $@, qr/^<> should be quotes at /, 'require <> error';
 
+my $module   = tempfile();
+my $mod_file = "$module.pm";
+
+open my $module_fh, ">", $mod_file or die $!;
+print { $module_fh } "print 1; 1;\n";
+close $module_fh;
+
+chmod 0333, $mod_file;
+
+SKIP: {
+    skip_if_miniperl("these modules may not be available to miniperl", 2);
+
+    push @INC, '../lib';
+    require Cwd;
+    require File::Spec::Functions;
+    if ($^O eq 'cygwin') {
+        require Win32;
+    }
+
+    # Going to try to switch away from root.  Might not work.
+    # (stolen from t/op/stat.t)
+    my $olduid = $>;
+    eval { $> = 1; };
+    skip "Can't test permissions meaningfully if you're superuser", 2
+        if ($^O eq 'cygwin' ? Win32::IsAdminUser() : $> == 0);
+
+    local @INC = ".";
+    eval "use $module";
+    like $@,
+        qr<^\QCan't locate $mod_file:>,
+        "special error message if the file exists but can't be opened";
+
+    my $file = File::Spec::Functions::catfile(Cwd::getcwd(), $mod_file);
+    eval {
+        require($file);
+    };
+    like $@,
+        qr<^\QCan't locate $file:>,
+        "...even if we use a full path";
+
+    # switch uid back (may not be implemented)
+    eval { $> = $olduid; };
+}
+
+1 while unlink $mod_file;
+
 # I can't see how to test the EMFILE case
 # I can't see how to test the case of not displaying @INC in the message.
 # (and does that only happen on VMS?)