Fix checks for tainted dir in $ENV{PATH}

$ cat > foo
#!/usr/bin/perl
print "What?!\n"
^D
$ chmod +x foo
$ ./perl -Ilib -Te '$ENV{PATH}="."; exec "foo"'
Insecure directory in $ENV{PATH} while running with -T switch at -e line 1.

That is what I expect to see.  But:

$ ./perl -Ilib -Te '$ENV{PATH}="/\\:."; exec "foo"'
What?!

Perl is allowing the \ to escape the :, but the \ is not treated as an
escape by the system, allowing a relative path in PATH to be consid-
ered safe.

6 files changed, 48 insertions, 5 deletions

diff --git a/embed.fnc b/embed.fnc
index 6601c5490d..c547b56d78 100644
--- a/embed.fnc
+++ b/embed.fnc
@@ -366,6 +366,10 @@ Ap	|I32	|debstackptrs
 pR	|SV *	|defelem_target	|NN SV *sv|NULLOK MAGIC *mg
 Anp	|char*	|delimcpy	|NN char* to|NN const char* toend|NN const char* from \
 				|NN const char* fromend|int delim|NN I32* retlen
+np	|char*	|delimcpy_no_escape|NN char* to|NN const char* toend \
+				   |NN const char* from \
+				   |NN const char* fromend|int delim \
+				   |NN I32* retlen
 : Used in op.c, perl.c
 pM	|void	|delete_eval_scope
 Aprd	|OP*    |die_sv         |NN SV *baseex
diff --git a/embed.h b/embed.h
index 8220ab567d..8be5109a28 100644
--- a/embed.h
+++ b/embed.h
@@ -1216,6 +1216,7 @@
 #define deb_stack_all()		Perl_deb_stack_all(aTHX)
 #define defelem_target(a,b)	Perl_defelem_target(aTHX_ a,b)
 #define delete_eval_scope()	Perl_delete_eval_scope(aTHX)
+#define delimcpy_no_escape	Perl_delimcpy_no_escape
 #define die_unwind(a)		Perl_die_unwind(aTHX_ a)
 #define do_aexec5(a,b,c,d,e)	Perl_do_aexec5(aTHX_ a,b,c,d,e)
 #define do_dump_pad(a,b,c,d)	Perl_do_dump_pad(aTHX_ a,b,c,d)
diff --git a/mg.c b/mg.c
index 874933f6ff..8b182e6f24 100644
--- a/mg.c
+++ b/mg.c
@@ -1217,7 +1217,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg)
 #else
 		const char path_sep = ':';
 #endif
-		s = delimcpy(tmpbuf, tmpbuf + sizeof tmpbuf,
+		s = delimcpy_no_escape(tmpbuf, tmpbuf + sizeof tmpbuf,
 			     s, strend, path_sep, &i);
 		s++;
 		if (i >= (I32)sizeof tmpbuf   /* too long -- assume the worst */
diff --git a/proto.h b/proto.h
index 9a4fa58459..908deb2b00 100644
--- a/proto.h
+++ b/proto.h
@@ -664,6 +664,9 @@ PERL_CALLCONV void	Perl_delete_eval_scope(pTHX);
 PERL_CALLCONV char*	Perl_delimcpy(char* to, const char* toend, const char* from, const char* fromend, int delim, I32* retlen);
 #define PERL_ARGS_ASSERT_DELIMCPY	\
 	assert(to); assert(toend); assert(from); assert(fromend); assert(retlen)
+PERL_CALLCONV char*	Perl_delimcpy_no_escape(char* to, const char* toend, const char* from, const char* fromend, int delim, I32* retlen);
+#define PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE	\
+	assert(to); assert(toend); assert(from); assert(fromend); assert(retlen)
 PERL_CALLCONV void	Perl_despatch_signals(pTHX);
 PERL_CALLCONV_NO_RET OP*	Perl_die(pTHX_ const char* pat, ...)
 			__attribute__noreturn__
diff --git a/t/op/taint.t b/t/op/taint.t
index 38a3952366..ca0a58b052 100644
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -17,7 +17,7 @@ BEGIN {
 use strict;
 use Config;
 
-plan tests => 808;
+plan tests => 812;
 
 $| = 1;
 
@@ -187,6 +187,22 @@ my $TEST = 'TEST';
 	like($@, qr/^Insecure (?:directory in )?\$ENV\{PATH}/);
     }
 
+    # Relative paths in $ENV{PATH} are always implicitly tainted.
+    SKIP: {
+        skip "Do these work on VMS?", 4 if $Is_VMS;
+        skip "Not applicable to DOSish systems", 4 if! $tmp;
+
+        local $ENV{PATH} = '.';
+        is(eval { `$echo 1` }, undef);
+        like($@, qr/^Insecure (?:directory in )?\$ENV\{PATH}/);
+
+        # Backslash should not fool perl into thinking that this is one
+        # path.
+        local $ENV{PATH} = '/\:.';
+        is(eval { `$echo 1` }, undef);
+        like($@, qr/^Insecure (?:directory in )?\$ENV\{PATH}/);
+    }
+
     SKIP: {
         skip "This is not VMS", 4 unless $Is_VMS;
 
diff --git a/util.c b/util.c
index 8bc34ccf7b..0f5533ebf9 100644
--- a/util.c
+++ b/util.c
@@ -524,15 +524,17 @@ Free_t   Perl_mfree (Malloc_t where)
 
 /* copy a string up to some (non-backslashed) delimiter, if any */
 
-char *
-Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
+static char *
+S_delimcpy(char *to, const char *toend, const char *from,
+	   const char *fromend, int delim, I32 *retlen,
+	   const bool allow_escape)
 {
     I32 tolen;
 
     PERL_ARGS_ASSERT_DELIMCPY;
 
     for (tolen = 0; from < fromend; from++, tolen++) {
-	if (*from == '\\') {
+	if (allow_escape && *from == '\\') {
 	    if (from[1] != delim) {
 		if (to < toend)
 		    *to++ = *from;
@@ -551,6 +553,23 @@ Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend
     return (char *)from;
 }
 
+char *
+Perl_delimcpy(char *to, const char *toend, const char *from, const char *fromend, int delim, I32 *retlen)
+{
+    PERL_ARGS_ASSERT_DELIMCPY;
+
+    return S_delimcpy(to, toend, from, fromend, delim, retlen, 1);
+}
+
+char *
+Perl_delimcpy_no_escape(char *to, const char *toend, const char *from,
+			const char *fromend, int delim, I32 *retlen)
+{
+    PERL_ARGS_ASSERT_DELIMCPY_NO_ESCAPE;
+
+    return S_delimcpy(to, toend, from, fromend, delim, retlen, 0);
+}
+
 /*
 =head1 Miscellaneous Functions