CVE-2014-10401 (published 2020-09-11T19:15Z)

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.

Severity: LOW
CVSS v2 base score: 3.6 (AV:L/AC:L/Au:N/C:P/I:N/A:P)
CVSS v3 base score: 6.1, MEDIUM (CVSS:3.1/AV:L/AC:L/PR:L/UI:N/S:U/C:H/I:N/A:L)

Weakness information:
cwe_id: CWE-732
cwe_name: Incorrect Permission Assignment for Critical Resource
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.
extended_description: When a resource is given a permission setting that provides access to a wider range of actors than required, it could lead to the exposure of sensitive information, or the modification of that resource by unintended parties. This is especially dangerous when the resource is related to program configuration, execution, or sensitive user data. For example, consider a misconfigured storage account for the cloud that can be read or written by a public or anonymous user.
         

Fix information:
repo_url: https://github.com/perl5-dbi/dbi
commit_details: repo_url: https://github.com/perl5-dbi/dbi
author: H.Merijn Brand - Tux
author_date: 2014-10-16 17:18:56+02:00
msg: Do not connect DBD::File on non-existing folder in f_dir
repository: repo_url: https://github.com/perl5-dbi/dbi
repo_name: perl5-dbi/dbi
description: DBI - The Perl 5 Database Interface
repo_language: Perl
owner: perl5-dbi
file_changes: filename: Changes
change_type: ModificationType.MODIFY
diff: @@ -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.

programming_language: Markdown
filename: File.pm
change_type: ModificationType.MODIFY
diff: @@ -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};

programming_language: Perl
filename: 49dbd_file.t
change_type: ModificationType.MODIFY
diff: @@ -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 ($$)

programming_language: Perl