summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGurusamy Sarathy <gsar@cpan.org>1998-05-15 01:34:53 +0000
committerGurusamy Sarathy <gsar@cpan.org>1998-05-15 01:34:53 +0000
commit48c036b1eb8f866b948f33704ee6152323a5aad9 (patch)
tree6e91e012efd9b99283cda0a0e070452f8d41eb8a
parentee580363108be8ac33155650c6c18d2e5cf051f3 (diff)
downloadperl-48c036b1eb8f866b948f33704ee6152323a5aad9.tar.gz
[win32] merge change#905 from maintbranch, minor fixes to get
clean build+test on Solaris p4raw-link: @905 on //depot/maint-5.004/perl: 15e73149a8419f18d739227762eab108524cec56 p4raw-id: //depot/win32/perl@976
-rw-r--r--doop.c2
-rw-r--r--dump.c4
-rw-r--r--embed.h2
-rw-r--r--embedvar.h10
-rw-r--r--lib/strict.pm8
-rw-r--r--mg.c3
-rw-r--r--op.h5
-rw-r--r--opcode.h2
-rw-r--r--pod/perlop.pod1
-rw-r--r--pod/perlre.pod2
-rw-r--r--pp_ctl.c11
-rw-r--r--pp_hot.c24
-rw-r--r--regcomp.c7
-rw-r--r--sv.c2
-rwxr-xr-xt/op/taint.t284
-rw-r--r--toke.c10
16 files changed, 208 insertions, 169 deletions
diff --git a/doop.c b/doop.c
index e7c5e359d3..e92f49e668 100644
--- a/doop.c
+++ b/doop.c
@@ -106,7 +106,7 @@ do_join(register SV *sv, SV *del, register SV **mark, register SV **sp)
sv_upgrade(sv, SVt_PV);
if (SvLEN(sv) < len + items) { /* current length is way too short */
while (items-- > 0) {
- if (*mark && !SvGMAGIC(*mark) && SvOK(*mark)) {
+ if (*mark && !SvGMAGICAL(*mark) && SvOK(*mark)) {
SvPV(*mark, tmplen);
len += tmplen;
}
diff --git a/dump.c b/dump.c
index 24602e9477..4ddcf330e1 100644
--- a/dump.c
+++ b/dump.c
@@ -361,7 +361,7 @@ dump_pm(PMOP *pm)
}
if (pm->op_pmflags || (pm->op_pmregexp && pm->op_pmregexp->check_substr)) {
SV *tmpsv = newSVpv("", 0);
- if (pm->op_pmflags & PMf_USED)
+ if (pm->op_pmdynflags & PMdf_USED)
sv_catpv(tmpsv, ",USED");
if (pm->op_pmflags & PMf_ONCE)
sv_catpv(tmpsv, ",ONCE");
@@ -381,6 +381,8 @@ dump_pm(PMOP *pm)
sv_catpv(tmpsv, ",GLOBAL");
if (pm->op_pmflags & PMf_CONTINUE)
sv_catpv(tmpsv, ",CONTINUE");
+ if (pm->op_pmflags & PMf_TAINTMEM)
+ sv_catpv(tmpsv, ",TAINTMEM");
if (pm->op_pmflags & PMf_EVAL)
sv_catpv(tmpsv, ",EVAL");
dump("PMFLAGS = (%s)\n", SvCUR(tmpsv) ? SvPVX(tmpsv) + 1 : "");
diff --git a/embed.h b/embed.h
index 087b5d16ca..02e4ce9f85 100644
--- a/embed.h
+++ b/embed.h
@@ -141,6 +141,7 @@
#define div_amg Perl_div_amg
#define div_ass_amg Perl_div_ass_amg
#define do_aexec Perl_do_aexec
+#define do_binmode Perl_do_binmode
#define do_chomp Perl_do_chomp
#define do_chop Perl_do_chop
#define do_close Perl_do_close
@@ -192,6 +193,7 @@
#define filter_add Perl_filter_add
#define filter_del Perl_filter_del
#define filter_read Perl_filter_read
+#define find_script Perl_find_script
#define find_threadsv Perl_find_threadsv
#define fold Perl_fold
#define fold_constants Perl_fold_constants
diff --git a/embedvar.h b/embedvar.h
index 11ccca23af..9df05545ac 100644
--- a/embedvar.h
+++ b/embedvar.h
@@ -45,6 +45,7 @@
#define markstack (curinterp->Tmarkstack)
#define markstack_max (curinterp->Tmarkstack_max)
#define markstack_ptr (curinterp->Tmarkstack_ptr)
+#define modcount (curinterp->Tmodcount)
#define nrs (curinterp->Tnrs)
#define ofs (curinterp->Tofs)
#define ofslen (curinterp->Tofslen)
@@ -127,7 +128,6 @@
#define incgv (curinterp->Iincgv)
#define initav (curinterp->Iinitav)
#define inplace (curinterp->Iinplace)
-#define sys_intern (curinterp->Isys_intern)
#define lastfd (curinterp->Ilastfd)
#define lastscream (curinterp->Ilastscream)
#define lastsize (curinterp->Ilastsize)
@@ -191,6 +191,7 @@
#define sv_count (curinterp->Isv_count)
#define sv_objcount (curinterp->Isv_objcount)
#define sv_root (curinterp->Isv_root)
+#define sys_intern (curinterp->Isys_intern)
#define tainting (curinterp->Itainting)
#define threadnum (curinterp->Ithreadnum)
#define thrsv (curinterp->Ithrsv)
@@ -247,7 +248,6 @@
#define Iincgv incgv
#define Iinitav initav
#define Iinplace inplace
-#define Isys_intern sys_intern
#define Ilastfd lastfd
#define Ilastscream lastscream
#define Ilastsize lastsize
@@ -311,6 +311,7 @@
#define Isv_count sv_count
#define Isv_objcount sv_objcount
#define Isv_root sv_root
+#define Isys_intern sys_intern
#define Itainting tainting
#define Ithreadnum threadnum
#define Ithrsv thrsv
@@ -344,6 +345,7 @@
#define Tmarkstack markstack
#define Tmarkstack_max markstack_max
#define Tmarkstack_ptr markstack_ptr
+#define Tmodcount modcount
#define Tnrs nrs
#define Tofs ofs
#define Tofslen ofslen
@@ -428,7 +430,6 @@
#define incgv Perl_incgv
#define initav Perl_initav
#define inplace Perl_inplace
-#define sys_intern Perl_sys_intern
#define lastfd Perl_lastfd
#define lastscream Perl_lastscream
#define lastsize Perl_lastsize
@@ -492,6 +493,7 @@
#define sv_count Perl_sv_count
#define sv_objcount Perl_sv_objcount
#define sv_root Perl_sv_root
+#define sys_intern Perl_sys_intern
#define tainting Perl_tainting
#define threadnum Perl_threadnum
#define thrsv Perl_thrsv
@@ -525,6 +527,7 @@
#define markstack Perl_markstack
#define markstack_max Perl_markstack_max
#define markstack_ptr Perl_markstack_ptr
+#define modcount Perl_modcount
#define nrs Perl_nrs
#define ofs Perl_ofs
#define ofslen Perl_ofslen
@@ -588,6 +591,7 @@
#define markstack (thr->Tmarkstack)
#define markstack_max (thr->Tmarkstack_max)
#define markstack_ptr (thr->Tmarkstack_ptr)
+#define modcount (thr->Tmodcount)
#define nrs (thr->Tnrs)
#define ofs (thr->Tofs)
#define ofslen (thr->Tofslen)
diff --git a/lib/strict.pm b/lib/strict.pm
index 463b056c7f..940e8bf7ff 100644
--- a/lib/strict.pm
+++ b/lib/strict.pm
@@ -85,14 +85,6 @@ subs => 0x00000200,
vars => 0x00000400
);
-$strict::VERSION = "1.01";
-
-my %bitmask = (
-refs => 0x00000002,
-subs => 0x00000200,
-vars => 0x00000400
-);
-
sub bits {
my $bits = 0;
foreach my $s (@_){ $bits |= $bitmask{$s} || 0; };
diff --git a/mg.c b/mg.c
index 492e35191d..108644a6de 100644
--- a/mg.c
+++ b/mg.c
@@ -460,7 +460,8 @@ magic_get(SV *sv, MAGIC *mg)
}
sv_setpvn(sv,s,i);
if (tainting)
- tainted = was_tainted || RX_MATCH_TAINTED(rx);
+ tainted = (was_tainted || RX_MATCH_TAINTED(rx) ||
+ (curpm->op_pmflags & PMf_TAINTMEM));
break;
}
}
diff --git a/op.h b/op.h
index a203c44639..8476acdae6 100644
--- a/op.h
+++ b/op.h
@@ -181,9 +181,12 @@ struct pmop {
REGEXP * op_pmregexp; /* compiled expression */
U16 op_pmflags;
U16 op_pmpermflags;
+ U8 op_pmdynflags;
};
-#define PMf_USED 0x0001 /* pm has been used once already */
+#define PMdf_USED 0x01 /* pm has been used once already */
+
+#define PMf_TAINTMEM 0x0001 /* taint $1 etc. if target tainted */
#define PMf_ONCE 0x0002 /* use pattern only once per reset */
#define PMf_REVERSED 0x0004 /* Should be matched right->left */
/*#define PMf_ALL 0x0008*/ /* initial constant is whole pat */
diff --git a/opcode.h b/opcode.h
index e243548971..b4f4a9f71f 100644
--- a/opcode.h
+++ b/opcode.h
@@ -2264,7 +2264,7 @@ EXT U32 opargs[] = {
0x00009c8e, /* oct */
0x00009c8e, /* abs */
0x00009c9c, /* length */
- 0x0091150c, /* substr */
+ 0x0991150c, /* substr */
0x0011151c, /* vec */
0x0091151c, /* index */
0x0091151c, /* rindex */
diff --git a/pod/perlop.pod b/pod/perlop.pod
index 69e4fcb0d9..e4088ec9c4 100644
--- a/pod/perlop.pod
+++ b/pod/perlop.pod
@@ -651,6 +651,7 @@ Options are:
m Treat string as multiple lines.
o Compile pattern only once.
s Treat string as single line.
+ t Taint $1 etc. if target string is tainted.
x Use extended regular expressions.
If "/" is the delimiter then the initial C<m> is optional. With the C<m>
diff --git a/pod/perlre.pod b/pod/perlre.pod
index f029cbecc1..68ce4b9bf7 100644
--- a/pod/perlre.pod
+++ b/pod/perlre.pod
@@ -395,7 +395,7 @@ Say,
matches a chunk of non-parentheses, possibly included in parentheses
themselves.
-=item C<(?imsx)>
+=item C<(?imstx)>
One or more embedded pattern-match modifiers. This is particularly
useful for patterns that are specified in a table somewhere, some of
diff --git a/pp_ctl.c b/pp_ctl.c
index 1ee85a6d87..75cf077b7b 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -130,8 +130,8 @@ PP(pp_substcont)
if (cx->sb_iters > cx->sb_maxiters)
DIE("Substitution loop");
- if (!cx->sb_rxtainted)
- cx->sb_rxtainted = SvTAINTED(TOPs);
+ if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
+ cx->sb_rxtainted |= 2;
sv_catsv(dstr, POPs);
/* Are we done */
@@ -143,6 +143,7 @@ PP(pp_substcont)
sv_catpvn(dstr, s, cx->sb_strend - s);
TAINT_IF(cx->sb_rxtainted || RX_MATCH_TAINTED(rx));
+ cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
(void)SvOOK_off(targ);
Safefree(SvPVX(targ));
@@ -151,11 +152,15 @@ PP(pp_substcont)
SvLEN_set(targ, SvLEN(dstr));
SvPVX(dstr) = 0;
sv_free(dstr);
+
+ TAINT_IF(cx->sb_rxtainted & 1);
+ PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
+
(void)SvPOK_only(targ);
+ TAINT_IF(cx->sb_rxtainted);
SvSETMAGIC(targ);
SvTAINT(targ);
- PUSHs(sv_2mortal(newSViv((I32)cx->sb_iters - 1)));
LEAVE_SCOPE(cx->sb_oldsave);
POPSUBST(cx);
RETURNOP(pm->op_next);
diff --git a/pp_hot.c b/pp_hot.c
index 2fba24a80e..8322e8936d 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -791,7 +791,7 @@ PP(pp_match)
DIE("panic: do_match");
TAINT_NOT;
- if (pm->op_pmflags & PMf_USED) {
+ if (pm->op_pmdynflags & PMdf_USED) {
failure:
if (gimme == G_ARRAY)
RETURN;
@@ -887,7 +887,7 @@ play_it_again:
{
curpm = pm;
if (pm->op_pmflags & PMf_ONCE)
- pm->op_pmflags |= PMf_USED;
+ pm->op_pmdynflags |= PMdf_USED;
goto gotcha;
}
else
@@ -952,7 +952,7 @@ yup: /* Confirmed by check_substr */
++BmUSEFUL(rx->check_substr);
curpm = pm;
if (pm->op_pmflags & PMf_ONCE)
- pm->op_pmflags |= PMf_USED;
+ pm->op_pmdynflags |= PMdf_USED;
Safefree(rx->subbase);
rx->subbase = Nullch;
if (global) {
@@ -1476,6 +1476,7 @@ PP(pp_subst)
s = SvPV(TARG, len);
if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
force_on_match = 1;
+ rxtainted = tainted << 1;
TAINT_NOT;
force_it:
@@ -1562,7 +1563,7 @@ PP(pp_subst)
curpm = pm;
SvSCREAM_off(TARG); /* disable possible screamer */
if (once) {
- rxtainted = RX_MATCH_TAINTED(rx);
+ rxtainted |= RX_MATCH_TAINTED(rx);
if (rx->subbase) {
m = orig + (rx->startp[0] - rx->subbase);
d = orig + (rx->endp[0] - rx->subbase);
@@ -1603,12 +1604,11 @@ PP(pp_subst)
else {
sv_chop(TARG, d);
}
- TAINT_IF(rxtainted);
+ TAINT_IF(rxtainted & 1);
SPAGAIN;
PUSHs(&sv_yes);
}
else {
- rxtainted = 0;
do {
if (iters++ > maxiters)
DIE("Substitution loop");
@@ -1632,11 +1632,12 @@ PP(pp_subst)
SvCUR_set(TARG, d - SvPVX(TARG) + i);
Move(s, d, i+1, char); /* include the NUL */
}
- TAINT_IF(rxtainted);
+ TAINT_IF(rxtainted & 1);
SPAGAIN;
PUSHs(sv_2mortal(newSViv((I32)iters)));
}
(void)SvPOK_only(TARG);
+ TAINT_IF(rxtainted);
if (SvSMAGICAL(TARG)) {
PUTBACK;
mg_set(TARG);
@@ -1653,7 +1654,7 @@ PP(pp_subst)
s = SvPV_force(TARG, len);
goto force_it;
}
- rxtainted = RX_MATCH_TAINTED(rx);
+ rxtainted |= RX_MATCH_TAINTED(rx);
dstr = NEWSV(25, len);
sv_setpvn(dstr, m, s-m);
curpm = pm;
@@ -1684,8 +1685,6 @@ PP(pp_subst)
} while (regexec_flags(rx, s, strend, orig, s == m, Nullsv, NULL, safebase));
sv_catpvn(dstr, s, strend - s);
- TAINT_IF(rxtainted);
-
(void)SvOOK_off(TARG);
Safefree(SvPVX(TARG));
SvPVX(TARG) = SvPVX(dstr);
@@ -1694,11 +1693,14 @@ PP(pp_subst)
SvPVX(dstr) = 0;
sv_free(dstr);
+ TAINT_IF(rxtainted & 1);
+ PUSHs(sv_2mortal(newSViv((I32)iters)));
+
(void)SvPOK_only(TARG);
+ TAINT_IF(rxtainted);
SvSETMAGIC(TARG);
SvTAINT(TARG);
SPAGAIN;
- PUSHs(sv_2mortal(newSViv((I32)iters)));
LEAVE_SCOPE(oldsave);
RETURN;
}
diff --git a/regcomp.c b/regcomp.c
index 8d66f387ab..38bf387975 100644
--- a/regcomp.c
+++ b/regcomp.c
@@ -1135,8 +1135,11 @@ reg(I32 paren, I32 *flagp)
break;
default:
--regparse;
- while (*regparse && strchr("iogcmsx", *regparse))
- pmflag(&regflags, *regparse++);
+ while (*regparse && strchr("iogcmsx", *regparse)) {
+ if (*regparse != 'o')
+ pmflag(&regflags, *regparse);
+ ++regparse;
+ }
unknown:
if (*regparse != ')')
FAIL2("Sequence (?%c...) not recognized", *regparse);
diff --git a/sv.c b/sv.c
index 8d8d6149e9..368525274b 100644
--- a/sv.c
+++ b/sv.c
@@ -3703,7 +3703,7 @@ sv_reset(register char *s, HV *stash)
if (!*s) { /* reset ?? searches */
for (pm = HvPMROOT(stash); pm; pm = pm->op_pmnext) {
- pm->op_pmflags &= ~PMf_USED;
+ pm->op_pmdynflags &= ~PMdf_USED;
}
return;
}
diff --git a/t/op/taint.t b/t/op/taint.t
index e18f123e9d..2b9da86b3f 100755
--- a/t/op/taint.t
+++ b/t/op/taint.t
@@ -83,7 +83,7 @@ print PROG 'print "@ARGV\n"', "\n";
close PROG;
my $echo = "$Invoke_Perl $ECHO";
-print "1..140\n";
+print "1..145\n";
# First, let's make sure that Perl is checking the dangerous
# environment variables. Maybe they aren't set yet, so we'll
@@ -121,7 +121,10 @@ print "1..140\n";
}
my $tmp;
- unless ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_Dos) {
+ if ($^O eq 'os2' || $^O eq 'amigaos' || $Is_MSWin32 || $Is_Dos) {
+ print "# all directories are writeable\n";
+ }
+ else {
$tmp = (grep { defined and -d and (stat _)[2] & 2 }
qw(/tmp /var/tmp /usr/tmp /sys$scratch),
@ENV{qw(TMP TEMP)})[0]
@@ -184,12 +187,16 @@ print "1..140\n";
test 20, not tainted $foo;
test 21, $foo eq 'bar';
+ $foo = $1 if ('bar' . $TAINT) =~ /(.+)/t;
+ test 22, tainted $foo;
+ test 23, $foo eq 'bar';
+
my $pi = 4 * atan2(1,1) + $TAINT0;
- test 22, tainted $pi;
+ test 24, tainted $pi;
($pi) = $pi =~ /(\d+\.\d+)/;
- test 23, not tainted $pi;
- test 24, sprintf("%.5f", $pi) eq '3.14159';
+ test 25, not tainted $pi;
+ test 26, sprintf("%.5f", $pi) eq '3.14159';
}
# How about command-line arguments? The problem is that we don't
@@ -205,21 +212,21 @@ print "1..140\n";
};
close PROG;
print `$Invoke_Perl "-T" $arg and some suspect arguments`;
- test 25, !$?, "Exited with status $?";
+ test 27, !$?, "Exited with status $?";
unlink $arg;
}
# Reading from a file should be tainted
{
my $file = './TEST';
- test 26, open(FILE, $file), "Couldn't open '$file': $!";
+ test 28, open(FILE, $file), "Couldn't open '$file': $!";
my $block;
sysread(FILE, $block, 100);
my $line = <FILE>;
close FILE;
- test 27, tainted $block;
- test 28, tainted $line;
+ test 29, tainted $block;
+ test 30, tainted $line;
}
# Globs should be forbidden, except under VMS,
@@ -229,122 +236,122 @@ if ($Is_VMS) {
}
else {
my @globs = eval { <*> };
- test 29, @globs == 0 && $@ =~ /^Insecure dependency/;
+ test 31, @globs == 0 && $@ =~ /^Insecure dependency/;
@globs = eval { glob '*' };
- test 30, @globs == 0 && $@ =~ /^Insecure dependency/;
+ test 32, @globs == 0 && $@ =~ /^Insecure dependency/;
}
# Output of commands should be tainted
{
my $foo = `$echo abc`;
- test 31, tainted $foo;
+ test 33, tainted $foo;
}
# Certain system variables should be tainted
{
- test 32, all_tainted $^X, $0;
+ test 34, all_tainted $^X, $0;
}
# Results of matching should all be untainted
{
my $foo = "abcdefghi" . $TAINT;
- test 33, tainted $foo;
+ test 35, tainted $foo;
$foo =~ /def/;
- test 34, not any_tainted $`, $&, $';
+ test 36, not any_tainted $`, $&, $';
$foo =~ /(...)(...)(...)/;
- test 35, not any_tainted $1, $2, $3, $+;
+ test 37, not any_tainted $1, $2, $3, $+;
my @bar = $foo =~ /(...)(...)(...)/;
- test 36, not any_tainted @bar;
+ test 38, not any_tainted @bar;
- test 37, tainted $foo; # $foo should still be tainted!
- test 38, $foo eq "abcdefghi";
+ test 39, tainted $foo; # $foo should still be tainted!
+ test 40, $foo eq "abcdefghi";
}
# Operations which affect files can't use tainted data.
{
- test 39, eval { chmod 0, $TAINT } eq '', 'chmod';
- test 40, $@ =~ /^Insecure dependency/, $@;
+ test 41, eval { chmod 0, $TAINT } eq '', 'chmod';
+ test 42, $@ =~ /^Insecure dependency/, $@;
# There is no feature test in $Config{} for truncate,
# so we allow for the possibility that it's missing.
- test 41, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate';
- test 42, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@;
-
- test 43, eval { rename '', $TAINT } eq '', 'rename';
- test 44, $@ =~ /^Insecure dependency/, $@;
+ test 43, eval { truncate 'NoSuChFiLe', $TAINT0 } eq '', 'truncate';
+ test 44, $@ =~ /^(?:Insecure dependency|truncate not implemented)/, $@;
- test 45, eval { unlink $TAINT } eq '', 'unlink';
+ test 45, eval { rename '', $TAINT } eq '', 'rename';
test 46, $@ =~ /^Insecure dependency/, $@;
- test 47, eval { utime $TAINT } eq '', 'utime';
+ test 47, eval { unlink $TAINT } eq '', 'unlink';
test 48, $@ =~ /^Insecure dependency/, $@;
+ test 49, eval { utime $TAINT } eq '', 'utime';
+ test 50, $@ =~ /^Insecure dependency/, $@;
+
if ($Config{d_chown}) {
- test 49, eval { chown -1, -1, $TAINT } eq '', 'chown';
- test 50, $@ =~ /^Insecure dependency/, $@;
+ test 51, eval { chown -1, -1, $TAINT } eq '', 'chown';
+ test 52, $@ =~ /^Insecure dependency/, $@;
}
else {
- for (49..50) { print "ok $_ # Skipped: chown() is not available\n" }
+ for (51..52) { print "ok $_ # Skipped: chown() is not available\n" }
}
if ($Config{d_link}) {
- test 51, eval { link $TAINT, '' } eq '', 'link';
- test 52, $@ =~ /^Insecure dependency/, $@;
+ test 53, eval { link $TAINT, '' } eq '', 'link';
+ test 54, $@ =~ /^Insecure dependency/, $@;
}
else {
- for (51..52) { print "ok $_ # Skipped: link() is not available\n" }
+ for (53..54) { print "ok $_ # Skipped: link() is not available\n" }
}
if ($Config{d_symlink}) {
- test 53, eval { symlink $TAINT, '' } eq '', 'symlink';
- test 54, $@ =~ /^Insecure dependency/, $@;
+ test 55, eval { symlink $TAINT, '' } eq '', 'symlink';
+ test 56, $@ =~ /^Insecure dependency/, $@;
}
else {
- for (53..54) { print "ok $_ # Skipped: symlink() is not available\n" }
+ for (55..56) { print "ok $_ # Skipped: symlink() is not available\n" }
}
}
# Operations which affect directories can't use tainted data.
{
- test 55, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir';
- test 56, $@ =~ /^Insecure dependency/, $@;
-
- test 57, eval { rmdir $TAINT } eq '', 'rmdir';
+ test 57, eval { mkdir $TAINT0, $TAINT } eq '', 'mkdir';
test 58, $@ =~ /^Insecure dependency/, $@;
- test 59, eval { chdir $TAINT } eq '', 'chdir';
+ test 59, eval { rmdir $TAINT } eq '', 'rmdir';
test 60, $@ =~ /^Insecure dependency/, $@;
+ test 61, eval { chdir $TAINT } eq '', 'chdir';
+ test 62, $@ =~ /^Insecure dependency/, $@;
+
if ($Config{d_chroot}) {
- test 61, eval { chroot $TAINT } eq '', 'chroot';
- test 62, $@ =~ /^Insecure dependency/, $@;
+ test 63, eval { chroot $TAINT } eq '', 'chroot';
+ test 64, $@ =~ /^Insecure dependency/, $@;
}
else {
- for (61..62) { print "ok $_ # Skipped: chroot() is not available\n" }
+ for (63..64) { print "ok $_ # Skipped: chroot() is not available\n" }
}
}
# Some operations using files can't use tainted data.
{
my $foo = "imaginary library" . $TAINT;
- test 63, eval { require $foo } eq '', 'require';
- test 64, $@ =~ /^Insecure dependency/, $@;
+ test 65, eval { require $foo } eq '', 'require';
+ test 66, $@ =~ /^Insecure dependency/, $@;
my $filename = "./taintB$$"; # NB: $filename isn't tainted!
END { unlink $filename if defined $filename }
$foo = $filename . $TAINT;
unlink $filename; # in any case
- test 65, eval { open FOO, $foo } eq '', 'open for read';
- test 66, $@ eq '', $@; # NB: This should be allowed
- test 67, $! == ($Config{"archname"} !~ "djgpp" ? 2 : 22); # File not found
+ test 67, eval { open FOO, $foo } eq '', 'open for read';
+ test 68, $@ eq '', $@; # NB: This should be allowed
+ test 69, $! == 2; # File not found
- test 68, eval { open FOO, "> $foo" } eq '', 'open for write';
- test 69, $@ =~ /^Insecure dependency/, $@;
+ test 70, eval { open FOO, "> $foo" } eq '', 'open for write';
+ test 71, $@ =~ /^Insecure dependency/, $@;
}
# Commands to the system can't use tainted data
@@ -352,67 +359,67 @@ else {
my $foo = $TAINT;
if ($^O eq 'amigaos') {
- for (70..73) { print "ok $_ # Skipped: open('|') is not available\n" }
+ for (72..75) { print "ok $_ # Skipped: open('|') is not available\n" }
}
else {
- test 70, eval { open FOO, "| $foo" } eq '', 'popen to';
- test 71, $@ =~ /^Insecure dependency/, $@;
-
- test 72, eval { open FOO, "$foo |" } eq '', 'popen from';
+ test 72, eval { open FOO, "| $foo" } eq '', 'popen to';
test 73, $@ =~ /^Insecure dependency/, $@;
- }
- test 74, eval { exec $TAINT } eq '', 'exec';
- test 75, $@ =~ /^Insecure dependency/, $@;
+ test 74, eval { open FOO, "$foo |" } eq '', 'popen from';
+ test 75, $@ =~ /^Insecure dependency/, $@;
+ }
- test 76, eval { system $TAINT } eq '', 'system';
+ test 76, eval { exec $TAINT } eq '', 'exec';
test 77, $@ =~ /^Insecure dependency/, $@;
+ test 78, eval { system $TAINT } eq '', 'system';
+ test 79, $@ =~ /^Insecure dependency/, $@;
+
$foo = "*";
taint_these $foo;
- test 78, eval { `$echo 1$foo` } eq '', 'backticks';
- test 79, $@ =~ /^Insecure dependency/, $@;
+ test 80, eval { `$echo 1$foo` } eq '', 'backticks';
+ test 81, $@ =~ /^Insecure dependency/, $@;
if ($Is_VMS) { # wildcard expansion doesn't invoke shell, so is safe
- test 80, join('', eval { glob $foo } ) ne '', 'globbing';
- test 81, $@ eq '', $@;
+ test 82, join('', eval { glob $foo } ) ne '', 'globbing';
+ test 83, $@ eq '', $@;
}
else {
- for (80..81) { print "ok $_ # Skipped: this is not VMS\n"; }
+ for (82..83) { print "ok $_ # Skipped: this is not VMS\n"; }
}
}
# Operations which affect processes can't use tainted data.
{
- test 82, eval { kill 0, $TAINT } eq '', 'kill';
- test 83, $@ =~ /^Insecure dependency/, $@;
+ test 84, eval { kill 0, $TAINT } eq '', 'kill';
+ test 85, $@ =~ /^Insecure dependency/, $@;
if ($Config{d_setpgrp}) {
- test 84, eval { setpgrp 0, $TAINT } eq '', 'setpgrp';
- test 85, $@ =~ /^Insecure dependency/, $@;
+ test 86, eval { setpgrp 0, $TAINT } eq '', 'setpgrp';
+ test 87, $@ =~ /^Insecure dependency/, $@;
}
else {
- for (84..85) { print "ok $_ # Skipped: setpgrp() is not available\n" }
+ for (86..87) { print "ok $_ # Skipped: setpgrp() is not available\n" }
}
if ($Config{d_setprior}) {
- test 86, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority';
- test 87, $@ =~ /^Insecure dependency/, $@;
+ test 88, eval { setpriority 0, $TAINT, $TAINT } eq '', 'setpriority';
+ test 89, $@ =~ /^Insecure dependency/, $@;
}
else {
- for (86..87) { print "ok $_ # Skipped: setpriority() is not available\n" }
+ for (88..89) { print "ok $_ # Skipped: setpriority() is not available\n" }
}
}
# Some miscellaneous operations can't use tainted data.
{
if ($Config{d_syscall}) {
- test 88, eval { syscall $TAINT } eq '', 'syscall';
- test 89, $@ =~ /^Insecure dependency/, $@;
+ test 90, eval { syscall $TAINT } eq '', 'syscall';
+ test 91, $@ =~ /^Insecure dependency/, $@;
}
else {
- for (88..89) { print "ok $_ # Skipped: syscall() is not available\n" }
+ for (90..91) { print "ok $_ # Skipped: syscall() is not available\n" }
}
{
@@ -421,17 +428,17 @@ else {
local *FOO;
my $temp = "./taintC$$";
END { unlink $temp }
- test 90, open(FOO, "> $temp"), "Couldn't open $temp for write: $!";
+ test 92, open(FOO, "> $temp"), "Couldn't open $temp for write: $!";
- test 91, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl';
- test 92, $@ =~ /^Insecure dependency/, $@;
+ test 93, eval { ioctl FOO, $TAINT, $foo } eq '', 'ioctl';
+ test 94, $@ =~ /^Insecure dependency/, $@;
if ($Config{d_fcntl}) {
- test 93, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl';
- test 94, $@ =~ /^Insecure dependency/, $@;
+ test 95, eval { fcntl FOO, $TAINT, $foo } eq '', 'fcntl';
+ test 96, $@ =~ /^Insecure dependency/, $@;
}
else {
- for (93..94) { print "ok $_ # Skipped: fcntl() is not available\n" }
+ for (95..96) { print "ok $_ # Skipped: fcntl() is not available\n" }
}
close FOO;
@@ -442,65 +449,65 @@ else {
{
my $foo = 'abc' . $TAINT;
my $fooref = \$foo;
- test 95, not tainted $fooref;
- test 96, tainted $$fooref;
- test 97, tainted $foo;
+ test 97, not tainted $fooref;
+ test 98, tainted $$fooref;
+ test 99, tainted $foo;
}
# Some tests involving assignment
{
my $foo = $TAINT0;
my $bar = $foo;
- test 98, all_tainted $foo, $bar;
- test 99, tainted($foo = $bar);
- test 100, tainted($bar = $bar);
- test 101, tainted($bar += $bar);
- test 102, tainted($bar -= $bar);
- test 103, tainted($bar *= $bar);
- test 104, tainted($bar++);
- test 105, tainted($bar /= $bar);
- test 106, tainted($bar += 0);
- test 107, tainted($bar -= 2);
- test 108, tainted($bar *= -1);
- test 109, tainted($bar /= 1);
- test 110, tainted($bar--);
- test 111, $bar == 0;
+ test 100, all_tainted $foo, $bar;
+ test 101, tainted($foo = $bar);
+ test 102, tainted($bar = $bar);
+ test 103, tainted($bar += $bar);
+ test 104, tainted($bar -= $bar);
+ test 105, tainted($bar *= $bar);
+ test 106, tainted($bar++);
+ test 107, tainted($bar /= $bar);
+ test 108, tainted($bar += 0);
+ test 109, tainted($bar -= 2);
+ test 110, tainted($bar *= -1);
+ test 111, tainted($bar /= 1);
+ test 112, tainted($bar--);
+ test 113, $bar == 0;
}
# Test assignment and return of lists
{
my @foo = ("A", "tainted" . $TAINT, "B");
- test 112, not tainted $foo[0];
- test 113, tainted $foo[1];
- test 114, not tainted $foo[2];
+ test 114, not tainted $foo[0];
+ test 115, tainted $foo[1];
+ test 116, not tainted $foo[2];
my @bar = @foo;
- test 115, not tainted $bar[0];
- test 116, tainted $bar[1];
- test 117, not tainted $bar[2];
+ test 117, not tainted $bar[0];
+ test 118, tainted $bar[1];
+ test 119, not tainted $bar[2];
my @baz = eval { "A", "tainted" . $TAINT, "B" };
- test 118, not tainted $baz[0];
- test 119, tainted $baz[1];
- test 120, not tainted $baz[2];
+ test 120, not tainted $baz[0];
+ test 121, tainted $baz[1];
+ test 122, not tainted $baz[2];
my @plugh = eval q[ "A", "tainted" . $TAINT, "B" ];
- test 121, not tainted $plugh[0];
- test 122, tainted $plugh[1];
- test 123, not tainted $plugh[2];
+ test 123, not tainted $plugh[0];
+ test 124, tainted $plugh[1];
+ test 125, not tainted $plugh[2];
my $nautilus = sub { "A", "tainted" . $TAINT, "B" };
- test 124, not tainted ((&$nautilus)[0]);
- test 125, tainted ((&$nautilus)[1]);
- test 126, not tainted ((&$nautilus)[2]);
+ test 126, not tainted ((&$nautilus)[0]);
+ test 127, tainted ((&$nautilus)[1]);
+ test 128, not tainted ((&$nautilus)[2]);
my @xyzzy = &$nautilus;
- test 127, not tainted $xyzzy[0];
- test 128, tainted $xyzzy[1];
- test 129, not tainted $xyzzy[2];
+ test 129, not tainted $xyzzy[0];
+ test 130, tainted $xyzzy[1];
+ test 131, not tainted $xyzzy[2];
my $red_october = sub { return "A", "tainted" . $TAINT, "B" };
- test 130, not tainted ((&$red_october)[0]);
- test 131, tainted ((&$red_october)[1]);
- test 132, not tainted ((&$red_october)[2]);
+ test 132, not tainted ((&$red_october)[0]);
+ test 133, tainted ((&$red_october)[1]);
+ test 134, not tainted ((&$red_october)[2]);
my @corge = &$red_october;
- test 133, not tainted $corge[0];
- test 134, tainted $corge[1];
- test 135, not tainted $corge[2];
+ test 135, not tainted $corge[0];
+ test 136, tainted $corge[1];
+ test 137, not tainted $corge[2];
}
# Test for system/library calls returning string data of dubious origin.
@@ -510,7 +517,7 @@ else {
setpwent();
my @getpwent = getpwent();
die "getpwent: $!\n" unless (@getpwent);
- test 136,( not tainted $getpwent[0]
+ test 138,( not tainted $getpwent[0]
and not tainted $getpwent[1]
and not tainted $getpwent[2]
and not tainted $getpwent[3]
@@ -521,17 +528,17 @@ else {
and not tainted $getpwent[8]);
endpwent();
} else {
- print "ok 136 # Skipped: getpwent() is not available\n";
+ print "ok 138 # Skipped: getpwent() is not available\n";
}
if ($Config{d_readdir}) { # pretty hard to imagine not
local(*D);
opendir(D, "op") or die "opendir: $!\n";
my $readdir = readdir(D);
- test 137, tainted $readdir;
+ test 139, tainted $readdir;
closedir(OP);
} else {
- print "ok 137 # Skipped: readdir() is not available\n";
+ print "ok 139 # Skipped: readdir() is not available\n";
}
if ($Config{d_readlink} && $Config{d_symlink}) {
@@ -539,10 +546,10 @@ else {
unlink($symlink);
symlink("/something/naughty", $symlink) or die "symlink: $!\n";
my $readlink = readlink($symlink);
- test 138, tainted $readlink;
+ test 140, tainted $readlink;
unlink($symlink);
} else {
- print "ok 138 # Skipped: readlink() or symlink() is not available\n";
+ print "ok 140 # Skipped: readlink() or symlink() is not available\n";
}
}
@@ -550,9 +557,22 @@ else {
{
my $why = "y";
my $j = "x" | $why;
- test 139, not tainted $j;
+ test 141, not tainted $j;
$why = $TAINT."y";
$j = "x" | $why;
- test 140, tainted $j;
+ test 142, tainted $j;
}
+# test target of substitution (regression bug)
+{
+ my $why = $TAINT."y";
+ $why =~ s/y/z/;
+ test 143, tainted $why;
+
+ my $z = "[z]";
+ $why =~ s/$z/zee/;
+ test 144, tainted $why;
+
+ $why =~ s/e/'-'.$$/ge;
+ test 145, tainted $why;
+}
diff --git a/toke.c b/toke.c
index 2282ef7e54..2f687e8691 100644
--- a/toke.c
+++ b/toke.c
@@ -4858,6 +4858,8 @@ void pmflag(U16 *pmfl, int ch)
*pmfl |= PMf_MULTILINE;
else if (ch == 's')
*pmfl |= PMf_SINGLELINE;
+ else if (ch == 't')
+ *pmfl |= PMf_TAINTMEM;
else if (ch == 'x')
*pmfl |= PMf_EXTENDED;
}
@@ -4879,7 +4881,7 @@ scan_pat(char *start)
pm = (PMOP*)newPMOP(OP_MATCH, 0);
if (multi_open == '?')
pm->op_pmflags |= PMf_ONCE;
- while (*s && strchr("iogcmsx", *s))
+ while (*s && strchr("iogcmstx", *s))
pmflag(&pm->op_pmflags,*s++);
pm->op_pmpermflags = pm->op_pmflags;
@@ -4924,13 +4926,15 @@ scan_subst(char *start)
multi_start = first_start; /* so whole substitution is taken together */
pm = (PMOP*)newPMOP(OP_SUBST, 0);
- while (*s && strchr("iogcmsex", *s)) {
+ while (*s) {
if (*s == 'e') {
s++;
es++;
}
- else
+ else if (strchr("iogcmstx", *s))
pmflag(&pm->op_pmflags,*s++);
+ else
+ break;
}
if (es) {