-t taint warnings

Message-ID: <20011214002707.GA10532@blackrider>

(reword the perlrun -t description a bit,
 and move the Itaint_warn to the bottom of
 the intrpvar.h for binary compatibility)

p4raw-id: //depot/perl@13684

diff --git a/MANIFEST b/MANIFEST
index c587d2f..3f13a5c 100644 (file)
--- 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 dfa0b33..47d608c 100644 (file)
--- 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 501f0d3..c46c8c1 100644 (file)
--- 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 de85380..26bdf71 100644 (file)
--- 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 cd82fe2..a27620a 100644 (file)
--- 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 dc32def..4eb2c4b 100644 (file)
--- 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 4b86d77..9de9a3e 100644 (file)
--- 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 481cc79..4c033d5 100755 (executable)
--- 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 (file)
index 0000000..bb52252
--- /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 1ce27e3..9bf00bc 100644 (file)
--- 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);
+        }
     }
 }