From: Christoph Lamprecht <ch.l.ngre@online.de>
Date: Mon, 11 May 2009 21:00:11 +0000 (-0700)
Subject: do/require don't treat '.\foo' or '..\foo' as "absolute paths" on Windows.
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=36f064bc37569629cfa8ffed15497f849ae8ccfa;p=p5sagit%2Fp5-mst-13.2.git

do/require don't treat '.\foo' or '..\foo' as "absolute paths" on Windows.

Both 'do' and 'require' treat paths *explicitly* relative to the
current directory (starting with './' or '../') as a special form of
absolute path.  That means they can be loaded directly and don't need
to be resolved via @INC, so they don't rely on '.' being in @INC
(unless running in taint mode). This behavior is "documented" in the P5P
thread "Coderefs in @INC" from 2002.

The code is missing special treatment of backslashes on Windows
so that '.\\' and '..\\' are handled in the same manner.

This change fixes

    http://rt.perl.org/rt3/Public/Bug/Display.html?id=63492

(Note that the references to taint mode in the bug report are only
relevant as far as taint mode removes '.' from @INC).

This change also fixes the following Scalar-List-Utils bug report:

    http://rt.cpan.org/Public/Bug/Display.html?id=25430

The Scalar::Util test failure in t/p_tainted.t only manifests itself
under Test::Harness 3, and only outside the Perl core:

* Test::Harness 2 (erroneously) puts '-I.' on the commandline in taint
  mode and runs something like this:

      `perl -I. t/p_tainted.t`

  so '.\t\tainted.t' can be found via '.' in @INC.

* Core Perl runs something like this from the t/ directory:

      `..\perl.exe -I../lib ../ext/List-Util/t/p_tainted.t`

  so '.\..\ext\List-Util\t\tained.t' can be found via '../lib' in @INC.

Signed-off-by: Jan Dubois <jand@activestate.com>
---

diff --git a/AUTHORS b/AUTHORS
index d25c432..3e508da 100644
--- a/AUTHORS
+++ b/AUTHORS
@@ -168,6 +168,7 @@ Chris Pepper
 Chris Wick			<cwick@lmc.com>
 Christian Kirsch		<ck@held.mind.de>
 Christian Winter		<bitpoet@linux-config.de>
+Christoph Lamprecht		<ch.l.ngre@online.de>
 Christophe Grosjean		<christophe.grosjean@gmail.com>
 Christopher Chan-Nui		<channui@austin.ibm.com>
 Christopher Davis		<ckd@loiosh.kei.com>
diff --git a/pp_ctl.c b/pp_ctl.c
index 27a4c03..dc8f0da 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -4935,8 +4935,16 @@ S_path_is_absolute(const char *name)
     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
 
     if (PERL_FILE_IS_ABSOLUTE(name)
+#if WIN32
+	|| (*name == '.' && ((name[1] == '/' ||
+			     (name[1] == '.' && name[2] == '/'))
+			 || (name[1] == '\\' ||
+			     ( name[1] == '.' && name[2] == '\\')))
+	    )
+#else
 	|| (*name == '.' && (name[1] == '/' ||
 			     (name[1] == '.' && name[2] == '/')))
+#endif
 	 )
     {
 	return TRUE;
diff --git a/t/run/switcht.t b/t/run/switcht.t
index 564b2f3..6f0fed5 100644
--- a/t/run/switcht.t
+++ b/t/run/switcht.t
@@ -6,7 +6,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan tests => 11;
+plan tests => 13;
 
 my $Perl = which_perl();
 
@@ -44,3 +44,23 @@ like( $warning, qr/^Insecure dependency in unlink $Tmsg/,
 ok( !-e $file,  'unlink worked' );
 
 ok( !$^W,   "-t doesn't enable regular warnings" );
+
+
+mkdir('tt');
+open(FH,'>','tt/ttest.pl')or DIE $!;
+print FH 'return 42';
+close FH or DIE $!;
+
+SKIP: {
+    ($^O eq 'MSWin32') || skip('skip tainted do test with \ seperator');
+    my $test = 0;
+    $test =  do '.\tt/ttest.pl';
+    is($test, 42, 'Could "do" .\tt/ttest.pl');
+}
+{
+    my $test = 0;
+    $test =  do './tt/ttest.pl';
+    is($test, 42, 'Could "do" ./tt/ttest.pl');
+}
+unlink ('./tt/ttest.pl');
+rmdir ('tt');