diff options
| -rw-r--r-- | gv.c | 8 | ||||
| -rw-r--r-- | mg.c | 10 | ||||
| -rw-r--r-- | pod/perlvar.pod | 5 | ||||
| -rwxr-xr-x | t/op/magic.t | 6 | ||||
| -rwxr-xr-x | t/op/taint.t | 23 |
5 files changed, 46 insertions, 6 deletions
@@ -893,7 +893,6 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) case '\011': /* $^I, NOT \t in EBCDIC */ case '\016': /* $^N */ case '\020': /* $^P */ - case '\024': /* $^T */ if (len > 1) break; goto magicalize; @@ -910,6 +909,13 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type) if (len > 1) break; goto ro_magicalize; + case '\024': /* $^T */ + if (len == 1) + goto magicalize; + else if (strEQ(name, "\024AINT")) + goto ro_magicalize; + else + break; case '\027': /* $^W & $^WARNING_BITS */ if (len > 1 && strNE(name, "\027ARNING_BITS") && strNE(name, "\027IDE_SYSTEM_CALLS")) @@ -612,12 +612,16 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) } break; case '\024': /* ^T */ + if (*(mg->mg_ptr+1) == '\0') { #ifdef BIG_TIME - sv_setnv(sv, PL_basetime); + sv_setnv(sv, PL_basetime); #else - sv_setiv(sv, (IV)PL_basetime); + sv_setiv(sv, (IV)PL_basetime); #endif - break; + } + else if (strEQ(mg->mg_ptr, "\024AINT")) + sv_setiv(sv, PL_tainting); + break; case '\027': /* ^W & $^WARNING_BITS & ^WIDE_SYSTEM_CALLS */ if (*(mg->mg_ptr+1) == '\0') sv_setiv(sv, (IV)((PL_dowarn & G_WARN_ON) ? TRUE : FALSE)); diff --git a/pod/perlvar.pod b/pod/perlvar.pod index 6f9bd8d3a6..aec8215753 100644 --- a/pod/perlvar.pod +++ b/pod/perlvar.pod @@ -1039,6 +1039,11 @@ The time at which the program began running, in seconds since the epoch (beginning of 1970). The values returned by the B<-M>, B<-A>, and B<-C> filetests are based on this value. +=item ${^TAINT} + +Reflects if taint mode is on or off (ie. if the program was run with +B<-T> or not). True for on, false for off. + =item $PERL_VERSION =item $^V diff --git a/t/op/magic.t b/t/op/magic.t index bbccd8e9e3..20d973b403 100755 --- a/t/op/magic.t +++ b/t/op/magic.t @@ -35,7 +35,7 @@ sub skip { return 1; } -print "1..41\n"; +print "1..43\n"; $Is_MSWin32 = $^O eq 'MSWin32'; $Is_NetWare = $^O eq 'NetWare'; @@ -283,3 +283,7 @@ ok ${"!"}{ENOENT}; ok $^S == 0; eval { ok $^S == 1 }; ok $^S == 0; + +ok ${^TAINT} == 0; +eval { ${^TAINT} = 1 }; +ok ${^TAINT} == 0; diff --git a/t/op/taint.t b/t/op/taint.t index 8ae8202966..d010afea99 100755 --- a/t/op/taint.t +++ b/t/op/taint.t @@ -15,6 +15,20 @@ BEGIN { use strict; use Config; +my $test = 177; +sub ok { + my($ok, $name) = @_; + + # You have to do it this way or VMS will get confused. + print $ok ? "ok $test - $name\n" : "not ok $test - $name\n"; + + printf "# Failed test at line %d\n", (caller)[2] unless $ok; + + $test++; + return $ok; +} + + $| = 1; # We do not want the whole taint.t to fail @@ -109,7 +123,7 @@ print PROG 'print "@ARGV\n"', "\n"; close PROG; my $echo = "$Invoke_Perl $ECHO"; -print "1..176\n"; +print "1..179\n"; # First, let's make sure that Perl is checking the dangerous # environment variables. Maybe they aren't set yet, so we'll @@ -885,3 +899,10 @@ else { } +ok( ${^TAINT}, '$^TAINT is on' ); + +eval { ${^TAINT} = 0 }; +ok( ${^TAINT}, '$^TAINT is not assignable' ); +ok( $@ =~ /^Modification of a read-only value attempted/, + 'Assigning to taint pukes properly' ); + |