This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #117265] fix various problems with safesyscalls
authorTony Cook <tony@develop-help.com>
Mon, 9 Sep 2013 05:36:26 +0000 (15:36 +1000)
committerTony Cook <tony@develop-help.com>
Mon, 9 Sep 2013 05:36:26 +0000 (15:36 +1000)
- handling "" overloading correctly
- avoid an extraneous warning from glob()

doio.c
embed.fnc
embed.h
ext/File-Glob/Glob.xs
inline.h
perl.h
perlio.c
pp_ctl.c
pp_hot.c
proto.h
t/io/open.t

diff --git a/doio.c b/doio.c
index d79bf44..f2c3752 100644 (file)
--- a/doio.c
+++ b/doio.c
@@ -206,6 +206,8 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw,
            *--tend = '\0';
 
        if (num_svs) {
+            const char *p;
+            STRLEN nlen = 0;
            /* New style explicit name, type is just mode and layer info */
 #ifdef USE_STDIO
            if (SvROK(*svp) && !strchr(oname,'&')) {
@@ -216,11 +218,13 @@ Perl_do_openn(pTHX_ GV *gv, const char *oname, I32 len, int as_raw,
                goto say_false;
            }
 #endif /* USE_STDIO */
-           if (!IS_SAFE_PATHNAME(*svp, "open"))
+            p = (SvOK(*svp) || SvGMAGICAL(*svp)) ? SvPV(*svp, nlen) : NULL;
+
+           if (p && !IS_SAFE_PATHNAME(p, nlen, "open"))
                 goto say_false;
 
-           name = (SvOK(*svp) || SvGMAGICAL(*svp)) ?
-                       savesvpv (*svp) : savepvs ("");
+           name = p ? savepvn(p, nlen) : savepvs("");
+
            SAVEFREEPV(name);
        }
        else {
@@ -1661,9 +1665,9 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
                    }
                }
                else {
-                   const char *name = SvPV_nomg_const_nolen(*mark);
+                   const char *name = SvPV_nomg_const(*mark, len);
                    APPLY_TAINT_PROPER();
-                    if (!IS_SAFE_PATHNAME(*mark, "chmod") ||
+                    if (!IS_SAFE_PATHNAME(name, len, "chmod") ||
                         PerlLIO_chmod(name, val)) {
                         tot--;
                     }
@@ -1697,9 +1701,9 @@ Perl_apply(pTHX_ I32 type, SV **mark, SV **sp)
                    }
                }
                else {
-                   const char *name = SvPV_nomg_const_nolen(*mark);
+                   const char *name = SvPV_nomg_const(*mark, len);
                    APPLY_TAINT_PROPER();
-                    if (!IS_SAFE_PATHNAME(*mark, "chown") ||
+                    if (!IS_SAFE_PATHNAME(name, len, "chown") ||
                         PerlLIO_chown(name, val, val2)) {
                        tot--;
                     }
@@ -1800,9 +1804,9 @@ nothing in the core.
        APPLY_TAINT_PROPER();
        tot = sp - mark;
        while (++mark <= sp) {
-           s = SvPV_nolen_const(*mark);
+           s = SvPV_const(*mark, len);
            APPLY_TAINT_PROPER();
-           if (!IS_SAFE_PATHNAME(*mark, "unlink")) {
+           if (!IS_SAFE_PATHNAME(s, len, "unlink")) {
                 tot--;
             }
            else if (PerlProc_geteuid() || PL_unsafe) {
@@ -1881,9 +1885,9 @@ nothing in the core.
                    }
                }
                else {
-                   const char * const name = SvPV_nomg_const_nolen(*mark);
+                   const char * const name = SvPV_nomg_const(*mark, len);
                    APPLY_TAINT_PROPER();
-                   if (!IS_SAFE_PATHNAME(*mark, "utime")) {
+                   if (!IS_SAFE_PATHNAME(name, len, "utime")) {
                         tot--;
                     }
                     else
@@ -2376,10 +2380,12 @@ Perl_start_glob (pTHX_ SV *tmpglob, IO *io)
     dVAR;
     SV * const tmpcmd = newSV(0);
     PerlIO *fp;
+    STRLEN len;
+    const char *s = SvPV(tmpglob, len);
 
     PERL_ARGS_ASSERT_START_GLOB;
 
-    if (!IS_SAFE_SYSCALL(tmpglob, "pattern", "glob"))
+    if (!IS_SAFE_SYSCALL(s, len, "pattern", "glob"))
         return NULL;
 
     ENTER;
@@ -2441,6 +2447,12 @@ Perl_vms_start_glob
     fp = IoIFP(io);
 #endif /* !VMS */
     LEAVE;
+
+    if (!fp && ckWARN(WARN_GLOB)) {
+        Perl_warner(aTHX_ packWARN(WARN_GLOB), "glob failed (can't start child: %s)",
+                    Strerror(errno));
+    }
+
     return fp;
 }
 
index 896f709..0f686d4 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -1598,7 +1598,7 @@ Ap     |I32    |whichsig_sv    |NN SV* sigsv
 Ap     |I32    |whichsig_pv    |NN const char* sig
 Ap     |I32    |whichsig_pvn   |NN const char* sig|STRLEN len
 : used to check for NULs in pathnames and other names
-AiR    |bool   |is_safe_syscall|NN SV *pv|NN const char *what|NN const char *op_name
+AiR    |bool   |is_safe_syscall|NN const char *pv|STRLEN len|NN const char *what|NN const char *op_name
 : Used in pp_ctl.c
 p      |void   |write_to_stderr|NN SV* msv
 : Used in op.c
diff --git a/embed.h b/embed.h
index 3662b97..7e0f83e 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define instr                  Perl_instr
 #define is_ascii_string                Perl_is_ascii_string
 #define is_lvalue_sub()                Perl_is_lvalue_sub(aTHX)
-#define is_safe_syscall(a,b,c) S_is_safe_syscall(aTHX_ a,b,c)
+#define is_safe_syscall(a,b,c,d)       S_is_safe_syscall(aTHX_ a,b,c,d)
 #define is_uni_alnum(a)                Perl_is_uni_alnum(aTHX_ a)
 #define is_uni_alnum_lc(a)     Perl_is_uni_alnum_lc(aTHX_ a)
 #define is_uni_alnumc(a)       Perl_is_uni_alnumc(aTHX_ a)
index 43904df..b3705b3 100644 (file)
@@ -63,7 +63,7 @@ doglob(pTHX_ const char *pattern, int flags)
 }
 
 static void
-iterate(pTHX_ bool(*globber)(pTHX_ AV *entries, SV *patsv))
+iterate(pTHX_ bool(*globber)(pTHX_ AV *entries, const char *pat, STRLEN len, bool is_utf8))
 {
     dSP;
     dMY_CXT;
@@ -80,8 +80,34 @@ iterate(pTHX_ bool(*globber)(pTHX_ AV *entries, SV *patsv))
 
     /* if we're just beginning, do it all first */
     if (SvTYPE(entries) != SVt_PVAV) {
+        const char *pat;
+        STRLEN len;
+        bool is_utf8;
+
+        /* glob without args defaults to $_ */
+        SvGETMAGIC(patsv);
+        if (
+            !SvOK(patsv)
+              && (patsv = DEFSV, SvGETMAGIC(patsv), !SvOK(patsv))
+            ) {
+            pat = "";
+            len = 0;
+            is_utf8 = 0;
+        }
+        else {
+            pat = SvPV_nomg(patsv,len);
+            is_utf8 = !!SvUTF8(patsv);
+        }
+
+        if (!IS_SAFE_SYSCALL(pat, len, "pattern", "glob")) {
+            if (gimme != G_ARRAY)
+                PUSHs(&PL_sv_undef);
+            PUTBACK;
+            return;
+        }
+
        PUTBACK;
-       on_stack = globber(aTHX_ entries, patsv);
+       on_stack = globber(aTHX_ entries, pat, len, is_utf8);
        SPAGAIN;
     }
 
@@ -111,10 +137,9 @@ iterate(pTHX_ bool(*globber)(pTHX_ AV *entries, SV *patsv))
 /* returns true if the items are on the stack already, but only in
    list context */
 static bool
-csh_glob(pTHX_ AV *entries, SV *patsv)
+csh_glob(pTHX_ AV *entries, const char *pat, STRLEN len, bool is_utf8)
 {
        dSP;
-       const char *pat;
        AV *patav = NULL;
        const char *patend;
        const char *s = NULL;
@@ -122,20 +147,13 @@ csh_glob(pTHX_ AV *entries, SV *patsv)
        SV *word = NULL;
        int const flags =
            (int)SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
-       bool is_utf8;
-       STRLEN len;
        U32 const gimme = GIMME_V;
 
-       /* glob without args defaults to $_ */
-       SvGETMAGIC(patsv);
-       if (
-           !SvOK(patsv)
-        && (patsv = DEFSV, SvGETMAGIC(patsv), !SvOK(patsv))
-       )
-            pat = "", len = 0, is_utf8 = 0;
-       else pat = SvPV_nomg(patsv,len), is_utf8 = !!SvUTF8(patsv);
        patend = pat + len;
 
+       assert(SvTYPE(entries) != SVt_PVAV);
+       sv_upgrade((SV *)entries, SVt_PVAV);
+
        /* extract patterns */
        s = pat-1;
        while (++s < patend) {
@@ -173,7 +191,7 @@ csh_glob(pTHX_ AV *entries, SV *patsv)
                    while (isSPACE(*(patend-1))) patend--;
                    /* bsd_glob expects a trailing null, but we cannot mod-
                       ify the original */
-                   if (patend < SvEND(patsv)) {
+                   if (patend < pat + len) {
                        if (word) sv_setpvn(word, pat, patend-pat);
                        else
                            word = newSVpvn_flags(
@@ -225,11 +243,6 @@ csh_glob(pTHX_ AV *entries, SV *patsv)
        }
       end_of_parsing:
 
-       assert(SvTYPE(entries) != SVt_PVAV);
-       sv_upgrade((SV *)entries, SVt_PVAV);
-        if (!IS_SAFE_SYSCALL(patsv, "pattern", "glob"))
-            return FALSE;
-
        if (patav) {
            I32 items = AvFILLp(patav) + 1;
            SV **svp = AvARRAY(patav);
@@ -284,21 +297,12 @@ csh_glob_iter(pTHX)
 
 /* wrapper around doglob that can be passed to the iterator */
 static bool
-doglob_iter_wrapper(pTHX_ AV *entries, SV *patsv)
+doglob_iter_wrapper(pTHX_ AV *entries, const char *pattern, STRLEN len, bool is_utf8)
 {
     dSP;
-    const char *pattern;
     int const flags =
            (int)SvIV(get_sv("File::Glob::DEFAULT_FLAGS", GV_ADD));
 
-    SvGETMAGIC(patsv);
-    if (
-           !SvOK(patsv)
-        && (patsv = DEFSV, SvGETMAGIC(patsv), !SvOK(patsv))
-    )
-        pattern = "";
-    else pattern = SvPV_nomg_nolen(patsv);
-
     PUSHMARK(SP);
     PUTBACK;
     doglob(aTHX_ pattern, flags);
@@ -341,12 +345,17 @@ GLOB_ERROR()
        RETVAL
 
 void
-bsd_glob(pattern,...)
-    char *pattern
+bsd_glob(pattern_sv,...)
+    SV *pattern_sv
 PREINIT:
     int flags = 0;
+    char *pattern;
+    STRLEN len;
 PPCODE:
     {
+        pattern = SvPV(pattern_sv, len);
+        if (!IS_SAFE_SYSCALL(pattern, len, "pattern", "bsd_glob"))
+            XSRETURN(0);
        /* allow for optional flags argument */
        if (items > 1) {
            flags = (int) SvIV(ST(1));
index a5742b8..a2727f4 100644 (file)
--- a/inline.h
+++ b/inline.h
@@ -288,7 +288,7 @@ S_isALNUM_lazy(pTHX_ const char* p)
 /* ------------------------------- perl.h ----------------------------- */
 
 /*
-=for apidoc AiR|bool|is_safe_syscall|SV *pv|const char *what|const char *op_name
+=for apidoc AiR|bool|is_safe_syscall|const char *pv|STRLEN len|const char *what|const char *op_name
 
 Test that the given C<pv> doesn't contain any internal NUL characters.
 If it does, set C<errno> to ENOENT, optionally warn, and return FALSE.
@@ -301,21 +301,20 @@ Used by the IS_SAFE_SYSCALL() macro.
 */
 
 PERL_STATIC_INLINE bool
-S_is_safe_syscall(pTHX_ SV *pv, const char *what, const char *op_name) {
+S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name) {
     /* While the Windows CE API provides only UCS-16 (or UTF-16) APIs
      * perl itself uses xce*() functions which accept 8-bit strings.
      */
 
     PERL_ARGS_ASSERT_IS_SAFE_SYSCALL;
 
-    if (SvPOK(pv) && SvCUR(pv) >= 1) {
-        char *p = SvPVX(pv);
+    if (pv && len > 1) {
         char *null_at;
-        if (UNLIKELY((null_at = (char *)memchr(p, 0, SvCUR(pv)-1)) != NULL)) {
+        if (UNLIKELY((null_at = (char *)memchr(pv, 0, len-1)) != NULL)) {
                 SETERRNO(ENOENT, LIB_INVARG);
                 Perl_ck_warner(aTHX_ packWARN(WARN_SYSCALLS),
                                    "Invalid \\0 character in %s for %s: %s\\0%s",
-                                   what, op_name, p, null_at+1);
+                                   what, op_name, pv, null_at+1);
                 return FALSE;
         }
     }
diff --git a/perl.h b/perl.h
index e4cee69..5adc8d4 100644 (file)
--- a/perl.h
+++ b/perl.h
@@ -5692,9 +5692,9 @@ extern void moncontrol(int);
 
 /* check embedded \0 characters in pathnames passed to syscalls,
    but allow one ending \0 */
-#define IS_SAFE_SYSCALL(pv, what, op_name) (S_is_safe_syscall(aTHX_ (pv), (what), (op_name)))
+#define IS_SAFE_SYSCALL(p, len, what, op_name) (S_is_safe_syscall(aTHX_ (p), (len), (what), (op_name)))
 
-#define IS_SAFE_PATHNAME(pv, op_name) IS_SAFE_SYSCALL((pv), "pathname", (op_name))
+#define IS_SAFE_PATHNAME(p, len, op_name) IS_SAFE_SYSCALL((p), (len), "pathname", (op_name))
 
 #if defined(OEMVS)
 #define NO_ENV_ARRAY_IN_MAIN
index 7de7085..c2cc319 100644 (file)
--- a/perlio.c
+++ b/perlio.c
@@ -312,8 +312,9 @@ PerlIO_openn(pTHX_ const char *layers, const char *mode, int fd,
        if (*args == &PL_sv_undef)
            return PerlIO_tmpfile();
        else {
-           const char *name = SvPV_nolen_const(*args);
-            if (!IS_SAFE_PATHNAME(*args, "open"))
+            STRLEN len;
+           const char *name = SvPV_nolen_const(*args, len);
+            if (!IS_SAFE_PATHNAME(name, len, "open"))
                 return NULL;
 
            if (*mode == IoTYPE_NUMERIC) {
@@ -2725,8 +2726,9 @@ PerlIOUnix_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 #endif
        }
        if (imode != -1) {
-           const char *path = SvPV_nolen_const(*args);
-           if (!IS_SAFE_PATHNAME(*args, "open"))
+            STRLEN len;
+           const char *path = SvPV_const(*args, len);
+           if (!IS_SAFE_PATHNAME(path, len, "open"))
                 return NULL;
            fd = PerlLIO_open3(path, imode, perm);
        }
@@ -3039,10 +3041,11 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
 {
     char tmode[8];
     if (PerlIOValid(f)) {
-       const char * const path = SvPV_nolen_const(*args);
+        STRLEN len;
+       const char * const path = SvPV_const(*args, len);
        PerlIOStdio * const s = PerlIOSelf(f, PerlIOStdio);
        FILE *stdio;
-       if (!IS_SAFE_PATHNAME(*args, "open"))
+       if (!IS_SAFE_PATHNAME(path, len, "open"))
             return NULL;
        PerlIOUnix_refcnt_dec(fileno(s->stdio));
        stdio = PerlSIO_freopen(path, (mode = PerlIOStdio_mode(mode, tmode)),
@@ -3055,8 +3058,9 @@ PerlIOStdio_open(pTHX_ PerlIO_funcs *self, PerlIO_list_t *layers,
     }
     else {
        if (narg > 0) {
-           const char * const path = SvPV_nolen_const(*args);
-            if (!IS_SAFE_PATHNAME(*args, "open"))
+            STRLEN len;
+           const char * const path = SvPV_const(*args, len);
+            if (!IS_SAFE_PATHNAME(path, len, "open"))
                 return NULL;
            if (*mode == IoTYPE_NUMERIC) {
                mode++;
index 7fd27f8..243bcac 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -3597,7 +3597,8 @@ STATIC PerlIO *
 S_check_type_and_open(pTHX_ SV *name)
 {
     Stat_t st;
-    const char *p = SvPV_nolen_const(name);
+    STRLEN len;
+    const char *p = SvPV_const(name, len);
     int st_rc;
 
     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
@@ -3608,7 +3609,7 @@ S_check_type_and_open(pTHX_ SV *name)
      * rather than for the .pm file.
      * This check prevents a \0 in @INC causing problems.
      */
-    if (!IS_SAFE_PATHNAME(name, "require"))
+    if (!IS_SAFE_PATHNAME(p, len, "require"))
         return NULL;
 
     st_rc = PerlLIO_stat(p, &st);
@@ -3637,7 +3638,7 @@ S_doopen_pm(pTHX_ SV *name)
      * warning referring to the .pmc which the user probably doesn't
      * know or care about
      */
-    if (!IS_SAFE_PATHNAME(name, "require"))
+    if (!IS_SAFE_PATHNAME(p, namelen, "require"))
         return NULL;
 
     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
@@ -3772,7 +3773,7 @@ PP(pp_require)
     name = SvPV_const(sv, len);
     if (!(name && len > 0 && *name))
        DIE(aTHX_ "Null filename used");
-    if (!IS_SAFE_PATHNAME(sv, "require")) {
+    if (!IS_SAFE_PATHNAME(name, len, "require")) {
         DIE(aTHX_ "Can't locate %s:   %s",
             pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
                       SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
index d3f8976..9641b19 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1569,14 +1569,10 @@ Perl_do_readline(pTHX)
     }
     if (!fp) {
        if ((!io || !(IoFLAGS(io) & IOf_START))
-           && ckWARN2(WARN_GLOB, WARN_CLOSED))
+           && ckWARN(WARN_CLOSED)
+            && type != OP_GLOB)
        {
-           if (type == OP_GLOB)
-               Perl_ck_warner_d(aTHX_ packWARN(WARN_GLOB),
-                           "glob failed (can't start child: %s)",
-                           Strerror(errno));
-           else
-               report_evil_fh(PL_last_in_gv);
+           report_evil_fh(PL_last_in_gv);
        }
        if (gimme == G_SCALAR) {
            /* undef TARG, and push that undefined value */
diff --git a/proto.h b/proto.h
index 88aaa0a..7281242 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1761,11 +1761,11 @@ PERL_CALLCONV bool      Perl_is_ascii_string(const U8 *s, STRLEN len)
 PERL_CALLCONV I32      Perl_is_lvalue_sub(pTHX)
                        __attribute__warn_unused_result__;
 
-PERL_STATIC_INLINE bool        S_is_safe_syscall(pTHX_ SV *pv, const char *what, const char *op_name)
+PERL_STATIC_INLINE bool        S_is_safe_syscall(pTHX_ const char *pv, STRLEN len, const char *what, const char *op_name)
                        __attribute__warn_unused_result__
                        __attribute__nonnull__(pTHX_1)
-                       __attribute__nonnull__(pTHX_2)
-                       __attribute__nonnull__(pTHX_3);
+                       __attribute__nonnull__(pTHX_3)
+                       __attribute__nonnull__(pTHX_4);
 #define PERL_ARGS_ASSERT_IS_SAFE_SYSCALL       \
        assert(pv); assert(what); assert(op_name)
 
index e170ab6..3e6efb4 100644 (file)
@@ -10,7 +10,7 @@ $|  = 1;
 use warnings;
 use Config;
 
-plan tests => 145;
+plan tests => 153;
 
 my $Perl = which_perl();
 
@@ -407,19 +407,30 @@ pass("no crash when open autovivifies glob in freed package");
     my ($final_mode, $final_mtime) = (stat $temp)[2, 9];
 
     my $fn = "$temp\0.invalid";
+    my $fno = bless \(my $fn2 = "$temp\0.overload"), "OverloadTest";
     is(open(I, $fn), undef, "open with nul in pathnames since 5.18 [perl #117265]");
     like($WARN, qr/^Invalid \\0 character in pathname for open: $temp_match\\0\.invalid/,
          "warn on embedded nul"); $WARN = '';
-    is (unlink($fn), 0);
-    like($WARN, qr/^Invalid \\0 character in pathname for unlink: $temp_match\\0\.invalid/,
-         "also on unlink"); $WARN = '';
-    is(chmod(0444, $fn), 0);
+    is(open(I, $fno), undef, "open with nul in pathnames since 5.18 [perl #117265] (overload)");
+    like($WARN, qr/^Invalid \\0 character in pathname for open: $temp_match\\0\.overload/,
+         "warn on embedded nul"); $WARN = '';
+
+    is(chmod(0444, $fn), 0, "chmod fails with \\0 in name");
     like($WARN, qr/^Invalid \\0 character in pathname for chmod: $temp_match\\0\.invalid/,
          "also on chmod"); $WARN = '';
-    is (glob($fn), ());
+
+    is(chmod(0444, $fno), 0, "chmod fails with \\0 in name (overload)");
+    like($WARN, qr/^Invalid \\0 character in pathname for chmod: $temp_match\\0\.overload/,
+         "also on chmod"); $WARN = '';
+
+    is (glob($fn), undef, "glob fails with \\0 in name");
     like($WARN, qr/^Invalid \\0 character in pattern for glob: $temp_match\\0\.invalid/,
          "also on glob"); $WARN = '';
 
+    is (glob($fno), undef, "glob fails with \\0 in name (overload)");
+    like($WARN, qr/^Invalid \\0 character in pattern for glob: $temp_match\\0\.overload/,
+         "also on glob"); $WARN = '';
+
     {
         no warnings 'syscalls';
         $WARN = '';
@@ -446,7 +457,19 @@ pass("no crash when open autovivifies glob in freed package");
         is($!+0, ENOENT, "check errno");
     }
 
+    is (unlink($fn), 0, "unlink fails with \\0 in name");
+    like($WARN, qr/^Invalid \\0 character in pathname for unlink: $temp_match\\0\.invalid/,
+         "also on unlink"); $WARN = '';
+
+    is (unlink($fno), 0, "unlink fails with \\0 in name (overload)");
+    like($WARN, qr/^Invalid \\0 character in pathname for unlink: $temp_match\\0\.overload/,
+         "also on unlink"); $WARN = '';
+
     ok(-f $temp, "nothing removed the temp file");
     is((stat $temp)[2], $final_mode, "nothing changed its mode");
     is((stat $temp)[9], $final_mtime, "nothing changes its mtime");
 }
+
+
+package OverloadTest;
+use overload '""' => sub { ${$_[0]} };