diff options
Diffstat (limited to 't/49dbd_file.t')
| -rw-r--r-- | t/49dbd_file.t | 174 |
1 files changed, 174 insertions, 0 deletions
diff --git a/t/49dbd_file.t b/t/49dbd_file.t new file mode 100644 index 0000000..0c64328 --- /dev/null +++ b/t/49dbd_file.t @@ -0,0 +1,174 @@ +#!perl -w +$|=1; + +use strict; + +use Cwd; +use File::Path; +use File::Spec; +use Test::More; + +my $using_dbd_gofer = ($ENV{DBI_AUTOPROXY}||"") =~ /^dbi:Gofer.*transport=/i; + +my $tbl; +BEGIN { $tbl = "db_". $$ . "_" }; +#END { $tbl and unlink glob "${tbl}*" } + +use_ok ("DBI"); +use_ok ("DBD::File"); + +do "t/lib.pl"; + +my $dir = test_dir (); + +my $rowidx = 0; +my @rows = ( [ "Hello World" ], [ "Hello DBI Developers" ], ); + +my $dbh; + +# Check if we can connect at all +ok ($dbh = DBI->connect ("dbi:File:"), "Connect clean"); +is (ref $dbh, "DBI::db", "Can connect to DBD::File driver"); + +my $f_versions = $dbh->func ("f_versions"); +note $f_versions; +ok ($f_versions, "f_versions"); + +# Check if all the basic DBI attributes are accepted +ok ($dbh = DBI->connect ("dbi:File:", undef, undef, { + RaiseError => 1, + PrintError => 1, + AutoCommit => 1, + ChopBlanks => 1, + ShowErrorStatement => 1, + FetchHashKeyName => "NAME_lc", + }), "Connect with DBI attributes"); + +# Check if all the f_ attributes are accepted, in two ways +ok ($dbh = DBI->connect ("dbi:File:f_ext=.txt;f_dir=.;f_encoding=cp1252;f_schema=test"), "Connect with driver attributes in DSN"); + +my $encoding = "iso-8859-1"; + +# now use dir to prove file existence +ok ($dbh = DBI->connect ("dbi:File:", undef, undef, { + f_ext => ".txt", + f_dir => $dir, + f_schema => undef, + f_encoding => $encoding, + f_lock => 0, + + RaiseError => 0, + PrintError => 0, + }), "Connect with driver attributes in hash"); + +my $sth; +ok ($sth = $dbh->prepare ("select * from t_sbdgf_53442Gz"), "Prepare select from non-existing file"); + +{ my @msg; + eval { + local $SIG{__DIE__} = sub { push @msg, @_ }; + $sth->execute; + }; + like ("@msg", qr{Cannot open .*t_sbdgf_}, "Cannot open non-existing file"); + eval { + note $dbh->f_get_meta ("t_sbdgf_53442Gz", "f_fqfn"); + }; + } + +SKIP: { + my $fh; + my $tbl2 = $tbl . "2"; + + my $tbl2_file1 = File::Spec->catfile ($dir, "$tbl2.txt"); + open $fh, ">", $tbl2_file1 or skip; + print $fh "You cannot read this anyway ..."; + close $fh; + + my $tbl2_file2 = File::Spec->catfile ($dir, "$tbl2"); + open $fh, ">", $tbl2_file2 or skip; + print $fh "Neither that"; + close $fh; + + ok ($dbh->do ("drop table if exists $tbl2"), "drop manually created table $tbl2 (first file)"); + ok (! -f $tbl2_file1, "$tbl2_file1 removed"); + ok ( -f $tbl2_file2, "$tbl2_file2 exists"); + ok ($dbh->do ("drop table if exists $tbl2"), "drop manually created table $tbl2 (second file)"); + ok (! -f $tbl2_file2, "$tbl2_file2 removed"); + } + +my @tfhl; + +# Now test some basic SQL statements +my $tbl_file = File::Spec->catfile (Cwd::abs_path( $dir ), "$tbl.txt"); +ok ($dbh->do ("create table $tbl (txt varchar (20))"), "Create table $tbl") or diag $dbh->errstr; +ok (-f $tbl_file, "Test table exists"); + +is ($dbh->f_get_meta ($tbl, "f_fqfn"), $tbl_file, "get single table meta data"); +is_deeply ($dbh->f_get_meta ([$tbl, "t_sbdgf_53442Gz"], [qw(f_dir f_ext)]), + { + $tbl => { + f_dir => $dir, + f_ext => ".txt", + }, + t_sbdgf_53442Gz => { + f_dir => $dir, + f_ext => ".txt", + }, + }, + "get multiple meta data"); + +# Expected: ("unix", "perlio", "encoding(iso-8859-1)") +# use Data::Peek; DDumper [ @tfh ]; +my @layer = grep { $_ eq "encoding($encoding)" } @tfhl; +is (scalar @layer, 1, "encoding shows in layer"); + +SKIP: { + $using_dbd_gofer and skip "modifying meta data doesn't work with Gofer-AutoProxy", 4; + ok ($dbh->f_set_meta ($tbl, "f_dir", $dir), "set single meta datum"); + is ($tbl_file, $dbh->f_get_meta ($tbl, "f_fqfn"), "verify set single meta datum"); + ok ($dbh->f_set_meta ($tbl, { f_dir => $dir }), "set multiple meta data"); + is ($tbl_file, $dbh->f_get_meta ($tbl, "f_fqfn"), "verify set multiple meta attributes"); + } + +ok ($sth = $dbh->prepare ("select * from $tbl"), "Prepare select * from $tbl"); +$rowidx = 0; +SKIP: { + $using_dbd_gofer and skip "method intrusion didn't work with proxying", 1; + ok ($sth->execute, "execute on $tbl"); + $dbh->errstr and diag; + } + +my $uctbl = uc($tbl); +ok ($sth = $dbh->prepare ("select * from $uctbl"), "Prepare select * from $uctbl"); +$rowidx = 0; +SKIP: { + $using_dbd_gofer and skip "method intrusion didn't work with proxying", 1; + ok ($sth->execute, "execute on $uctbl"); + $dbh->errstr and diag; + } + +ok ($dbh->do ("drop table $tbl"), "table drop"); +is (-s "$tbl.txt", undef, "Test table removed"); + +done_testing (); + +sub DBD::File::Table::fetch_row ($$) +{ + my ($self, $data) = @_; + my $meta = $self->{meta}; + if ($rowidx >= scalar @rows) { + $self->{row} = undef; + } + else { + $self->{row} = $rows[$rowidx++]; + } + return $self->{row}; + } # fetch_row + +sub DBD::File::Table::push_names ($$$) +{ + my ($self, $data, $row_aryref) = @_; + my $meta = $self->{meta}; + @tfhl = PerlIO::get_layers ($meta->{fh}); + @{$meta->{col_names}} = @{$row_aryref}; + } # push_names |