From: Michael G. Schwern <schwern@pobox.com>
Date: Sun, 18 Feb 2001 01:11:35 +0000 (-0500)
Subject: Fixing PERL5OPT (was Re: Warnings, strict, and CPAN)
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4ea8f8fb25afd51f8653b84174abb95c1382d5ec;p=p5sagit%2Fp5-mst-13.2.git

Fixing PERL5OPT (was Re: Warnings, strict, and CPAN)
Message-ID: <20010218011135.A19957@magnonel.guild.net>

Revive mjd's and Simon's PERL5OPT fix.

p4raw-id: //depot/perl@8822
---

diff --git a/MANIFEST b/MANIFEST
index edc5467..77f921e 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -1715,6 +1715,7 @@ t/pragma/warn/universal	Tests for universal.c for warnings.t
 t/pragma/warn/utf8	Tests for utf8.c for warnings.t
 t/pragma/warn/util	Tests for util.c for warnings.t
 t/pragma/warnings.t	See if warning controls work
+t/run/runenv.t		Test if perl honors its environment variables.
 taint.c			Tainting code
 thrdvar.h		Per-thread variables
 thread.h		Threading header
diff --git a/perl.c b/perl.c
index 8d8dc1f..7dc4902 100644
--- a/perl.c
+++ b/perl.c
@@ -1173,6 +1173,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
 	    PL_tainting = TRUE;
 	else {
 	    while (s && *s) {
+	        char *d;
 		while (isSPACE(*s))
 		    s++;
 		if (*s == '-') {
@@ -1180,11 +1181,18 @@ print \"  \\@INC:\\n    @INC\\n\";");
 		    if (isSPACE(*s))
 			continue;
 		}
+		d = s;
 		if (!*s)
 		    break;
 		if (!strchr("DIMUdmw", *s))
 		    Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
-		s = moreswitches(s);
+		while (++s && *s) {
+		    if (isSPACE(*s)) {
+		        *s++ = '\0';
+			break;
+		    }
+		}
+		moreswitches(d);
 	    }
 	}
     }
diff --git a/t/run/runenv.t b/t/run/runenv.t
new file mode 100644
index 0000000..736e48f
--- /dev/null
+++ b/t/run/runenv.t
@@ -0,0 +1,137 @@
+#!./perl
+#
+# Tests for Perl run-time environment variable settings
+#
+# $PERL5OPT, $PERL5LIB, etc.
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+my $STDOUT = './results-0';
+my $STDERR = './results-1';
+my $PERL = './perl';
+my $FAILURE_CODE = 119;
+
+print "1..9\n";
+
+# Run perl with specified environment and arguments returns a list.
+# First element is true iff Perl's stdout and stderr match the
+# supplied $stdout and $stderr argument strings exactly.
+# second element is an explanation of the failure
+sub runperl {
+  local *F;
+  my ($env, $args, $stdout, $stderr) = @_;
+
+  unshift @$args, '-I../lib';
+
+  $stdout = '' unless defined $stdout;
+  $stderr = '' unless defined $stderr;
+  my $pid = fork;
+  return (0, "Couldn't fork: $!") unless defined $pid;   # failure
+  if ($pid) {                   # parent
+    my ($actual_stdout, $actual_stderr);
+    wait;
+    return (0, "Failure in child.\n") if ($?>>8) == $FAILURE_CODE;
+
+    open F, "< $STDOUT" or return (0, "Couldn't read $STDOUT file");
+    { local $/; $actual_stdout = <F> }
+    open F, "< $STDERR" or return (0, "Couldn't read $STDERR file");
+    { local $/; $actual_stderr = <F> }
+
+    if ($actual_stdout ne $stdout) {
+      return (0, "Stdout mismatch: expected [$stdout], saw [$actual_stdout]");
+    } elsif ($actual_stderr ne $stderr) {
+      return (0, "Stderr mismatch: expected [$stderr], saw [$actual_stderr]");
+    } else {
+      return 1;                 # success
+    }
+  } else {                      # child
+    for my $k (keys %$env) {
+      $ENV{$k} = $env->{$k};
+    }
+    open STDOUT, "> $STDOUT" or exit $FAILURE_CODE;
+    open STDERR, "> $STDERR" or it_didnt_work();
+    { exec $PERL, @$args }
+    it_didnt_work();
+  }
+}
+
+
+sub it_didnt_work {
+    print STDOUT "IWHCWJIHCI\cNHJWCJQWKJQJWCQW\n";
+    exit $FAILURE_CODE;
+}
+
+sub try {
+  my $testno = shift;
+  my ($success, $reason) = runperl(@_);
+  if ($success) {
+    print "ok $testno\n";
+  } else {
+    $reason =~ s/\n/\\n/g;
+    print "not ok $testno # $reason\n";    
+  }
+}
+
+#  PERL5OPT    Command-line options (switches).  Switches in
+#                    this variable are taken as if they were on
+#                    every Perl command line.  Only the -[DIMUdmw]
+#                    switches are allowed.  When running taint
+#                    checks (because the program was running setuid
+#                    or setgid, or the -T switch was used), this
+#                    variable is ignored.  If PERL5OPT begins with
+#                    -T, tainting will be enabled, and any
+#                    subsequent options ignored.
+
+my  $T = 1;
+try($T++, {PERL5OPT => '-w'}, ['-e', 'print $::x'],
+    "", 
+    qq{Name "main::x" used only once: possible typo at -e line 1.\nUse of uninitialized value in print at -e line 1.\n});
+
+try($T++, {PERL5OPT => '-Mstrict'}, ['-e', 'print $::x'],
+    "", "");
+
+try($T++, {PERL5OPT => '-Mstrict'}, ['-e', 'print $x'],
+    "", 
+    qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
+
+# Fails in 5.6.0
+try($T++, {PERL5OPT => '-Mstrict -w'}, ['-e', 'print $x'],
+    "", 
+    qq{Global symbol "\$x" requires explicit package name at -e line 1.\nExecution of -e aborted due to compilation errors.\n});
+
+# Fails in 5.6.0
+try($T++, {PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
+    "", 
+    <<ERROR
+Name "main::x" used only once: possible typo at -e line 1.
+Use of uninitialized value in print at -e line 1.
+ERROR
+    );
+
+# Fails in 5.6.0
+try($T++, {PERL5OPT => '-w -Mstrict'}, ['-e', 'print $::x'],
+    "", 
+    <<ERROR
+Name "main::x" used only once: possible typo at -e line 1.
+Use of uninitialized value in print at -e line 1.
+ERROR
+    );
+
+try($T++, {PERL5OPT => '-MExporter'}, ['-e0'],
+    "", 
+    "");
+
+# Fails in 5.6.0
+try($T++, {PERL5OPT => '-MExporter -MExporter'}, ['-e0'],
+    "", 
+    "");
+
+try($T++, {PERL5OPT => '-Mstrict -Mwarnings'}, 
+    ['-e', 'print "ok" if $INC{"strict.pm"} and $INC{"warnings.pm"}'],
+    "ok",
+    "");
+
+print "# ", $T-1, " tests total.\n";