File perl-DBI-CVE-2014-10402.patch of Package perl-DBI.35400

Index: DBI-1.628/lib/DBD/File.pm
===================================================================
--- DBI-1.628.orig/lib/DBD/File.pm
+++ DBI-1.628/lib/DBD/File.pm
@@ -85,6 +85,8 @@ use warnings;
 
 use vars qw( @ISA $imp_data_size );
 
+use Carp;
+
 @DBD::File::dr::ISA           = qw( DBI::DBD::SqlEngine::dr );
 $DBD::File::dr::imp_data_size = 0;
 
@@ -100,6 +102,34 @@ sub dsn_quote
 # XXX rewrite using TableConfig ...
 sub default_table_source { "DBD::File::TableSource::FileSystem" }
 
+sub connect
+{
+    my ($drh, $dbname, $user, $auth, $attr) = @_;
+
+    # We do not (yet) care about conflicting attributes here
+    # my $dbh = DBI->connect ("dbi:CSV:f_dir=test", undef, undef, { f_dir => "text" });
+    # will test here that both test and text should exist
+    #
+    # Parsing on our own similar to parse_dsn to find attributes in 'dbname' parameter.
+    if ($dbname) {
+	my @attrs = split /;/ => $dbname;
+	my $attr_hash = { map { split /\s*=>?\s*|\s*,\s*/, $_} @attrs };
+	if (defined $attr_hash->{f_dir} && ! -d $attr_hash->{f_dir}) {
+	    my $msg = "No such directory '$attr_hash->{f_dir}";
+	    $drh->set_err (2, $msg);
+	    $attr_hash->{RaiseError} and croak $msg;
+	    return;
+	    }
+	}
+    if ($attr and defined $attr->{f_dir} && ! -d $attr->{f_dir}) {
+	my $msg = "No such directory '$attr->{f_dir}";
+	$drh->set_err (2, $msg);
+	return;
+	}
+
+    return $drh->SUPER::connect ($dbname, $user, $auth, $attr);
+    } # connect
+
 sub disconnect_all
 {
     } # disconnect_all
@@ -130,7 +160,7 @@ sub data_sources
 {
     my ($dbh, $attr, @other) = @_;
     ref ($attr) eq "HASH" or $attr = {};
-    exists $attr->{f_dir}        or $attr->{f_dir}     = $dbh->{f_dir};
+    exists $attr->{f_dir}        or $attr->{f_dir}        = $dbh->{f_dir};
     exists $attr->{f_dir_search} or $attr->{f_dir_search} = $dbh->{f_dir_search};
     return $dbh->SUPER::data_sources ($attr, @other);
     } # data_source
@@ -343,6 +373,10 @@ sub data_sources
 	? $attr->{f_dir}
 	: File::Spec->curdir ();
     defined $dir or return; # Stream-based databases do not have f_dir
+    unless (-d $dir && -r $dir && -x $dir) {
+	$drh->set_err ($DBI::stderr, "Cannot use directory $dir from f_dir");
+	return;
+	}
     my %attrs;
     $attr and %attrs = %$attr;
     delete $attrs{f_dir};
@@ -994,6 +1028,11 @@ directory) when the dbh attribute is set
 
   f_dir => "/data/foo/csv",
 
+If C<f_dir> is set to a non-existing location, the connection will fail.
+See CVE-2014-10401 for reasoning. Because of this, folders to use cannot
+be created after the connection, but must exist before the connection is
+initiated.
+
 See L<KNOWN BUGS AND LIMITATIONS>.
 
 =head4 f_dir_search
Index: DBI-1.628/t/51dbm_file.t
===================================================================
--- DBI-1.628.orig/t/51dbm_file.t
+++ DBI-1.628/t/51dbm_file.t
@@ -15,6 +15,31 @@ use DBI;
 
 do "t/lib.pl";
 
+{
+    # test issue reported in RT#99508
+    my @msg;
+    my $dbh = eval {
+	local $SIG{__WARN__} = sub { push @msg, @_ };
+	local $SIG{__DIE__}  = sub { push @msg, @_ };
+	DBI->connect ("dbi:DBM:f_dir=./hopefully-doesnt-existst;sql_identifier_case=1;RaiseError=1");
+    };
+    is ($dbh, undef, "Connect failed");
+    like ("@msg", qr{.*hopefully-doesnt-existst.*}, "Cannot open from non-existing directory with attributes in DSN");
+
+    @msg = ();
+    $dbh = eval {
+	local $SIG{__WARN__} = sub { push @msg, @_ };
+	local $SIG{__DIE__}  = sub { push @msg, @_ };
+	DBI->connect ("dbi:DBM:", , undef, undef, {
+	    f_dir               => "./hopefully-doesnt-existst",
+	    sql_identifier_case => 1,
+	    RaiseError          => 1,
+	});
+    };
+    is ($dbh, undef, "Connect failed");
+    like ("@msg", qr{.*hopefully-doesnt-existst}, "Cannot open from non-existing directory with attributes in HASH");
+}
+
 my $dir = test_dir();
 
 my $dbh = DBI->connect( 'dbi:DBM:', undef, undef, {
@@ -23,6 +48,8 @@ my $dbh = DBI->connect( 'dbi:DBM:', unde
     }
 );
 
+ok( $dbh, "Connect with driver attributes in hash" );
+
 ok( $dbh->do(q/drop table if exists FRED/), 'drop table' );
 
 my $dirfext = $^O eq 'VMS' ? '.sdbm_dir' : '.dir';
Index: DBI-1.628/t/49dbd_file.t
===================================================================
--- DBI-1.628.orig/t/49dbd_file.t
+++ DBI-1.628/t/49dbd_file.t
@@ -207,6 +207,31 @@ ok ($dbh = DBI->connect ("dbi:File:", un
 ok ($dbh->do ("drop table $tbl"), "table drop");
 is (-s $tbl_file, undef, "Test table removed"); # -s => size test
 
+# ==================== Nonexisting top-dir ========================
+my %drh = DBI->installed_drivers;
+my $qer = qr{\bNo such directory};
+foreach my $tld ("./non-existing", "nonexisting_folder", "/Fr-dle/hurd0k/ok$$") {
+    is (DBI->connect ("dbi:File:", undef, undef, {
+	f_dir      => $tld,
+
+	RaiseError => 0,
+	PrintError => 0,
+	}), undef, "Should not be able to open a DB to $tld");
+    like ($DBI::errstr, $qer, "Error message");
+    $drh{File}->set_err (undef, "");
+    is ($DBI::errstr, undef, "Cleared error");
+    my $dbh;
+    eval { $dbh = DBI->connect ("dbi:File:", undef, undef, {
+	f_dir      => $tld,
+
+	RaiseError => 1,
+	PrintError => 0,
+	})};
+    is ($dbh, undef, "connect () should die on $tld with RaiseError");
+    like ($@,           $qer, "croak message");
+    like ($DBI::errstr, $qer, "Error message");
+    }
+
 done_testing ();
 
 sub DBD::File::Table::fetch_row ($$)