On Wed, 21 Aug 2002, Tim Bunce wrote:
> Probably (well spotted). There's a $sth->_set_fbav( \@fieldvalues) method
> you could try that copies the supplied values into the row array.
Yeah, tainting the src vars as the copy happens seems to work.
New patch attached, now with doc changes.
BTW, should ->set_err have DBI_NO_TAINT_IN set? Bugzilla is still doing
taint stuff manually, and the set_err with a tainted sql string was
failing because the result was tainted...
Bradley
diff -ur DBI-1.30/DBI.pm DBI/DBI.pm
--- DBI-1.30/DBI.pm Fri Jul 19 00:24:04 2002
+++ DBI/DBI.pm Mon Sep 2 18:18:29 2002
@@ -2788,15 +2788,27 @@
=item C<Taint> (boolean, inherited)
If this attribute is set to a true value I<and> Perl is running in
-taint mode (e.g., started with the C<-T> option), then all data
-fetched from the database is tainted, and the arguments to most DBI
-method calls are checked for being tainted. I<This may change.>
+taint mode (e.g., started with the C<-T> option), then all the arguments
+to most DBI method calls are checked for being tainted. I<This may change.>
The attribute defaults to off, even if Perl is in taint mode.
See L<perlsec> for more about taint mode. If Perl is not
running in taint mode, this attribute has no effect.
-When fetching data that you trust you can turn off the Taint attribute,
+When fetching data that you trust you can turn off the TaintIn attribute,
+for that statement handle, for the duration of the fetch loop.
+
+=item C<TaintOut> (boolean, inherited)
+
+If this attribute is set to a true value I<and> Perl is running in
+taint mode (e.g., started with the C<-T> option), then most data fetched
+from the database is considered tainted. I<This may change.>
+
+The attribute defaults to off, even if Perl is in taint mode.
+See L<perlsec> for more about taint mode. If Perl is not
+running in taint mode, this attribute has no effect.
+
+When fetching data that you trust you can turn off the TaintOut attribute,
for that statement handle, for the duration of the fetch loop.
Currently only fetched data is tainted. It is possible that the results
@@ -2805,6 +2817,15 @@
applications unless you take great care now. If you use DBI Taint mode,
please report your experience and any suggestions for changes.
+=item C<Taint> (boolean, inherited)
+
+This value is shortcut for L</TaintIn> and L</TaintOut> (it is also present
+for backwards compatability).
+
+Setting this attribute sets both L</TaintIn> and L</TaintOut>, and retrieving
+it returns a true value if and only if L</TaintIn> and L</TaintOut> are
+both set to true values.
+
=item C<Profile> (inherited)
Enable collection and reporting of method call timing statistics.
Only in DBI: DBI.pm~
diff -ur DBI-1.30/DBI.xs DBI/DBI.xs
--- DBI-1.30/DBI.xs Fri Jul 19 00:23:51 2002
+++ DBI/DBI.xs Mon Sep 2 18:23:57 2002
@@ -932,7 +932,8 @@
if (DBIc_is(imp_xxh, DBIcf_BegunWork)) sv_catpv(flags,"BegunWork ");
if (DBIc_is(imp_xxh, DBIcf_LongTruncOk)) sv_catpv(flags,"LongTruncOk ");
if (DBIc_is(imp_xxh, DBIcf_MultiThread)) sv_catpv(flags,"MultiThread ");
- if (DBIc_is(imp_xxh, DBIcf_Taint)) sv_catpv(flags,"Taint ");
+ if (DBIc_is(imp_xxh, DBIcf_TaintIn)) sv_catpv(flags,"TaintIn ");
+ if (DBIc_is(imp_xxh, DBIcf_TaintOut)) sv_catpv(flags,"TaintOut ");
if (DBIc_is(imp_xxh, DBIcf_Profile)) sv_catpv(flags,"Profile ");
PerlIO_printf(DBILOGFP,"%s FLAGS 0x%lx: %s\n", pad, (long)DBIc_FLAGS(imp_xxh),
SvPV(flags,lna));
PerlIO_printf(DBILOGFP,"%s PARENT %s\n", pad,
neatsvpv((SV*)DBIc_PARENT_H(imp_xxh),0));
@@ -1109,7 +1110,7 @@
if ( (av = DBIc_FIELDS_AV(imp_sth)) == Nullav)
av = dbih_setup_fbav(imp_sth);
- if (DBIc_is(imp_sth, DBIcf_Taint)) {
+ if (DBIc_is(imp_sth, DBIcf_TaintOut)) {
dTHR;
TAINT; /* affects sv_setsv()'s called within same perl statement */
}
@@ -1321,7 +1322,14 @@
}
}
else if (strEQ(key, "Taint")) {
- DBIc_set(imp_xxh,DBIcf_Taint, on);
+ /* 'Taint' is a shortcut for both in and out mode */
+ DBIc_set(imp_xxh,DBIcf_TaintIn|DBIcf_TaintOut, on);
+ }
+ else if (strEQ(key, "TaintIn")) {
+ DBIc_set(imp_xxh,DBIcf_TaintIn, on);
+ }
+ else if (strEQ(key, "TaintOut")) {
+ DBIc_set(imp_xxh,DBIcf_TaintOut, on);
}
else if (htype<=DBIt_DB && keylen==10 && strEQ(key, "CachedKids")) {
D_imp_dbh(h); /* XXX also for drh */
@@ -1536,7 +1544,14 @@
valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_MultiThread));
}
else if (keylen==5 && strEQ(key, "Taint")) {
- valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_Taint));
+ valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_TaintIn) &&
+ DBIc_has(imp_xxh,DBIcf_TaintOut));
+ }
+ else if (keylen==7 && strEQ(key, "TaintIn")) {
+ valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_TaintIn));
+ }
+ else if (keylen==8 && strEQ(key, "TaintOut")) {
+ valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_TaintOut));
}
else if (htype<=DBIt_DB && keylen==10 && strEQ(key, "AutoCommit")) {
valuesv = boolSV(DBIc_has(imp_xxh,DBIcf_AutoCommit));
@@ -2144,7 +2159,7 @@
}
if (tainting && items > 1 /* method call has args */
- && DBIc_is(imp_xxh, DBIcf_Taint) /* taint checks requested */
+ && DBIc_is(imp_xxh, DBIcf_TaintIn) /* taint checks requested */
&& !(ima && ima->flags & IMA_NO_TAINT_IN)
) {
for(i=1; i < items; ++i) {
@@ -2337,7 +2352,7 @@
}
PerlIO_printf(logfp,"%c%c <- %s",
(call_depth > 1) ? '0'+call_depth-1 : ' ',
- (DBIc_is(imp_xxh, DBIcf_Taint)) ? 'T' : ' ',
+ (DBIc_is(imp_xxh, DBIcf_TaintIn|DBIcf_TaintOut)) ? 'T' : ' ',
meth_name);
if (debug==1 && items>=2) { /* make level 1 more useful */
/* we only have the first two parameters available here */
@@ -2401,7 +2416,7 @@
}
if (tainting
- && DBIc_is(imp_xxh, DBIcf_Taint) /* taint checks requested */
+ && DBIc_is(imp_xxh, DBIcf_TaintOut) /* taint checks requested */
/* XXX this would taint *everything* being returned from *any* */
/* method that doesn't have IMA_NO_TAINT_OUT set. */
/* DISABLED: just tainting fetched data in get_fbav seems ok */
@@ -3332,6 +3347,9 @@
croak("_set_fbav(%s): array has %d fields, should have %d%s",
neatsvpv(src_rv,0), AvFILL(src_av)+1, num_fields);
for(i=0; i < num_fields; ++i) { /* copy over the row */
+ /* If we're given the values, then taint them if required */
+ if (DBIc_is(imp_sth, DBIcf_TaintOut))
+ SvTAINT(AvARRAY(src_av)[i]);
sv_setsv(AvARRAY(dst_av)[i], AvARRAY(src_av)[i]);
}
ST(0) = sv_2mortal(newRV((SV*)dst_av));
Only in DBI: DBI.xs~
diff -ur DBI-1.30/DBIXS.h DBI/DBIXS.h
--- DBI-1.30/DBIXS.h Mon Jul 15 21:19:04 2002
+++ DBI/DBIXS.h Mon Sep 2 18:23:14 2002
@@ -227,11 +227,12 @@
#define DBIcf_AutoCommit 0x000200 /* dbh only. used by drivers */
#define DBIcf_LongTruncOk 0x000400 /* truncation to LongReadLen is okay */
#define DBIcf_MultiThread 0x000800 /* allow multiple threads to enter */
-#define DBIcf_Taint 0x001000 /* taint fetched data */
-#define DBIcf_ShowErrorStatement 0x002000 /* include Statement in error */
-#define DBIcf_BegunWork 0x004000 /* between begin_work & commit/rollback */
-#define DBIcf_HandleError 0x008000 /* has coderef in HandleError attribute */
-#define DBIcf_Profile 0x010000 /* profile activity on this handle */
+#define DBIcf_TaintIn 0x001000 /* check inputs for taintedness */
+#define DBIcf_TaintOut 0x002000 /* taint outgoing data */
+#define DBIcf_ShowErrorStatement 0x004000 /* include Statement in error */
+#define DBIcf_BegunWork 0x008000 /* between begin_work & commit/rollback */
+#define DBIcf_HandleError 0x010000 /* has coderef in HandleError attribute */
+#define DBIcf_Profile 0x020000 /* profile activity on this handle */
#define DBIcf_INHERITMASK /* what NOT to pass on to children */ \
(U32)( DBIcf_COMSET | DBIcf_IMPSET | DBIcf_ACTIVE | DBIcf_IADESTROY \
Only in DBI: DBIXS.h~
Only in DBI: Makefile.old
diff -ur DBI-1.30/lib/DBD/ExampleP.pm DBI/lib/DBD/ExampleP.pm
--- DBI-1.30/lib/DBD/ExampleP.pm Mon Jul 15 21:19:20 2002
+++ DBI/lib/DBD/ExampleP.pm Mon Sep 2 18:24:51 2002
@@ -326,6 +326,8 @@
$sth->finish;
return;
}
+ # untaint $f so that we can use this for DBI taint tests
+ ($f) = ($f =~ m/^(.*)$/);
my $file = $haveFileSpec
? File::Spec->catfile($dir, $f) : "$dir/$f";
# put in all the data fields
Only in DBI/lib/DBD: ExampleP.pm~
diff -ur DBI-1.30/lib/DBI/PurePerl.pm DBI/lib/DBI/PurePerl.pm
--- DBI-1.30/lib/DBI/PurePerl.pm Mon Jul 15 21:19:22 2002
+++ DBI/lib/DBI/PurePerl.pm Wed Aug 21 11:04:18 2002
@@ -134,6 +134,8 @@
ShowErrorStatement
Statement
Taint
+ TaintIn
+ TaintOut
TraceLevel
Version
Warn
@@ -492,6 +494,9 @@
$i++;
}
}
+ if ($key eq "Taint") {
+ return ($h->{'TaintIn'} && $h->{'TaintOut'});
+ }
my $v = $h->{$key};
if (!defined $v && !exists $h->{$key}) {
local $^W; # hide undef warnings
@@ -507,6 +512,13 @@
unless $value == -900 || $value == -901;
$value = ($value == -901);
}
+ elsif (($key eq 'Taint' || $key eq 'TaintIn' || $key eq 'TaintOut')) {
+ Carp::croak(sprintf "Can't set %s->{%s}: Taint mode not supported by
+DBI::PurePerl",$h,$key);
+ }
+ elsif ($key eq 'Taint') {
+ $h->{'TaintIn'} = $h->{'TaintOut'} = $value;
+ return 1;
+ }
elsif (!$is_valid_attribute{$key} && $key =~ /^[A-Z]/ && !exists $h->{$key}) {
Carp::croak(sprintf "Can't set %s->{%s}: unrecognised attribute or invalid
value %s",
$h,$key,$value);
@@ -752,6 +764,8 @@
InactiveDestroy
Kids
Taint
+ TaintIn
+ TaintOut
TraceLevel
(and probably others)
Only in DBI/lib/DBI: PurePerl.pm~
diff -ur DBI-1.30/t/10examp.t DBI/t/10examp.t
--- DBI-1.30/t/10examp.t Mon Jul 15 21:19:08 2002
+++ DBI/t/10examp.t Mon Sep 2 17:43:01 2002
@@ -35,11 +35,13 @@
DBI->trace(3,$trace_file); # enable trace before first driver load
my $r;
-my $dbh = DBI->connect('dbi:ExampleP(AutoCommit=>1 ,Taint = 1):', undef, undef);
+my $dbh = DBI->connect('dbi:ExampleP(AutoCommit=>1):', undef, undef);
die "Unable to connect to ExampleP driver: $DBI::errstr" unless $dbh;
ok(0, $dbh);
ok(0, ref $dbh);
+$dbh->{Taint} = 1 unless $DBI::PurePerl;
+
if (0) {
DBI->trace(9,undef);
warn DBI::dump_handle($dbh,"dump_handle",1);
@@ -67,7 +69,7 @@
#$dbh->trace(2);
$dbh->{AutoCommit} = 1;
$dbh->{PrintError} = 0;
-ok(0, $dbh->{Taint} == 1);
+ok(0, $dbh->{Taint} == 1) unless $DBI::PurePerl && ok(0,1);
ok(0, $dbh->{AutoCommit} == 1);
ok(0, $dbh->{PrintError} == 0);
#$dbh->trace(0); die;
@@ -158,6 +160,38 @@
ok(0, "@{[sort keys %{$csr_b->{NAME_uc_hash}}]}" eq "MODE NAME SIZE");
ok(0, "@{[sort values %{$csr_b->{NAME_uc_hash}}]}" eq "0 1 2");
+if ($DBI::PurePerl) {
+ warn " Taint mode switching tests skipped\n";
+ ok(0,1) foreach (1..15);
+} else {
+ # Check Taint* attribute switching
+
+ #$dbh->{'Taint'} = 1; # set in connect
+ ok(0, $dbh->{'Taint'});
+ ok(0, $dbh->{'TaintIn'} == 1);
+ ok(0, $dbh->{'TaintOut'} == 1);
+
+ $dbh->{'TaintOut'} = 0;
+ ok(0, $dbh->{'Taint'} == 0);
+ ok(0, $dbh->{'TaintIn'} == 1);
+ ok(0, $dbh->{'TaintOut'} == 0);
+
+ $dbh->{'Taint'} = 0;
+ ok(0, $dbh->{'Taint'} == 0);
+ ok(0, $dbh->{'TaintIn'} == 0);
+ ok(0, $dbh->{'TaintOut'} == 0);
+
+ $dbh->{'TaintIn'} = 1;
+ ok(0, $dbh->{'Taint'} == 0);
+ ok(0, $dbh->{'TaintIn'} == 1);
+ ok(0, $dbh->{'TaintOut'} == 0);
+
+ $dbh->{'TaintOut'} = 1;
+ ok(0, $dbh->{'Taint'} == 1);
+ ok(0, $dbh->{'TaintIn'} == 1);
+ ok(0, $dbh->{'TaintOut'} == 1);
+}
+
# get a dir always readable on all platforms
my $dir = getcwd() || cwd();
$dir = VMS::Filespec::unixify($dir) if $^O eq 'VMS';
@@ -173,7 +207,7 @@
#$csr_a->trace(2);
ok(0, $csr_a->bind_columns(undef, \($col0, $col1, $col2)) );
ok(0, $csr_a->execute( $dir ));
-ok(0, $csr_a->{Taint} = 1);
+ok(0, $csr_a->{Taint} = 1) unless $DBI::PurePerl && ok(0,1);
@row_a = $csr_a->fetchrow_array;
ok(0, @row_a);
@@ -189,29 +223,81 @@
my $foo;
return ! eval { ($foo=join('',@_)), kill 0; 1; };
}
-if (is_tainted($^X)) {
+if (is_tainted($^X) && !$DBI::PurePerl) {
print "Taint attribute test enabled\n";
- ok(0, is_tainted($row_a[0]) );
- ok(0, is_tainted($row_a[1]) );
- ok(0, is_tainted($row_a[2]) );
- # check simple method call values
- ok(0, 1);
- # check simple attribute values
- ok(0, 1); # is_tainted($dbh->{AutoCommit}) );
- # check nested attribute values (where a ref is returned)
+ $dbh->{'Taint'} = 0;
+ my $st;
+ eval { $st = $dbh->prepare($std_sql); };
+ ok(0, ref $st);
+
+ ok(0, $st->{'Taint'} == 0);
+
+ ok(0, $st->execute( $dir ));
+
+ my @row = $st->fetchrow_array;
+ ok(0, @row);
+
+ ok(0, !is_tainted($row[0]));
+ ok(0, !is_tainted($row[1]));
+ ok(0, !is_tainted($row[2]));
+
+ $st->{'TaintIn'} = 1;
+
+ @row = $st->fetchrow_array;
+ ok(0, @row);
+
+ ok(0, !is_tainted($row[0]));
+ ok(0, !is_tainted($row[1]));
+ ok(0, !is_tainted($row[2]));
+
+ $st->{'TaintOut'} = 1;
+
+ @row = $st->fetchrow_array;
+ ok(0, @row);
+
+ ok(0, is_tainted($row[0]));
+ ok(0, is_tainted($row[1]));
+ ok(0, is_tainted($row[2]));
+
+ $st->finish;
+
+ # check simple method call values
+ #ok(0, 1);
+ # check simple attribute values
+ #ok(0, 1); # is_tainted($dbh->{AutoCommit}) );
+ # check nested attribute values (where a ref is returned)
#ok(0, is_tainted($csr_a->{NAME}->[0]) );
- # check checking for tainted values
- eval { $dbh->prepare($^X); 1; };
- ok(0, $@ =~ /Insecure dependency/, $@);
- eval { $csr_a->execute($^X); 1; };
- ok(0, $@ =~ /Insecure dependency/, $@);
+ # check checking for tainted values
+
+ $dbh->{'Taint'} = $csr_a->{'Taint'} = 1;
+ eval { $dbh->prepare($^X); 1; };
+ ok(0, $@ =~ /Insecure dependency/, $@);
+ eval { $csr_a->execute($^X); 1; };
+ ok(0, $@ =~ /Insecure dependency/, $@);
undef $@;
+
+ $dbh->{'TaintIn'} = $csr_a->{'TaintIn'} = 0;
+
+ eval { $dbh->prepare($^X); 1; };
+ ok(0, !$@);
+ eval { $csr_a->execute($^X); 1; };
+ ok(0, !$@);
+
+ # Reset taint status to what it was before this block, so that
+ # tests later in the file don't get confused
+ $dbh->{'Taint'} = $csr_a->{'Taint'} = 1;
}
else {
warn " Taint attribute tests skipped\n";
- ok(0,1) foreach (1..7);
+ ok(0,1) foreach (1..19);
+}
+
+unless ($DBI::PurePerl) {
+ $csr_a->{Taint} = 0;
+ ok(0, $csr_a->{Taint} == 0);
+} else {
+ ok(0, 1);
}
-$csr_a->{Taint} = 0;
ok(0, $csr_b->bind_param(1, $dir));
ok(0, $csr_b->execute());
@@ -574,4 +660,4 @@
}
ok(0, (%tables == 0));
-BEGIN { $tests = 215; }
+BEGIN { $tests = 243; }
Only in DBI/t: 10examp.t~
Only in DBI/t: zz_01basics_pp.t
Only in DBI/t: zz_02dbidrv_pp.t
Only in DBI/t: zz_03hleak_pp.t
Only in DBI/t: zz_04mods_pp.t
Only in DBI/t: zz_05thrclone_pp.t
Only in DBI/t: zz_10examp_pp.t
Only in DBI/t: zz_15array_pp.t
Only in DBI/t: zz_20meta_pp.t
Only in DBI/t: zz_30subclass_pp.t
Only in DBI/t: zz_40profile_pp.t
Only in DBI/t: zz_60preparse_pp.t
Only in DBI/t: zz_70shell_pp.t
Only in DBI/t: zz_80proxy_pp.t
