[perl #117265] correctly handle overloaded strings

diff --git a/doio.c b/doio.c
index d79bf44..3988c78 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;

diff --git a/embed.fnc b/embed.fnc
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
@@ -231,7 +231,7 @@
 #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)

diff --git a/ext/File-Glob/Glob.xs b/ext/File-Glob/Glob.xs
index 43904df..6189b0f 100644 (file)
--- a/ext/File-Glob/Glob.xs
+++ b/ext/File-Glob/Glob.xs
@@ -136,6 +136,12 @@ csh_glob(pTHX_ AV *entries, SV *patsv)
        else pat = SvPV_nomg(patsv,len), is_utf8 = !!SvUTF8(patsv);
        patend = pat + len;
 
+       assert(SvTYPE(entries) != SVt_PVAV);
+       sv_upgrade((SV *)entries, SVt_PVAV);
+
+        if (!IS_SAFE_SYSCALL(pat, len, "pattern", "glob"))
+            return FALSE;
+
        /* extract patterns */
        s = pat-1;
        while (++s < patend) {
@@ -225,11 +231,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);

diff --git a/inline.h b/inline.h
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

diff --git a/perlio.c b/perlio.c
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++;

diff --git a/pp_ctl.c b/pp_ctl.c
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),

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)
 

diff --git a/t/io/open.t b/t/io/open.t
index 711c27e..3e6efb4 100644 (file)
--- a/t/io/open.t
+++ b/t/io/open.t
@@ -419,21 +419,17 @@ pass("no crash when open autovivifies glob in freed package");
     like($WARN, qr/^Invalid \\0 character in pathname for chmod: $temp_match\\0\.invalid/,
          "also on chmod"); $WARN = '';
 
-    $TODO = "broken for overloading";
     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 = '';
-    undef $TODO;
 
     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 = '';
 
-    $TODO = "broken for overloading";
     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 = '';
-    undef $TODO;
 
     {
         no warnings 'syscalls';
@@ -465,12 +461,10 @@ pass("no crash when open autovivifies glob in freed package");
     like($WARN, qr/^Invalid \\0 character in pathname for unlink: $temp_match\\0\.invalid/,
          "also on unlink"); $WARN = '';
 
-    $TODO = "broken for overloading";
     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 = '';
 
-    local $TODO = "this is broken for overloading";
     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");