[perl #117265] correctly handle overloaded strings

10 files changed, 53 insertions, 48 deletions

diff --git a/doio.c b/doio.c
index d79bf44da7..3988c78873 100644
--- 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 896f709fc9..0f686d46d7 100644
--- 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 3662b97d3a..7e0f83ea7f 100644
--- 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 43904df434..6189b0fa7a 100644
--- 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 a5742b892a..a2727f41a1 100644
--- 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 e4cee6918c..5adc8d495a 100644
--- 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 7de7085d6b..c2cc3197ce 100644
--- 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 7fd27f8531..243bcac7c3 100644
--- 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 88aaa0a6b1..7281242c1c 100644
--- 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 711c27e2f4..3e6efb428e 100644
--- 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");