From caedc0d7d602f5b2ae5efc1b00f39efeafb7b05a Mon Sep 17 00:00:00 2001
From: "H.Merijn Brand - Tux" <h.m.brand@xs4all.nl>
Date: Thu, 16 Oct 2014 17:18:56 +0200
Subject: [PATCH] Do not connect DBD::File on non-existing folder in f_dir

---
 Changes         |  3 +++
 lib/DBD/File.pm | 33 ++++++++++++++++++++++++++++++++-
 t/49dbd_file.t  | 25 +++++++++++++++++++++++++
 3 files changed, 60 insertions(+), 1 deletion(-)

diff --git a/Changes b/Changes
index 7acf30f7..13d06e90 100644
--- a/Changes
+++ b/Changes
@@ -16,6 +16,9 @@ DBI::Changes - List of significant changes to the DBI
     Fixed DBI::DBD::SqlEngine to complain loudly when prerequite
         driver_prefix is not fulfilled (RT#93204) [Jens Rehsack]
     Fixed redundant sprintf argument warning RT#97062 [Reini Urban]
+    Fixed security issue where DBD::File drivers would open files
+        from folders other than specifically passed using the
+        f_dir attribute RT#99508 [H.Merijn Brand]
 
     Changed delete $h->{$key} to work for keys with 'private_' prefix
         per request in RT#83156. local $h->{$key} works as before.
diff --git a/lib/DBD/File.pm b/lib/DBD/File.pm
index 590a351b..373fecc6 100644
--- a/lib/DBD/File.pm
+++ b/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,31 @@ 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
+    if (my $attr_hash = (DBI->parse_dsn ($dbname))[3]) {
+	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);
+	$attr->{RaiseError} and croak $msg;
+	return;
+	}
+
+    return $drh->SUPER::connect ($dbname, $user, $auth, $attr);
+    } # connect
+
 sub disconnect_all
 {
     } # disconnect_all
@@ -130,7 +157,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 +370,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};
diff --git a/t/49dbd_file.t b/t/49dbd_file.t
index 1883bfaf..51cb9304 100644
--- a/t/49dbd_file.t
+++ b/t/49dbd_file.t
@@ -207,6 +207,31 @@ ok ($dbh = DBI->connect ("dbi:File:", undef, undef, {
 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 ($$)