summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--MANIFEST1
-rw-r--r--embedvar.h3
-rw-r--r--intrpvar.h7
-rw-r--r--lib/Test/Harness.pm4
-rw-r--r--perl.c7
-rw-r--r--perlapi.h2
-rw-r--r--pod/perlrun.pod10
-rwxr-xr-xt/TEST4
-rw-r--r--t/run/switcht.t43
-rw-r--r--taint.c15
10 files changed, 85 insertions, 11 deletions
diff --git a/MANIFEST b/MANIFEST
index c587d2f17c..3f13a5c70b 100644
--- a/MANIFEST
+++ b/MANIFEST
@@ -2313,6 +2313,7 @@ t/run/switchn.t Test the -n switch
t/run/switchp.t Test the -p switch
t/run/switchPx.aux Data for switchPx.t
t/run/switchPx.t Test the -Px combination
+t/run/switcht.t Test the -t switch
t/run/switchx.aux Data for switchx.t
t/run/switchx.t Test the -x switch
t/TEST The regression tester
diff --git a/embedvar.h b/embedvar.h
index dfa0b33185..47d608ccbf 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -399,6 +399,7 @@
#define PL_sv_yes (PERL_GET_INTERP->Isv_yes)
#define PL_svref_mutex (PERL_GET_INTERP->Isvref_mutex)
#define PL_sys_intern (PERL_GET_INTERP->Isys_intern)
+#define PL_taint_warn (PERL_GET_INTERP->Itaint_warn)
#define PL_tainting (PERL_GET_INTERP->Itainting)
#define PL_threadnum (PERL_GET_INTERP->Ithreadnum)
#define PL_threads_mutex (PERL_GET_INTERP->Ithreads_mutex)
@@ -693,6 +694,7 @@
#define PL_sv_yes (vTHX->Isv_yes)
#define PL_svref_mutex (vTHX->Isvref_mutex)
#define PL_sys_intern (vTHX->Isys_intern)
+#define PL_taint_warn (vTHX->Itaint_warn)
#define PL_tainting (vTHX->Itainting)
#define PL_threadnum (vTHX->Ithreadnum)
#define PL_threads_mutex (vTHX->Ithreads_mutex)
@@ -990,6 +992,7 @@
#define PL_Isv_yes PL_sv_yes
#define PL_Isvref_mutex PL_svref_mutex
#define PL_Isys_intern PL_sys_intern
+#define PL_Itaint_warn PL_taint_warn
#define PL_Itainting PL_tainting
#define PL_Ithreadnum PL_threadnum
#define PL_Ithreads_mutex PL_threads_mutex
diff --git a/intrpvar.h b/intrpvar.h
index 501f0d385b..c46c8c1a30 100644
--- a/intrpvar.h
+++ b/intrpvar.h
@@ -4,6 +4,10 @@
/* Don't forget to re-run embed.pl to propagate changes! */
+/* New variables must be added to the very end for binary compatibility.
+ * XSUB.h provides wrapper functions via perlapi.h that make this
+ * irrelevant, but not all code may be expected to #include XSUB.h. */
+
/* The 'I' prefix is only needed for vars that need appropriate #defines
* generated when built with or without MULTIPLICITY. It is also used
* to generate the appropriate export list for win32.
@@ -504,8 +508,9 @@ PERLVARI(Iencoding, SV*, Nullsv) /* character encoding */
PERLVAR(Idebug_pad, struct perl_debug_pad) /* always needed because of the re extension */
+PERLVAR(Itaint_warn, bool) /* taint warns instead of dying */
+
/* New variables must be added to the very end for binary compatibility.
* XSUB.h provides wrapper functions via perlapi.h that make this
* irrelevant, but not all code may be expected to #include XSUB.h. */
-
diff --git a/lib/Test/Harness.pm b/lib/Test/Harness.pm
index de85380f67..26bdf718fa 100644
--- a/lib/Test/Harness.pm
+++ b/lib/Test/Harness.pm
@@ -834,8 +834,8 @@ sub _set_switches {
my $s = $Switches;
$s .= " $ENV{'HARNESS_PERL_SWITCHES'}"
if exists $ENV{'HARNESS_PERL_SWITCHES'};
- $s .= join " ", q[ "-T"], map {qq["-I$_"]} @INC
- if $first =~ /^#!.*\bperl.*-\w*T/;
+ $s .= join " ", qq[ "-$1"], map {qq["-I$_"]} @INC
+ if $first =~ /^#!.*\bperl.*-\w*([tT])/;
close(TEST) or print "can't close $test. $!\n";
diff --git a/perl.c b/perl.c
index cd82fe2ff5..a27620a41d 100644
--- a/perl.c
+++ b/perl.c
@@ -1099,6 +1099,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
goto reswitch;
break;
+ case 't':
+ PL_taint_warn = TRUE;
case 'T':
PL_tainting = TRUE;
s++;
@@ -2373,6 +2375,11 @@ Perl_moreswitches(pTHX_ char *s)
PL_doswitches = TRUE;
s++;
return s;
+ case 't':
+ if (!PL_tainting)
+ Perl_croak(aTHX_ "Too late for \"-t\" option");
+ s++;
+ return s;
case 'T':
if (!PL_tainting)
Perl_croak(aTHX_ "Too late for \"-T\" option");
diff --git a/perlapi.h b/perlapi.h
index dc32def20c..4eb2c4bcca 100644
--- a/perlapi.h
+++ b/perlapi.h
@@ -535,6 +535,8 @@ END_EXTERN_C
#define PL_svref_mutex (*Perl_Isvref_mutex_ptr(aTHX))
#undef PL_sys_intern
#define PL_sys_intern (*Perl_Isys_intern_ptr(aTHX))
+#undef PL_taint_warn
+#define PL_taint_warn (*Perl_Itaint_warn_ptr(aTHX))
#undef PL_tainting
#define PL_tainting (*Perl_Itainting_ptr(aTHX))
#undef PL_threadnum
diff --git a/pod/perlrun.pod b/pod/perlrun.pod
index 4b86d77b51..9de9a3e710 100644
--- a/pod/perlrun.pod
+++ b/pod/perlrun.pod
@@ -4,7 +4,7 @@ perlrun - how to execute the Perl interpreter
=head1 SYNOPSIS
-B<perl> S<[ B<-CsTuUWX> ]>
+B<perl> S<[ B<-CsTtuUWX> ]>
S<[ B<-hv> ] [ B<-V>[:I<configvar>] ]>
S<[ B<-cw> ] [ B<-d>[:I<debugger>] ] [ B<-D>[I<number/list>] ]>
S<[ B<-pna> ] [ B<-F>I<pattern> ] [ B<-l>[I<octal>] ] [ B<-0>[I<octal>] ]>
@@ -697,6 +697,14 @@ separators, it will first be searched for in the current directory
before being searched for on the PATH. On Unix platforms, the
program will be searched for strictly on the PATH.
+=item B<-t>
+
+Like B<-T>, but taint checks will issue warnings rather than fatal
+errors. Since these are warnings, the B<-w> switch (or C<use warnings>)
+must be used along with this option. This is meant only to be used as
+a temporary aid while securing code: for real production code always
+use the real B<-T>.
+
=item B<-T>
forces "taint" checks to be turned on so you can test them. Ordinarily
diff --git a/t/TEST b/t/TEST
index 481cc79d82..4c033d57b3 100755
--- a/t/TEST
+++ b/t/TEST
@@ -166,8 +166,8 @@ EOT
open(SCRIPT,"<$test") or die "Can't run $test.\n";
$_ = <SCRIPT>;
close(SCRIPT) unless ($type eq 'deparse');
- if (/#!.*\bperl.*-\w*T/) {
- $switch = '"-T"';
+ if (/#!.*\bperl.*-\w*([tT])/) {
+ $switch = qq{"-$1"};
}
else {
$switch = '';
diff --git a/t/run/switcht.t b/t/run/switcht.t
new file mode 100644
index 0000000000..bb52252291
--- /dev/null
+++ b/t/run/switcht.t
@@ -0,0 +1,43 @@
+#!./perl -tw
+
+BEGIN {
+ chdir 't';
+ @INC = '../lib';
+ require './test.pl';
+}
+
+plan tests => 10;
+
+my $Perl = which_perl();
+
+my $warning;
+local $SIG{__WARN__} = sub { $warning = join "\n", @_; };
+my $Tmsg = 'while running with -t switch';
+
+ok( ${^TAINT}, '${^TAINT} defined' );
+
+my $out = `$Perl -le "print q{Hello}"`;
+is( $out, "Hello\n", '`` worked' );
+like( $warning, qr/^Insecure .* $Tmsg/, ' taint warn' );
+
+{
+ no warnings 'taint';
+ $warning = '';
+ my $out = `$Perl -le "print q{Hello}"`;
+ is( $out, "Hello\n", '`` worked' );
+ is( $warning, '', ' no warnings "taint"' );
+}
+
+# Get ourselves a tainted variable.
+$file = $0;
+$file =~ s/.*/some.tmp/;
+ok( open(FILE, ">$file"), 'open >' ) or DIE $!;
+print FILE "Stuff\n";
+close FILE;
+like( $warning, qr/^Insecure dependency in open $Tmsg/, 'open > taint warn' );
+ok( -e $file, ' file written' );
+
+unlink($file);
+like( $warning, qr/^Insecure dependency in unlink $Tmsg/,
+ 'unlink() taint warn' );
+ok( !-e $file, 'unlink worked' );
diff --git a/taint.c b/taint.c
index 1ce27e324f..9bf00bcf07 100644
--- a/taint.c
+++ b/taint.c
@@ -25,12 +25,17 @@ Perl_taint_proper(pTHX_ const char *f, const char *s)
ug = " while running setuid";
else if (PL_egid != PL_gid)
ug = " while running setgid";
- else
+ else if (PL_taint_warn)
+ ug = " while running with -t switch";
+ else
ug = " while running with -T switch";
- if (!PL_unsafe)
- Perl_croak(aTHX_ f, s, ug);
- else if (ckWARN(WARN_TAINT))
- Perl_warner(aTHX_ WARN_TAINT, f, s, ug);
+ if (PL_unsafe || PL_taint_warn) {
+ if(ckWARN(WARN_TAINT))
+ Perl_warner(aTHX_ WARN_TAINT, f, s, ug);
+ }
+ else {
+ Perl_croak(aTHX_ f, s, ug);
+ }
}
}
View Lorry Controller Status