Re: DBD::File

On Wed, 15 Oct 2014 21:39:47 +0200, Jens Rehsack <[email protected]>
wrote:

> 
> Am 15.10.2014 um 19:16 schrieb H.Merijn Brand <[email protected]>:
> 
> > 
> > my $dbh = DBI->connect ("dbi:CSV:f_dir=.");
> > 
> > # do something with $dbh
> > 
> > $dbh->disconnect;
> > 
> > $dbh = DBI->connect ("dbi:CSV:f_dir=test");
> > 
> > The second connect does NOT call data_sources () using whatever the
> > first left behind. I think that is a serious bug.
> > 
> > Found that while trying to find an issue found by Mithaldu where
> > 
> > $dbh = DBI->connect ("dbi:CSV:f_dir=./non_existent");
> > 
> > will *always* fall back to "." (curdir), which IMHO is just as serious
> > a bug.
> 
> I completely agree above analysis.
> 
> > /me is digging …
> 
> Thanks. Will join next week or so when finished PoC using AnyData (purely ...)

doubt: should DBD::File::connect croak or should it return undef and
set the error?

Other than that, the important fix is, which I plan to apply after we
decide to croak or return undef/errstr (of course with a not in
Changes):

--8<---
diff --git a/lib/DBD/File.pm b/lib/DBD/File.pm
index 590a351..90336b5 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,26 @@ sub dsn_quote
 # XXX rewrite using TableConfig ...
 sub default_table_source { "DBD::File::TableSource::FileSystem" }

+sub connect
+{
+    my ($drh, $dbname, $user, $auth, $attr) = @_;
+
+    if (my $attr_hash = (DBI->parse_dsn ($dbname))[3]) {
+       if (defined $attr_hash->{f_dir} && ! -d $attr_hash->{f_dir}) {
+           #DBI->set_err (2, "No such directory '$attr_hash->{f_dir}");
+           #croak "No such directory '$attr_hash->{f_dir}'";
+           return;
+           }
+       }
+    if ($attr and defined $attr->{f_dir} && ! -d $attr->{f_dir}) {
+       #DBI->set_err (2, "No such directory '$attr_hash->{f_dir}");
+       #croak "No such directory '$attr->{f_dir}'";
+       return;
+       }
+
+    return DBI::DBD::SqlEngine::dr::connect ($drh, $dbname, $user, $auth, $attr);
+    } # connect
+
 sub disconnect_all
 {
     } # disconnect_all
@@ -130,7 +152,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 +365,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 main directory $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 1883bfa..60ea6cb 100644
--- a/t/49dbd_file.t
+++ b/t/49dbd_file.t
@@ -207,6 +207,16 @@ 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 ========================
+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 a non-existig folder");
+    }
+
 done_testing ();

 sub DBD::File::Table::fetch_row ($$)
-->8---

I did not yet find the correct way to specify DBI::errstr :(


-- 
H.Merijn Brand  http://tux.nl   Perl Monger  http://amsterdam.pm.org/
using perl5.00307 .. 5.19   porting perl5 on HP-UX, AIX, and openSUSE
http://mirrors.develooper.com/hpux/        http://www.test-smoke.org/
http://qa.perl.org   http://www.goldmark.org/jeff/stupid-disclaimers/

-----BEGIN PGP SIGNATURE-----
Version: GnuPG v2.0.22 (GNU/Linux)

iQEcBAEBAgAGBQJUP4giAAoJEAOhR6E+XcCY0nUH/1hWDXT/yNnbOmaieRojKFfp
iHt+aFkUZQSj5fnm+XJS9HaQ2/Nsf3HnKc7TEq/jonx7pP2CWUcde2zL6EHMugYg
npXTLBSPAZyotDL1H/wyPFTc5xYEY34ku8dp+3lfDzwQFyigK+JJCZDNHt1CRarM
lRNtkOWlCbNU7vQloAqsNYVHen4WfpEjNWtJdZcXB3oR7AG7pb0DDYP/1hfJFBSZ
vkzskqV5sEIcIPpC4V+nn701BsUrXF1MoO6yjFgNhrBWOuo4+SkR/6Y2ggIp5O2x
0dgVYVlKZ/B8gXpHp4dvSnmmFXE7CIRc/pa9K387F9KOBNM43t0/8aqMSuf2iSU=
=DCs2
-----END PGP SIGNATURE-----