1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
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
|
