CVE-2014-10401: Incorrect Permission Assignment for Critical Resource (CWE-732)
value: An issue was discovered in the DBI module before 1.632 for Perl. DBD::File drivers can open files from folders other than those specifically passed via the f_dir attribute.
CWE description: The product specifies permissions for a security-critical resource in a way that allows that resource to be read or modified by unintended actors.
CVSS v3 base score: 6.1
Published: 2020-09-11T19:15Z
Repository: https://github.com/perl5-dbi/dbi
Language: Other
Files changed: Changes, lib/DBD/File.pm, t/49dbd_file.t
Commit date: 2014-10-16 17:18:56 +0200
Commit message: Do not connect DBD::File on non-existing folder in f_dir

Diff: diff --git a/Changes b/Changes
index 7acf30f7..13d06e90 100644
--- a/Changes
+++ b/Changes
@@ -14,10 +14,13 @@ DBI::Changes - List of significant changes to the DBI
     Fixed DBD::PurePerl to not set $sth->{Active} true by default
         drivers are expected to set it true as needed.
     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.
 
     Added security notice to DBD::Proxy and DBI::ProxyServer because they
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
@@ -83,10 +83,12 @@ package DBD::File::dr;
 use strict;
 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;
 
 sub dsn_quote
 {
@@ -98,10 +100,35 @@ sub dsn_quote
     } # 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
 
 sub DESTROY
@@ -128,11 +155,11 @@ $DBD::File::db::imp_data_size = 0;
 
 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
 
 sub set_versions
@@ -341,10 +368,14 @@ sub data_sources
     my ($class, $drh, $attr) = @_;
     my $dir = $attr && exists $attr->{f_dir}
 	? $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};
     my $dsn_quote = $drh->{ImplementorClass}->can ("dsn_quote");
     my $dsnextra = join ";", map { $_ . "=" . &{$dsn_quote} ($attrs{$_}) } keys %attrs;
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
@@ -205,10 +205,35 @@ ok ($dbh = DBI->connect ("dbi:File:", undef, undef, {
 # XXX add a truncate test
 
 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 ($$)
 {
     my ($self, $data) = @_;

Vulnerable code:     exists $attr->{f_dir}        or $attr->{f_dir}     = $dbh->{f_dir};
Fixed code:     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]
use Carp;

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

    exists $attr->{f_dir}        or $attr->{f_dir}        = $dbh->{f_dir};
    unless (-d $dir && -r $dir && -x $dir) {
	$drh->set_err ($DBI::stderr, "Cannot use directory $dir from f_dir");
	return;
	}
# ==================== 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");
    }