This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
make do "a\0b" fail silently instead of throwing (RT #129928)
authorLukas Mai <l.mai@web.de>
Thu, 20 Oct 2016 22:10:15 +0000 (00:10 +0200)
committerTony Cook <tony@develop-help.com>
Tue, 25 Oct 2016 00:08:51 +0000 (11:08 +1100)
Also remove the label/goto from CLEAR_ERRSV because labels have function
scope, which means you couldn't use CLEAR_ERRSV more than once per
function without getting a "duplicate label" error.

perl.h
pp_ctl.c
t/op/require_errors.t

diff --git a/perl.h b/perl.h
index 88d4207..d27754e 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -1280,14 +1280,13 @@ EXTERN_C char *crypt(const char *, const char *);
 #define CLEAR_ERRSV() STMT_START {                                     \
     SV ** const svp = &GvSV(PL_errgv);                                 \
     if (!*svp) {                                                       \
-       goto clresv_newemptypv;                                         \
+        *svp = newSVpvs("");                                            \
     } else if (SvREADONLY(*svp)) {                                     \
        SvREFCNT_dec_NN(*svp);                                          \
-       clresv_newemptypv:                                              \
        *svp = newSVpvs("");                                            \
     } else {                                                           \
        SV *const errsv = *svp;                                         \
-        SvPVCLEAR(errsv);                                                \
+        SvPVCLEAR(errsv);                                               \
        SvPOK_only(errsv);                                              \
        if (SvMAGICAL(errsv)) {                                         \
            mg_free(errsv);                                             \
index 0eb032d..7b8dc5b 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3692,6 +3692,10 @@ S_require_file(pTHX_ SV *const sv)
         DIE(aTHX_ "Missing or undefined argument to require");
 
     if (!IS_SAFE_PATHNAME(name, len, "require")) {
+        if (PL_op->op_type != OP_REQUIRE) {
+            CLEAR_ERRSV();
+            RETPUSHUNDEF;
+        }
         DIE(aTHX_ "Can't locate %s:   %s",
             pv_escape(newSVpvs_flags("",SVs_TEMP),name,len,len*2,
                       NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
index d2c2bb5..2bacf59 100644 (file)
@@ -9,7 +9,7 @@ BEGIN {
 use strict;
 use warnings;
 
-plan(tests => 20);
+plan(tests => 23);
 
 my $nonfile = tempfile();
 
@@ -120,11 +120,21 @@ SKIP: {
 # fail and print the full filename
 eval { no warnings 'syscalls'; require "strict.pm\0invalid"; };
 like $@, qr/^Can't locate strict\.pm\\0invalid: /, 'require nul check [perl #117265]';
-eval { no warnings 'syscalls'; do "strict.pm\0invalid"; };
-like $@, qr/^Can't locate strict\.pm\\0invalid: /, 'do nul check';
 {
   my $WARN;
   local $SIG{__WARN__} = sub { $WARN = shift };
+  {
+    my $ret = do "strict.pm\0invalid";
+    my $exc = $@;
+    my $err = $!;
+    is $ret, undef, 'do nulstring returns undef';
+    is $exc, '',    'do nulstring clears $@';
+    $! = $err;
+    ok $!{ENOENT},  'do nulstring fails with ENOENT';
+    like $WARN, qr{^Invalid \\0 character in pathname for require: strict\.pm\\0invalid at }, 'do nulstring warning';
+  }
+
+  $WARN = '';
   eval { require "strict.pm\0invalid"; };
   like $WARN, qr{^Invalid \\0 character in pathname for require: strict\.pm\\0invalid at }, 'nul warning';
   like $@, qr{^Can't locate strict\.pm\\0invalid: }, 'nul error';