diff options
| -rw-r--r-- | dist/Cwd/t/taint.t | 9 | ||||
| -rw-r--r-- | dist/IO/t/io_taint.t | 5 | ||||
| -rw-r--r-- | dist/Locale-Maketext/t/09_compile.t | 3 | ||||
| -rw-r--r-- | doio.c | 4 | ||||
| -rw-r--r-- | doop.c | 2 | ||||
| -rw-r--r-- | dump.c | 4 | ||||
| -rw-r--r-- | ext/Devel-Peek/t/Peek.t | 6 | ||||
| -rw-r--r-- | ext/File-Glob/t/taint.t | 9 | ||||
| -rw-r--r-- | ext/POSIX/t/taint.t | 11 | ||||
| -rw-r--r-- | hv.c | 6 | ||||
| -rw-r--r-- | lib/File/Basename.t | 4 | ||||
| -rw-r--r-- | lib/File/Find/t/taint.t | 11 | ||||
| -rw-r--r-- | mg.c | 12 | ||||
| -rw-r--r-- | op.c | 10 | ||||
| -rw-r--r-- | os2/os2.c | 2 | ||||
| -rw-r--r-- | pad.c | 2 | ||||
| -rw-r--r-- | perl.c | 85 | ||||
| -rw-r--r-- | perl.h | 50 | ||||
| -rw-r--r-- | perlio.c | 6 | ||||
| -rw-r--r-- | pp_ctl.c | 20 | ||||
| -rw-r--r-- | pp_hot.c | 34 | ||||
| -rw-r--r-- | pp_sys.c | 12 | ||||
| -rw-r--r-- | regcomp.c | 16 | ||||
| -rw-r--r-- | regexp.h | 8 | ||||
| -rw-r--r-- | scope.c | 9 | ||||
| -rw-r--r-- | sv.c | 9 | ||||
| -rw-r--r-- | sv.h | 14 | ||||
| -rw-r--r-- | taint.c | 22 | ||||
| -rw-r--r-- | utf8.c | 6 | ||||
| -rw-r--r-- | util.c | 8 | ||||
| -rw-r--r-- | vms/vms.c | 6 |
31 files changed, 277 insertions, 128 deletions
diff --git a/dist/Cwd/t/taint.t b/dist/Cwd/t/taint.t index 60cbfebc41..309b3e5dfc 100644 --- a/dist/Cwd/t/taint.t +++ b/dist/Cwd/t/taint.t @@ -8,7 +8,14 @@ chdir 't' unless $ENV{PERL_CORE}; use File::Spec; use lib File::Spec->catdir('t', 'lib'); -use Test::More tests => 17; +use Test::More; +BEGIN { + plan( + ${^TAINT} + ? (tests => 17) + : (skip_all => "A perl without taint support") + ); +} use Scalar::Util qw/tainted/; diff --git a/dist/IO/t/io_taint.t b/dist/IO/t/io_taint.t index 3cbe30345f..5740353e77 100644 --- a/dist/IO/t/io_taint.t +++ b/dist/IO/t/io_taint.t @@ -3,7 +3,10 @@ use Config; BEGIN { - if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') { + if ($ENV{PERL_CORE} + and $Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS' + or not ${^TAINT}) # not ${^TAINT} => perl without taint support + { print "1..0\n"; exit 0; } diff --git a/dist/Locale-Maketext/t/09_compile.t b/dist/Locale-Maketext/t/09_compile.t index 06db4849f0..d03ba9fa14 100644 --- a/dist/Locale-Maketext/t/09_compile.t +++ b/dist/Locale-Maketext/t/09_compile.t @@ -13,7 +13,8 @@ my $tainted_value; do { $tainted_value = shift @ENV_values } while(!$tainted_value || ref $tainted_value); $tainted_value =~ s/([\[\]])/~$1/g; -ok(tainted($tainted_value), "\$tainted_value is tainted") or die('huh... %ENV has no entries? I don\'t know how to test taint without it'); +# If ${^TAINT} is not set despite -T, thsi perl doesn't have taint support +ok(!${^TAINT} || tainted($tainted_value), "\$tainted_value is tainted") or die('huh... %ENV has no entries? I don\'t know how to test taint without it'); my $result = Locale::Maketext::_compile("hello [_1]", $tainted_value); @@ -1599,11 +1599,11 @@ Perl_apply(pTHX_ I32 type, register SV **mark, register SV **sp) #define APPLY_TAINT_PROPER() \ STMT_START { \ - if (PL_tainted) { TAINT_PROPER(what); } \ + if (TAINT_get) { TAINT_PROPER(what); } \ } STMT_END /* This is a first heuristic; it doesn't catch tainting magic. */ - if (PL_tainting) { + if (TAINTING_get) { while (++mark <= sp) { if (SvTAINTED(*mark)) { TAINT; @@ -707,7 +707,7 @@ Perl_do_join(pTHX_ register SV *sv, SV *delim, register SV **mark, register SV * /* sv_setpv retains old UTF8ness [perl #24846] */ SvUTF8_off(sv); - if (PL_tainting && SvMAGICAL(sv)) + if (TAINTING_get && SvMAGICAL(sv)) SvTAINTED_off(sv); if (items-- > 0) { @@ -581,7 +581,7 @@ Perl_sv_peek(pTHX_ SV *sv) finish: while (unref--) sv_catpv(t, ")"); - if (PL_tainting && SvTAINTED(sv)) + if (TAINTING_get && SvTAINTED(sv)) sv_catpv(t, " [tainted]"); return SvPV_nolen(t); } @@ -664,7 +664,7 @@ S_pm_description(pTHX_ const PMOP *pm) #endif if (regex) { - if (RX_EXTFLAGS(regex) & RXf_TAINTED) + if (RX_ISTAINTED(regex)) sv_catpv(desc, ",TAINTED"); if (RX_CHECK_SUBSTR(regex)) { if (!(RX_EXTFLAGS(regex) & RXf_NOSCAN)) diff --git a/ext/Devel-Peek/t/Peek.t b/ext/Devel-Peek/t/Peek.t index 11217b0aac..c9af2d272b 100644 --- a/ext/Devel-Peek/t/Peek.t +++ b/ext/Devel-Peek/t/Peek.t @@ -550,8 +550,9 @@ do_test('scalar with pos magic', # VMS is setting FAKE and READONLY flags. What VMS uses for storing # ENV hashes is also not always null terminated. # -do_test('tainted value in %ENV', - $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value +if (${^TAINT}) { + do_test('tainted value in %ENV', + $ENV{PATH}=@ARGV, # scalar(@ARGV) is a handy known tainted value 'SV = PVMG\\($ADDR\\) at $ADDR REFCNT = 1 FLAGS = \\(GMG,SMG,RMG(?:,POK)?(?:,pIOK)?,pPOK\\) @@ -577,6 +578,7 @@ do_test('tainted value in %ENV', MAGIC = $ADDR MG_VIRTUAL = &PL_vtbl_taint MG_TYPE = PERL_MAGIC_taint\\(t\\)'); +} do_test('blessed reference', bless(\\undef, 'Foobar'), diff --git a/ext/File-Glob/t/taint.t b/ext/File-Glob/t/taint.t index 3f49836bce..aab379b5bf 100644 --- a/ext/File-Glob/t/taint.t +++ b/ext/File-Glob/t/taint.t @@ -10,7 +10,14 @@ BEGIN { } } -use Test::More tests => 2; +use Test::More; +BEGIN { + plan( + ${^TAINT} + ? (skip_all => "Appear to running a perl without taint support") + : (tests => 2) + ); +} BEGIN { use_ok('File::Glob'); diff --git a/ext/POSIX/t/taint.t b/ext/POSIX/t/taint.t index 3ca01743e0..5a960c714b 100644 --- a/ext/POSIX/t/taint.t +++ b/ext/POSIX/t/taint.t @@ -8,9 +8,16 @@ BEGIN { } } -use Test::More tests => 7; -use Scalar::Util qw/tainted/; +use Test::More; +BEGIN { + plan( + ${^TAINT} + ? (tests => 7) + : (skip_all => "A perl without taint support") + ); +} +use Scalar::Util qw/tainted/; use POSIX qw(fcntl_h open read mkfifo); use strict ; @@ -526,13 +526,13 @@ Perl_hv_common(pTHX_ HV *hv, SV *keysv, const char *key, STRLEN klen, bool needs_store; hv_magic_check (hv, &needs_copy, &needs_store); if (needs_copy) { - const bool save_taint = PL_tainted; + const bool save_taint = TAINT_get; /* Unused var warning under NO_TAINT_SUPPORT */ if (keysv || is_utf8) { if (!keysv) { keysv = newSVpvn_utf8(key, klen, TRUE); } - if (PL_tainting) - PL_tainted = SvTAINTED(keysv); + if (TAINTING_get) + TAINT_set(SvTAINTED(keysv)); keysv = sv_2mortal(newSVsv(keysv)); mg_copy(MUTABLE_SV(hv), val, (char*)keysv, HEf_SVKEY); } else { diff --git a/lib/File/Basename.t b/lib/File/Basename.t index 0d3b633669..6ff3121ec9 100644 --- a/lib/File/Basename.t +++ b/lib/File/Basename.t @@ -154,7 +154,9 @@ can_ok( __PACKAGE__, qw( basename fileparse dirname fileparse_set_fstype ) ); ### Test tainting -{ +SKIP: { + skip "A perl without taint support", 2 + if not ${^TAINT}; # The empty tainted value, for tainting strings my $TAINT = substr($^X, 0, 0); diff --git a/lib/File/Find/t/taint.t b/lib/File/Find/t/taint.t index d47b21a7c3..f696a438a9 100644 --- a/lib/File/Find/t/taint.t +++ b/lib/File/Find/t/taint.t @@ -1,12 +1,19 @@ #!./perl -T use strict; +use Test::More; +BEGIN { + plan( + ${^TAINT} + ? (skip_all => "A perl without taint support") + : (tests => 45) + ); +} my %Expect_File = (); # what we expect for $_ my %Expect_Name = (); # what we expect for $File::Find::name/fullname my %Expect_Dir = (); # what we expect for $File::Find::dir my ($cwd, $cwd_untainted); - BEGIN { require File::Spec; chdir 't' if -d 't'; @@ -42,8 +49,6 @@ BEGIN { $ENV{'PATH'} = join($sep,@path); } -use Test::More tests => 45; - my $symlink_exists = eval { symlink("",""); 1 }; use File::Find; @@ -876,8 +876,8 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg) #endif } else if (strEQ(remaining, "AINT")) - sv_setiv(sv, PL_tainting - ? (PL_taint_warn || PL_unsafe ? -1 : 1) + sv_setiv(sv, TAINTING_get + ? (TAINT_WARN_get || PL_unsafe ? -1 : 1) : 0); break; case '\025': /* $^UNICODE, $^UTF8LOCALE, $^UTF8CACHE */ @@ -1132,7 +1132,7 @@ Perl_magic_setenv(pTHX_ SV *sv, MAGIC *mg) #if !defined(OS2) && !defined(AMIGAOS) && !defined(WIN32) && !defined(MSDOS) /* And you'll never guess what the dog had */ /* in its mouth... */ - if (PL_tainting) { + if (TAINTING_get) { MgTAINTEDDIR_off(mg); #ifdef VMS if (s && klen == 8 && strEQ(key, "DCL$PATH")) { @@ -1832,7 +1832,7 @@ Perl_magic_setpack(pTHX_ SV *sv, MAGIC *mg) * fake up a temporary tainted value (this is easier than temporarily * re-enabling magic on sv). */ - if (PL_tainting && (tmg = mg_find(sv, PERL_MAGIC_taint)) + if (TAINTING_get && (tmg = mg_find(sv, PERL_MAGIC_taint)) && (tmg->mg_len & 1)) { val = sv_mortalcopy(sv); @@ -2233,7 +2233,7 @@ Perl_magic_settaint(pTHX_ SV *sv, MAGIC *mg) PERL_UNUSED_ARG(sv); /* update taint status */ - if (PL_tainted) + if (TAINT_get) mg->mg_len |= 1; else mg->mg_len &= ~1; @@ -2493,7 +2493,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg) } } /* mg_set() has temporarily made sv non-magical */ - if (PL_tainting) { + if (TAINTING_get) { if ((tmg = mg_find(sv,PERL_MAGIC_taint)) && tmg->mg_len & 1) SvTAINTED_on(PL_bodytarget); else @@ -2831,7 +2831,7 @@ Perl_op_scope(pTHX_ OP *o) { dVAR; if (o) { - if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || PL_tainting) { + if (o->op_flags & OPf_PARENS || PERLDB_NOOPT || TAINTING_get) { o = op_prepend_elem(OP_LINESEQ, newOP(OP_ENTER, 0), o); o->op_type = OP_LEAVE; o->op_ppaddr = PL_ppaddr[OP_LEAVE]; @@ -4677,8 +4677,8 @@ Perl_pmruntime(pTHX_ OP *o, OP *expr, bool isreg, I32 floor) * preceding stacking ops; * OP_REGCRESET is there to reset taint before executing the * stacking ops */ - if (pm->op_pmflags & PMf_KEEP || PL_tainting) - expr = newUNOP((PL_tainting ? OP_REGCRESET : OP_REGCMAYBE),0,expr); + if (pm->op_pmflags & PMf_KEEP || TAINTING_get) + expr = newUNOP((TAINTING_get ? OP_REGCRESET : OP_REGCMAYBE),0,expr); if (pm->op_pmflags & PMf_HAS_CV) { /* we have a runtime qr with literal code. This means @@ -9094,9 +9094,9 @@ Perl_ck_index(pTHX_ OP *o) if (kid) kid = kid->op_sibling; /* get past "big" */ if (kid && kid->op_type == OP_CONST) { - const bool save_taint = PL_tainted; + const bool save_taint = TAINT_get; /* accepted unused var warning if NO_TAINT_SUPPORT */ fbm_compile(((SVOP*)kid)->op_sv, 0); - PL_tainted = save_taint; + TAINT_set(save_taint); } } return ck_fun(o); @@ -1568,7 +1568,7 @@ my_syspopen4(pTHX_ char *cmd, char *mode, I32 cnt, SV** args) /* `this' is what we use in the parent, `that' in the child. */ this = (*mode == 'w'); that = !this; - if (PL_tainting) { + if (TAINTING_get) { taint_env(); taint_proper("Insecure %s%s", "EXEC"); } @@ -1669,7 +1669,7 @@ S_pad_reset(pTHX) ) ); - if (!PL_tainting) { /* Can't mix tainted and non-tainted temporaries. */ + if (!TAINTING_get) { /* Can't mix tainted and non-tainted temporaries. */ I32 po; for (po = AvMAX(PL_comppad); po > PL_padix_floor; po--) { if (PL_curpad[po] && !SvIMMORTAL(PL_curpad[po])) @@ -1230,8 +1230,8 @@ perl_destruct(pTHXx) Safefree(psig_save); } nuke_stacks(); - PL_tainting = FALSE; - PL_taint_warn = FALSE; + TAINTING_set(FALSE); + TAINT_WARN_set(FALSE); PL_hints = 0; /* Reset hints. Should hints be per-interpreter ? */ PL_debug = 0; @@ -1594,7 +1594,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) PL_do_undump = FALSE; cxstack_ix = -1; /* start label stack again */ init_ids(); - assert (!PL_tainted); + assert (!TAINT_get); TAINT; S_set_caret_X(aTHX); TAINT_NOT; @@ -1832,17 +1832,31 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) break; case 't': +#if SILENT_NO_TAINT_SUPPORT + /* silently ignore */ +#elif NO_TAINT_SUPPORT + Perl_croak("This perl was compiled without taint support. " + "Cowardly refusing to run with -t or -T flags"); +#else CHECK_MALLOC_TOO_LATE_FOR('t'); - if( !PL_tainting ) { - PL_taint_warn = TRUE; - PL_tainting = TRUE; + if( !TAINTING_get ) { + TAINT_WARN_set(TRUE); + TAINTING_set(TRUE); } +#endif s++; goto reswitch; case 'T': +#if SILENT_NO_TAINT_SUPPORT + /* silently ignore */ +#elif NO_TAINT_SUPPORT + Perl_croak("This perl was compiled without taint support. " + "Cowardly refusing to run with -t or -T flags"); +#else CHECK_MALLOC_TOO_LATE_FOR('T'); - PL_tainting = TRUE; - PL_taint_warn = FALSE; + TAINTING_set(TRUE); + TAINT_WARN_set(FALSE); +#endif s++; goto reswitch; @@ -1943,16 +1957,23 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) if ( #ifndef SECURE_INTERNAL_GETENV - !PL_tainting && + !TAINTING_get && #endif (s = PerlEnv_getenv("PERL5OPT"))) { while (isSPACE(*s)) s++; if (*s == '-' && *(s+1) == 'T') { +#if SILENT_NO_TAINT_SUPPORT + /* silently ignore */ +#elif NO_TAINT_SUPPORT + Perl_croak("This perl was compiled without taint support. " + "Cowardly refusing to run with -t or -T flags"); +#else CHECK_MALLOC_TOO_LATE_FOR('T'); - PL_tainting = TRUE; - PL_taint_warn = FALSE; + TAINTING_set(TRUE); + TAINT_WARN_set(FALSE); +#endif } else { char *popt_copy = NULL; @@ -1982,10 +2003,17 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) } } if (*d == 't') { - if( !PL_tainting ) { - PL_taint_warn = TRUE; - PL_tainting = TRUE; +#if SILENT_NO_TAINT_SUPPORT + /* silently ignore */ +#elif NO_TAINT_SUPPORT + Perl_croak("This perl was compiled without taint support. " + "Cowardly refusing to run with -t or -T flags"); +#else + if( !TAINTING_get) { + TAINT_WARN_set(TRUE); + TAINTING_set(TRUE); } +#endif } else { moreswitches(d); } @@ -1996,7 +2024,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) /* Set $^X early so that it can be used for relocatable paths in @INC */ /* and for SITELIB_EXP in USE_SITECUSTOMIZE */ - assert (!PL_tainted); + assert (!TAINT_get); TAINT; S_set_caret_X(aTHX); TAINT_NOT; @@ -2052,7 +2080,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) scriptname = "-"; } - assert (!PL_tainted); + assert (!TAINT_get); init_perllib(); { @@ -2195,7 +2223,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #ifdef PERL_MAD { const char *s; - if (!PL_tainting && + if (!TAINTING_get && (s = PerlEnv_getenv("PERL_XMLDUMP"))) { PL_madskills = 1; PL_minus_c = 1; @@ -3299,8 +3327,15 @@ Perl_moreswitches(pTHX_ const char *s) return s; case 't': case 'T': - if (!PL_tainting) +#if SILENT_NO_TAINT_SUPPORT + /* silently ignore */ +#elif NO_TAINT_SUPPORT + Perl_croak("This perl was compiled without taint support. " + "Cowardly refusing to run with -t or -T flags"); +#else + if (!TAINTING_get) TOO_LATE_FOR(*s); +#endif s++; return s; case 'u': @@ -3796,6 +3831,9 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) STATIC void S_init_ids(pTHX) { + /* no need to do anything here any more if we don't + * do tainting. */ +#if !NO_TAINT_SUPPORT dVAR; const UV my_uid = PerlProc_getuid(); const UV my_euid = PerlProc_geteuid(); @@ -3804,7 +3842,8 @@ S_init_ids(pTHX) /* Should not happen: */ CHECK_MALLOC_TAINT(my_uid && (my_euid != my_uid || my_egid != my_gid)); - PL_tainting |= (my_uid && (my_euid != my_uid || my_egid != my_gid)); + TAINTING_set( TAINTING_get | (my_uid && (my_euid != my_uid || my_egid != my_gid)) ); +#endif /* BUG */ /* PSz 27 Feb 04 * Should go by suidscript, not uid!=euid: why disallow @@ -4221,7 +4260,7 @@ S_init_perllib(pTHX) STRLEN len; #endif - if (!PL_tainting) { + if (!TAINTING_get) { #ifndef VMS perl5lib = PerlEnv_getenv("PERL5LIB"); /* @@ -4337,7 +4376,7 @@ S_init_perllib(pTHX) |INCPUSH_CAN_RELOCATE); #endif - if (!PL_tainting) { + if (!TAINTING_get) { #ifndef VMS /* * It isn't possible to delete an environment variable with @@ -4394,7 +4433,7 @@ S_init_perllib(pTHX) #endif #endif /* !PERL_IS_MINIPERL */ - if (!PL_tainting) + if (!TAINTING_get) S_incpush(aTHX_ STR_WITH_LEN("."), 0); } @@ -4560,7 +4599,7 @@ S_mayberelocate(pTHX_ const char *const dir, STRLEN len, U32 flags) SvREFCNT_dec(libdir); /* And this is the new libdir. */ libdir = tempsv; - if (PL_tainting && + if (TAINTING_get && (PerlProc_getuid() != PerlProc_geteuid() || PerlProc_getgid() != PerlProc_getegid())) { /* Need to taint relocated paths if running set ID */ @@ -528,11 +528,51 @@ register struct op *Perl_op asm(stringify(OP_IN_REGISTER)); # define VOL #endif -#define TAINT (PL_tainted = TRUE) -#define TAINT_NOT (PL_tainted = FALSE) -#define TAINT_IF(c) if (c) { PL_tainted = TRUE; } -#define TAINT_ENV() if (PL_tainting) { taint_env(); } -#define TAINT_PROPER(s) if (PL_tainting) { taint_proper(NULL, s); } +/* By compiling a perl with -DNO_TAINT_SUPPORT or -DSILENT_NO_TAINT_SUPPORT, + * you get a perl without taint support, but doubtlessly with a lesser + * degree of support. Do not do so unless you know exactly what it means + * technically, have a good reason to do so, and know exactly how the + * perl will be used. perls with -DSILENT_NO_TAINT_SUPPORT are considered + * a potential security risk due to flat out ignoring the security-relevant + * taint flags. This being said, a perl without taint support compiled in + * has marginal run-time performance benefits. + * SILENT_NO_TAINT_SUPPORT implies NO_TAINT_SUPPORT. + * SILENT_NO_TAINT_SUPPORT is the same as NO_TAINT_SUPPORT except it + * silently ignores -t/-T instead of throwing an exception. + */ +#if SILENT_NO_TAINT_SUPPORT && !defined(NO_TAINT_SUPPORT) +# define NO_TAINT_SUPPORT 1 +#endif + +/* NO_TAINT_SUPPORT can be set to transform virtually all taint-related + * operations into no-ops for a very modest speed-up. Enable only if you + * know what you're doing: tests and CPAN modules' tests are bound to fail. + */ +#if NO_TAINT_SUPPORT +# define TAINT NOOP +# define TAINT_NOT NOOP +# define TAINT_IF(c) NOOP +# define TAINT_ENV() NOOP +# define TAINT_PROPER(s) NOOP +# define TAINT_set(s) NOOP +# define TAINT_get 0 +# define TAINTING_get 0 +# define TAINTING_set(s) NOOP +# define TAINT_WARN_get 0 +# define TAINT_WARN_set(s) NOOP +#else +# define TAINT (PL_tainted = TRUE) +# define TAINT_NOT (PL_tainted = FALSE) +# define TAINT_IF(c) if (c) { PL_tainted = TRUE; } +# define TAINT_ENV() if (PL_tainting) { taint_env(); } +# define TAINT_PROPER(s) if (PL_tainting) { taint_proper(NULL, s); } +# define TAINT_set(s) (PL_tainted = (s)) +# define TAINT_get (PL_tainted) +# define TAINTING_get (PL_tainting) +# define TAINTING_set(s) (PL_tainting = (s)) +# define TAINT_WARN_get (PL_taint_warn) +# define TAINT_WARN_set(s) (PL_taint_warn = (s)) +#endif /* flags used internally only within pp_subst and pp_substcont */ #ifdef PERL_CORE @@ -450,7 +450,7 @@ PerlIO_debug(const char *fmt, ...) dSYS; va_start(ap, fmt); if (!PL_perlio_debug_fd) { - if (!PL_tainting && + if (!TAINTING_get && PerlProc_getuid() == PerlProc_geteuid() && PerlProc_getgid() == PerlProc_getegid()) { const char * const s = PerlEnv_getenv("PERLIO_DEBUG"); @@ -1155,7 +1155,7 @@ PerlIO_default_layers(pTHX) { dVAR; if (!PL_def_layerlist) { - const char * const s = (PL_tainting) ? NULL : PerlEnv_getenv("PERLIO"); + const char * const s = TAINTING_get ? NULL : PerlEnv_getenv("PERLIO"); PERLIO_FUNCS_DECL(*osLayer) = &PerlIO_unix; PL_def_layerlist = PerlIO_list_alloc(aTHX); PerlIO_define_layer(aTHX_ PERLIO_FUNCS_CAST(&PerlIO_unix)); @@ -5014,7 +5014,7 @@ PerlIO_tmpfile(void) # if defined(HAS_MKSTEMP) && ! defined(VMS) && ! defined(OS2) int fd = -1; char tempname[] = "/tmp/PerlIO_XXXXXX"; - const char * const tmpdir = PL_tainting ? NULL : PerlEnv_getenv("TMPDIR"); + const char * const tmpdir = TAINTING_get ? NULL : PerlEnv_getenv("TMPDIR"); SV * sv = NULL; /* * I have no idea how portable mkstemp() is ... NI-S @@ -129,7 +129,7 @@ PP(pp_regcomp) some day. */ if (pm->op_type == OP_MATCH) { SV *lhs; - const bool was_tainted = PL_tainted; + const bool was_tainted = TAINT_get; if (pm->op_flags & OPf_STACKED) lhs = args[-1]; else if (pm->op_private & OPpTARGET_MY) @@ -138,8 +138,8 @@ PP(pp_regcomp) SvGETMAGIC(lhs); /* Restore the previous value of PL_tainted (which may have been modified by get-magic), to avoid incorrectly setting the - RXf_TAINTED flag further down. */ - PL_tainted = was_tainted; + RXf_TAINTED flag with RX_TAINT_on further down. */ + TAINT_set(was_tainted); } tmp = reg_temp_copy(NULL, new_re); ReREFCNT_dec(new_re); @@ -151,9 +151,9 @@ PP(pp_regcomp) } #ifndef INCOMPLETE_TAINTS - if (PL_tainting && PL_tainted) { + if (TAINTING_get && TAINT_get) { SvTAINTED_on((SV*)new_re); - RX_EXTFLAGS(new_re) |= RXf_TAINTED; + RX_TAINT_on(new_re); } #endif @@ -259,7 +259,7 @@ PP(pp_substcont) /* update the taint state of various various variables in * preparation for final exit. * See "how taint works" above pp_subst() */ - if (PL_tainting) { + if (TAINTING_get) { if ((cx->sb_rxtainted & SUBST_TAINT_PAT) || ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) @@ -271,8 +271,10 @@ PP(pp_substcont) ) SvTAINTED_on(TOPs); /* taint return value */ /* needed for mg_set below */ - PL_tainted = cBOOL(cx->sb_rxtainted & - (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)); + TAINT_set( + cBOOL(cx->sb_rxtainted & + (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) + ); SvTAINT(TARG); } /* PL_tainted must be correctly set for this mg_set */ @@ -321,7 +323,7 @@ PP(pp_substcont) /* update the taint state of various various variables in preparation * for calling the code block. * See "how taint works" above pp_subst() */ - if (PL_tainting) { + if (TAINTING_get) { if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */ cx->sb_rxtainted |= SUBST_TAINT_PAT; @@ -122,7 +122,7 @@ PP(pp_sassign) SV * const temp = left; left = right; right = temp; } - if (PL_tainting && PL_tainted && !SvTAINTED(right)) + if (TAINTING_get && TAINT_get && !SvTAINTED(right)) TAINT_NOT; if (PL_op->op_private & OPpASSIGN_CV_TO_GV) { SV * const cv = SvRV(right); @@ -1142,7 +1142,7 @@ PP(pp_aassign) tmp_gid = PerlProc_getgid(); tmp_egid = PerlProc_getegid(); } - PL_tainting |= (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)); + TAINTING_set( TAINTING_get | (tmp_uid && (tmp_euid != tmp_uid || tmp_egid != tmp_gid)) ); } PL_delaymagic = 0; @@ -1217,7 +1217,7 @@ PP(pp_qr) (void)sv_bless(rv, stash); } - if (RX_EXTFLAGS(rx) & RXf_TAINTED) { + if (RX_ISTAINTED(rx)) { SvTAINTED_on(rv); SvTAINTED_on(SvRV(rv)); } @@ -1264,8 +1264,8 @@ PP(pp_match) if (!s) DIE(aTHX_ "panic: pp_match"); strend = s + len; - rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) || - (PL_tainted && (pm->op_pmflags & PMf_RETAINT))); + rxtainted = (RX_ISTAINTED(rx) || + (TAINT_get && (pm->op_pmflags & PMf_RETAINT))); TAINT_NOT; RX_MATCH_UTF8_set(rx, DO_UTF8(TARG)); @@ -1976,14 +1976,19 @@ PP(pp_iter) /* A description of how taint works in pattern matching and substitution. +This is all conditional on NO_TAINT_SUPPORT not being defined. Under +NO_TAINT_SUPPORT, taint-related operations should become no-ops. + While the pattern is being assembled/concatenated and then compiled, -PL_tainted will get set if any component of the pattern is tainted, e.g. -/.*$tainted/. At the end of pattern compilation, the RXf_TAINTED flag -is set on the pattern if PL_tainted is set. +PL_tainted will get set (via TAINT_set) if any component of the pattern +is tainted, e.g. /.*$tainted/. At the end of pattern compilation, +the RXf_TAINTED flag is set on the pattern if PL_tainted is set (via +TAINT_get). When the pattern is copied, e.g. $r = qr/..../, the SV holding the ref to the pattern is marked as tainted. This means that subsequent usage, such -as /x$r/, will set PL_tainted, and thus RXf_TAINTED, on the new pattern too. +as /x$r/, will set PL_tainted using TAINT_set, and thus RXf_TAINTED, +on the new pattern too. During execution of a pattern, locale-variant ops such as ALNUML set the local flag RF_tainted. At the end of execution, the engine sets the @@ -2111,10 +2116,10 @@ PP(pp_subst) once = !(rpm->op_pmflags & PMf_GLOBAL); /* See "how taint works" above */ - if (PL_tainting) { + if (TAINTING_get) { rxtainted = ( (SvTAINTED(TARG) ? SUBST_TAINT_STR : 0) - | ((RX_EXTFLAGS(rx) & RXf_TAINTED) ? SUBST_TAINT_PAT : 0) + | (RX_ISTAINTED(rx) ? SUBST_TAINT_PAT : 0) | ((pm->op_pmflags & PMf_RETAINT) ? SUBST_TAINT_RETAINT : 0) | ((once && !(rpm->op_pmflags & PMf_NONDESTRUCT)) ? SUBST_TAINT_BOOLRET : 0)); @@ -2402,7 +2407,7 @@ PP(pp_subst) } /* See "how taint works" above */ - if (PL_tainting) { + if (TAINTING_get) { if ((rxtainted & SUBST_TAINT_PAT) || ((rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT)) @@ -2417,8 +2422,9 @@ PP(pp_subst) SvTAINTED_off(TOPs); /* may have got tainted earlier */ /* needed for mg_set below */ - PL_tainted = - cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)); + TAINT_set( + cBOOL(rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)) + ); SvTAINT(TARG); } SvSETMAGIC(TARG); /* PL_tainted must be correctly set for this mg_set */ @@ -387,7 +387,7 @@ PP(pp_glob) ENTER_with_name("glob"); #ifndef VMS - if (PL_tainting) { + if (TAINTING_get) { /* * The external globbing program may use things we can't control, * so for security reasons we must assume the worst. @@ -4138,11 +4138,11 @@ PP(pp_system) I32 value; int result; - if (PL_tainting) { + if (TAINTING_get) { TAINT_ENV(); while (++MARK <= SP) { (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ - if (PL_tainted) + if (TAINT_get) break; } MARK = ORIGMARK; @@ -4285,11 +4285,11 @@ PP(pp_exec) dVAR; dSP; dMARK; dORIGMARK; dTARGET; I32 value; - if (PL_tainting) { + if (TAINTING_get) { TAINT_ENV(); while (++MARK <= SP) { (void)SvPV_nolen_const(*MARK); /* stringify for taint check */ - if (PL_tainted) + if (TAINT_get) break; } MARK = ORIGMARK; @@ -5435,7 +5435,7 @@ PP(pp_syscall) I32 i = 0; IV retval = -1; - if (PL_tainting) { + if (TAINTING_get) { while (++MARK <= SP) { if (SvTAINTED(*MARK)) { TAINT; @@ -5762,7 +5762,7 @@ Perl_re_op_compile(pTHX_ SV ** const patternp, int pat_count, RExC_pm_flags = pm_flags; if (runtime_code) { - if (PL_tainting && PL_tainted) + if (TAINTING_get && TAINT_get) Perl_croak(aTHX_ "Eval-group in insecure regular expression"); if (!S_compile_runtime_code(aTHX_ pRExC_state, exp, plen)) { @@ -6743,10 +6743,14 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, assert(s >= rx->subbeg); assert(rx->sublen >= (s - rx->subbeg) + i ); if (i >= 0) { - const int oldtainted = PL_tainted; +#if NO_TAINT_SUPPORT + sv_setpvn(sv, s, i); +#else + const int oldtainted = TAINT_get; TAINT_NOT; sv_setpvn(sv, s, i); - PL_tainted = oldtainted; + TAINT_set(oldtainted); +#endif if ( (rx->extflags & RXf_CANY_SEEN) ? (RXp_MATCH_UTF8(rx) && (!i || is_utf8_string((U8*)s, i))) @@ -6756,12 +6760,12 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, } else SvUTF8_off(sv); - if (PL_tainting) { + if (TAINTING_get) { if (RXp_MATCH_TAINTED(rx)) { if (SvTYPE(sv) >= SVt_PVMG) { MAGIC* const mg = SvMAGIC(sv); MAGIC* mgt; - PL_tainted = 1; + TAINT; SvMAGIC_set(sv, mg->mg_moremagic); SvTAINT(sv); if ((mgt = SvMAGIC(sv))) { @@ -6769,7 +6773,7 @@ Perl_reg_numbered_buff_fetch(pTHX_ REGEXP * const r, const I32 paren, SvMAGIC_set(sv, mg); } } else { - PL_tainted = 1; + TAINT; SvTAINT(sv); } } else @@ -435,6 +435,14 @@ get_regex_charset_name(const U32 flags, STRLEN* const lenp) * */ +#if NO_TAINT_SUPPORT +# define RX_ISTAINTED(prog) 0 +# define RX_TAINT_on(prog) NOOP +#else +# define RX_ISTAINTED(prog) (RX_EXTFLAGS(prog) & RXf_TAINTED) +# define RX_TAINT_on(prog) (RX_EXTFLAGS(prog) |= RXf_TAINTED) +#endif + #define RX_HAS_CUTGROUP(prog) ((prog)->intflags & PREGf_CUTGROUP_SEEN) #define RXp_MATCH_TAINTED(prog) (RXp_EXTFLAGS(prog) & RXf_TAINTED_SEEN) #define RX_MATCH_TAINTED(prog) (RX_EXTFLAGS(prog) & RXf_TAINTED_SEEN) @@ -713,7 +713,7 @@ Perl_leave_scope(pTHX_ I32 base) char* str; I32 i; /* Localise the effects of the TAINT_NOT inside the loop. */ - bool was = PL_tainted; + bool was = TAINT_get; if (base < -1) Perl_croak(aTHX_ "panic: corrupt saved stack index %ld", (long) base); @@ -817,8 +817,8 @@ Perl_leave_scope(pTHX_ I32 base) case SAVEt_BOOL: /* bool reference */ ptr = SSPOPPTR; *(bool*)ptr = cBOOL(uv >> 8); - - if (ptr == &PL_tainted) { +#if !NO_TAINT_SUPPORT + if (ptr == TAINT_get) { /* If we don't update <was>, to reflect what was saved on the * stack for PL_tainted, then we will overwrite this attempt to * restore it when we exit this routine. Note that this won't @@ -826,6 +826,7 @@ Perl_leave_scope(pTHX_ I32 base) * such as I32 */ was = *(bool*)ptr; } +#endif break; case SAVEt_I32_SMALL: ptr = SSPOPPTR; @@ -1177,7 +1178,7 @@ Perl_leave_scope(pTHX_ I32 base) } } - PL_tainted = was; + TAINT_set(was); PERL_ASYNC_CHECK(); } @@ -12948,9 +12948,14 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_origargc = proto_perl->Iorigargc; PL_origargv = proto_perl->Iorigargv; +#if !NO_TAINT_SUPPORT /* Set tainting stuff before PerlIO_debug can possibly get called */ PL_tainting = proto_perl->Itainting; PL_taint_warn = proto_perl->Itaint_warn; +#else + PL_tainting = FALSE; + PL_taint_warn = FALSE; +#endif PL_minus_c = proto_perl->Iminus_c; @@ -13123,7 +13128,11 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_timesbuf = proto_perl->Itimesbuf; #endif +#if !NO_TAINT_SUPPORT PL_tainted = proto_perl->Itainted; +#else + PL_tainted = FALSE; +#endif PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */ PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */ @@ -1442,14 +1442,18 @@ attention to precisely which outputs are influenced by which inputs. #define sv_taint(sv) sv_magic((sv), NULL, PERL_MAGIC_taint, NULL, 0) -#define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv)) -#define SvTAINTED_on(sv) STMT_START{ if(PL_tainting){sv_taint(sv);} }STMT_END -#define SvTAINTED_off(sv) STMT_START{ if(PL_tainting){sv_untaint(sv);} }STMT_END +#if NO_TAINT_SUPPORT +# define SvTAINTED(sv) 0 +#else +# define SvTAINTED(sv) (SvMAGICAL(sv) && sv_tainted(sv)) +#endif +#define SvTAINTED_on(sv) STMT_START{ if(TAINTING_get){sv_taint(sv);} }STMT_END +#define SvTAINTED_off(sv) STMT_START{ if(TAINTING_get){sv_untaint(sv);} }STMT_END #define SvTAINT(sv) \ STMT_START { \ - if (PL_tainting) { \ - if (PL_tainted) \ + if (TAINTING_get) { \ + if (TAINT_get) \ SvTAINTED_on(sv); \ } \ } STMT_END @@ -38,7 +38,7 @@ Perl_taint_proper(pTHX_ const char *f, const char *const s) DEBUG_u(PerlIO_printf(Perl_debug_log, "%s %d %"UVuf" %"UVuf"\n", - s, PL_tainted, uid, euid)); + s, TAINT_get, uid, euid)); } # else { @@ -47,12 +47,12 @@ Perl_taint_proper(pTHX_ const char *f, const char *const s) DEBUG_u(PerlIO_printf(Perl_debug_log, "%s %d %"IVdf" %"IVdf"\n", - s, PL_tainted, uid, euid)); + s, TAINT_get, uid, euid)); } # endif #endif - if (PL_tainted) { + if (TAINT_get) { const char *ug; if (!f) @@ -61,11 +61,11 @@ Perl_taint_proper(pTHX_ const char *f, const char *const s) ug = " while running setuid"; else if (PerlProc_getgid() != PerlProc_getegid()) ug = " while running setgid"; - else if (PL_taint_warn) + else if (TAINT_WARN_get) ug = " while running with -t switch"; else ug = " while running with -T switch"; - if (PL_unsafe || PL_taint_warn) { + if (PL_unsafe || TAINT_WARN_get) { Perl_ck_warner_d(aTHX_ packWARN(WARN_TAINT), f, s, ug); } else { @@ -95,13 +95,13 @@ Perl_taint_env(pTHX) /* Don't bother if there's no *ENV glob */ if (!PL_envgv) return; - /* If there's no %ENV hash of if it's not magical, croak, because + /* If there's no %ENV hash or if it's not magical, croak, because * it probably doesn't reflect the actual environment */ if (!GvHV(PL_envgv) || !(SvRMAGICAL(GvHV(PL_envgv)) && mg_find((const SV *)GvHV(PL_envgv), PERL_MAGIC_env))) { - const bool was_tainted = PL_tainted; + const bool was_tainted = TAINT_get; const char * const name = GvENAME(PL_envgv); - PL_tainted = TRUE; + TAINT; if (strEQ(name,"ENV")) /* hash alias */ taint_proper("%%ENV is aliased to %s%s", "another variable"); @@ -109,7 +109,7 @@ Perl_taint_env(pTHX) /* glob alias: report it in the error message */ taint_proper("%%ENV is aliased to %%%s%s", name); /* this statement is reached under -t or -U */ - PL_tainted = was_tainted; + TAINT_set(was_tainted); } #ifdef VMS @@ -154,10 +154,10 @@ Perl_taint_env(pTHX) svp = hv_fetchs(GvHVn(PL_envgv),"TERM",FALSE); if (svp && *svp && SvTAINTED(*svp)) { STRLEN len; - const bool was_tainted = PL_tainted; + const bool was_tainted = TAINT_get; const char *t = SvPV_const(*svp, len); const char * const e = t + len; - PL_tainted = was_tainted; + TAINT_set(was_tainted); if (t < e && isALNUM(*t)) t++; while (t < e && (isALNUM(*t) || strchr("-_.+", *t))) @@ -2867,8 +2867,10 @@ Perl__core_swash_init(pTHX_ const char* pkg, const char* name, SV *listsv, I32 m * PL_tainted to 1 while saving $1 etc (see the code after getrx: * in Perl_magic_get). Even line to create errsv_save can turn on * PL_tainted. */ - SAVEBOOL(PL_tainted); - PL_tainted = 0; +#ifndef NO_TAINT_SUPPORT + SAVEBOOL(TAINT_get); + TAINT_NOT; +#endif Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT, newSVpvn(pkg,pkg_len), NULL); if (!SvTRUE(ERRSV)) @@ -2488,7 +2488,7 @@ Perl_my_popen_list(pTHX_ const char *mode, int n, SV **args) PERL_FLUSHALL_FOR_CHILD; This = (*mode == 'w'); that = !This; - if (PL_tainting) { + if (TAINTING_get) { taint_env(); taint_proper("Insecure %s%s", "EXEC"); } @@ -2634,7 +2634,7 @@ Perl_my_popen(pTHX_ const char *cmd, const char *mode) #endif This = (*mode == 'w'); that = !This; - if (doexec && PL_tainting) { + if (doexec && TAINTING_get) { taint_env(); taint_proper("Insecure %s%s", "EXEC"); } @@ -6366,7 +6366,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) { dVAR; SV * const dbsv = GvSVn(PL_DBsub); - const bool save_taint = PL_tainted; + const bool save_taint = TAINT_get; /* Accepted unused var warning under NO_TAINT_SUPPORT */ /* When we are called from pp_goto (svp is null), * we do not care about using dbsv to call CV; @@ -6375,7 +6375,7 @@ Perl_get_db_sub(pTHX_ SV **svp, CV *cv) PERL_ARGS_ASSERT_GET_DB_SUB; - PL_tainted = FALSE; + TAINT_set(FALSE); save_item(dbsv); if (!PERLDB_SUB_NN) { GV *gv = CvGV(cv); @@ -1072,7 +1072,7 @@ int Perl_my_trnlnm(pTHX_ const char *lnm, char *eqv, unsigned long int idx) if (aTHX != NULL) #endif #ifdef SECURE_INTERNAL_GETENV - flags = (PL_curinterp ? PL_tainting : will_taint) ? + flags = (PL_curinterp ? TAINTING_get : will_taint) ? PERL__TRNENV_SECURE : 0; #endif @@ -1145,7 +1145,7 @@ Perl_my_getenv(pTHX_ const char *lnm, bool sys) /* Impose security constraints only if tainting */ if (sys) { /* Impose security constraints only if tainting */ - secure = PL_curinterp ? PL_tainting : will_taint; + secure = PL_curinterp ? TAINTING_get : will_taint; saverr = errno; savvmserr = vaxc$errno; } else { @@ -1244,7 +1244,7 @@ Perl_my_getenv_len(pTHX_ const char *lnm, unsigned long *len, bool sys) else { if (sys) { /* Impose security constraints only if tainting */ - secure = PL_curinterp ? PL_tainting : will_taint; + secure = PL_curinterp ? TAINTING_get : will_taint; saverr = errno; savvmserr = vaxc$errno; } else { |