(perl #131895) fail stat on names with \0 embedded

Also lstat() and the file test ops.

diff --git a/doio.c b/doio.c
index ebcf1b1..6931346 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -1808,7 +1808,7 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
        return PL_laststatval;
     else {
        SV* const sv = TOPs;
-       const char *s;
+       const char *s, *d;
        STRLEN len;
        if ((gv = MAYBE_DEREF_GV_flags(sv,flags))) {
            goto do_fstat;
@@ -1822,9 +1822,14 @@ Perl_my_stat_flags(pTHX_ const U32 flags)
        s = SvPV_flags_const(sv, len, flags);
        PL_statgv = NULL;
        sv_setpvn(PL_statname, s, len);
-       s = SvPVX_const(PL_statname);           /* s now NUL-terminated */
+       d = SvPVX_const(PL_statname);           /* s now NUL-terminated */
        PL_laststype = OP_STAT;
-       PL_laststatval = PerlLIO_stat(s, &PL_statcache);
+        if (!IS_SAFE_PATHNAME(s, len, OP_NAME(PL_op))) {
+            PL_laststatval = -1;
+        }
+        else {
+            PL_laststatval = PerlLIO_stat(d, &PL_statcache);
+        }
        if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(s)) {
             GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
            Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "stat");
@@ -1841,6 +1846,7 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
     static const char* const no_prev_lstat = "The stat preceding -l _ wasn't an lstat";
     dSP;
     const char *file;
+    STRLEN len;
     SV* const sv = TOPs;
     bool isio = FALSE;
     if (PL_op->op_flags & OPf_REF) {
@@ -1884,9 +1890,14 @@ Perl_my_lstat_flags(pTHX_ const U32 flags)
                               HEKfARG(GvENAME_HEK((const GV *)
                                           (SvROK(sv) ? SvRV(sv) : sv))));
     }
-    file = SvPV_flags_const_nolen(sv, flags);
+    file = SvPV_flags_const(sv, len, flags);
     sv_setpv(PL_statname,file);
-    PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
+    if (!IS_SAFE_PATHNAME(file, len, OP_NAME(PL_op))) {
+        PL_laststatval = -1;
+    }
+    else {
+        PL_laststatval = PerlLIO_lstat(file,&PL_statcache);
+    }
     if (PL_laststatval < 0 && ckWARN(WARN_NEWLINE) && should_warn_nl(file)) {
         GCC_DIAG_IGNORE(-Wformat-nonliteral); /* PL_warn_nl is constant */
         Perl_warner(aTHX_ packWARN(WARN_NEWLINE), PL_warn_nl, "lstat");

diff --git a/pod/perldelta.pod b/pod/perldelta.pod
index a86e290..a8f029c 100644 (file)
--- a/pod/perldelta.pod
+++ b/pod/perldelta.pod
@@ -444,6 +444,12 @@ files in F<ext/> and F<lib/> are best summarized in L</Modules and Pragmata>.
 
 =item *
 
+C<stat()>, C<lstat()>, and file test operators now fail if given a
+filename containing a nul character, in the same way that C<open()>
+already fails.
+
+=item *
+
 The in-place reverse optimisation now correctly strengthens weak
 references using the L<C<sv_rvunweaken()>|perlapi/sv_rvunweaken>
 API function.

diff --git a/pp_sys.c b/pp_sys.c
index a41b188..672e7de 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -2952,19 +2952,24 @@ PP(pp_stat)
     }
     else {
         const char *file;
+        const char *temp;
+        STRLEN len;
        if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVIO) { 
             io = MUTABLE_IO(SvRV(sv));
             if (PL_op->op_type == OP_LSTAT)
                 goto do_fstat_warning_check;
             goto do_fstat_have_io; 
         }
-        
        SvTAINTED_off(PL_statname); /* previous tainting irrelevant */
-       sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
+        temp = SvPV_nomg_const(sv, len);
+       sv_setpv(PL_statname, temp);
        PL_statgv = NULL;
        PL_laststype = PL_op->op_type;
         file = SvPV_nolen_const(PL_statname);
-       if (PL_op->op_type == OP_LSTAT)
+        if (!IS_SAFE_PATHNAME(temp, len, OP_NAME(PL_op))) {
+            PL_laststatval = -1;
+        }
+       else if (PL_op->op_type == OP_LSTAT)
            PL_laststatval = PerlLIO_lstat(file, &PL_statcache);
        else
            PL_laststatval = PerlLIO_stat(file, &PL_statcache);
@@ -3198,8 +3203,12 @@ PP(pp_ftrread)
 
     if (use_access) {
 #if defined(HAS_ACCESS) || defined (PERL_EFF_ACCESS)
-       const char *name = SvPV_nolen(*PL_stack_sp);
-       if (effective) {
+        STRLEN len;
+       const char *name = SvPV(*PL_stack_sp, len);
+        if (!IS_SAFE_PATHNAME(name, len, OP_NAME(PL_op))) {
+            result = -1;
+        }
+       else if (effective) {
 #  ifdef PERL_EFF_ACCESS
            result = PERL_EFF_ACCESS(name, access_mode);
 #  else
@@ -3524,10 +3533,18 @@ PP(pp_fttext)
     }
     else {
         const char *file;
+        const char *temp;
+        STRLEN temp_len;
         int fd; 
 
         assert(sv);
-       sv_setpv(PL_statname, SvPV_nomg_const_nolen(sv));
+        temp = SvPV_nomg_const(sv, temp_len);
+       sv_setpv(PL_statname, temp);
+        if (!IS_SAFE_PATHNAME(temp, temp_len, OP_NAME(PL_op))) {
+            PL_laststatval = -1;
+            PL_laststype = OP_STAT;
+            FT_RETURNUNDEF;
+        }
       really_filename:
         file = SvPVX_const(PL_statname);
        PL_statgv = NULL;

diff --git a/t/lib/warnings/pp_sys b/t/lib/warnings/pp_sys
index 337defd..90d3cc7 100644 (file)
--- a/t/lib/warnings/pp_sys
+++ b/t/lib/warnings/pp_sys
@@ -913,3 +913,17 @@ close $fh;
 unlink $file;
 EXPECT
 syswrite() is deprecated on :utf8 handles. This will be a fatal error in Perl 5.30 at - line 5.
+########
+# NAME stat on name with \0
+use warnings;
+my @x = stat("./\0-");
+my @y = lstat("./\0-");
+-T ".\0-";
+-x ".\0-";
+-l ".\0-";
+EXPECT
+Invalid \0 character in pathname for stat: ./\0- at - line 2.
+Invalid \0 character in pathname for lstat: ./\0- at - line 3.
+Invalid \0 character in pathname for fttext: .\0- at - line 4.
+Invalid \0 character in pathname for fteexec: .\0- at - line 5.
+Invalid \0 character in pathname for ftlink: .\0- at - line 6.

diff --git a/t/op/filetest.t b/t/op/filetest.t
index 8883381..bd1d08c 100644 (file)
--- a/t/op/filetest.t
+++ b/t/op/filetest.t
@@ -9,7 +9,7 @@ BEGIN {
     set_up_inc(qw '../lib ../cpan/Perl-OSType/lib');
 }
 
-plan(tests => 53 + 27*14);
+plan(tests => 57 + 27*14);
 
 if ($^O =~ /MSWin32|cygwin|msys/ && !is_miniperl) {
   require Win32; # for IsAdminUser()
@@ -393,3 +393,11 @@ SKIP: {
     is $failed_stat2, $failed_stat1,
        'failed -r($gv_with_io_but_no_fp) with and w/out fatal warnings';
 } 
+
+{
+    # [perl #131895] stat() doesn't fail on filenames containing \0 / NUL
+    ok(!-T "TEST\0-", '-T on name with \0');
+    ok(!-B "TEST\0-", '-B on name with \0');
+    ok(!-f "TEST\0-", '-f on name with \0');
+    ok(!-r "TEST\0-", '-r on name with \0');
+}

diff --git a/t/op/stat.t b/t/op/stat.t
index 48b659b..f93f21d 100644 (file)
--- a/t/op/stat.t
+++ b/t/op/stat.t
@@ -25,7 +25,7 @@ if ($^O eq 'MSWin32') {
     ${^WIN32_SLOPPY_STAT} = 0;
 }
 
-plan tests => 108;
+plan tests => 110;
 
 my $Perl = which_perl();
 
@@ -626,6 +626,16 @@ SKIP:
       'stat on an array of valid paths should return ENOENT';
 }
 
+# [perl #131895] stat() doesn't fail on filenames containing \0 / NUL
+ok !stat("TEST\0-"), 'stat on filename with \0';
+SKIP: {
+    my $link = "TEST.symlink.$$";
+    my $can_symlink = eval { symlink "TEST", $link };
+    skip "cannot symlink", 1 unless $can_symlink;
+    ok !lstat("$link\0-"), 'lstat on filename with \0';
+    unlink $link;
+}
+
 END {
     chmod 0666, $tmpfile;
     unlink_all $tmpfile;