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
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
|
#!perl -w
use strict;
use Test::More tests => 148;
## ----------------------------------------------------------------------------
## 06attrs.t - ...
## ----------------------------------------------------------------------------
# This test checks the parameters and the values associated with them for
# the three different handles (Driver, Database, Statement)
## ----------------------------------------------------------------------------
BEGIN {
use_ok( 'DBI' )
}
$|=1;
my $using_autoproxy = ($ENV{DBI_AUTOPROXY});
my $dsn = 'dbi:ExampleP:dummy';
# Connect to the example driver.
my $dbh = DBI->connect($dsn, '', '', {
PrintError => 0, RaiseError => 1,
});
isa_ok( $dbh, 'DBI::db' );
# Clean up when we're done.
END { $dbh->disconnect if $dbh };
## ----------------------------------------------------------------------------
# Check the database handle attributes.
# bit flag attr
ok( $dbh->{Warn}, '... checking Warn attribute for dbh');
ok( $dbh->{Active}, '... checking Active attribute for dbh');
ok( $dbh->{AutoCommit}, '... checking AutoCommit attribute for dbh');
ok(!$dbh->{CompatMode}, '... checking CompatMode attribute for dbh');
ok(!$dbh->{InactiveDestroy}, '... checking InactiveDestory attribute for dbh');
ok(!$dbh->{AutoInactiveDestroy}, '... checking AutoInactiveDestory attribute for dbh');
ok(!$dbh->{PrintError}, '... checking PrintError attribute for dbh');
ok( $dbh->{PrintWarn}, '... checking PrintWarn attribute for dbh'); # true because of perl -w above
ok( $dbh->{RaiseError}, '... checking RaiseError attribute for dbh');
ok(!$dbh->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for dbh');
ok(!$dbh->{ChopBlanks}, '... checking ChopBlanks attribute for dbh');
ok(!$dbh->{LongTruncOk}, '... checking LongTrunkOk attribute for dbh');
ok(!$dbh->{TaintIn}, '... checking TaintIn attribute for dbh');
ok(!$dbh->{TaintOut}, '... checking TaintOut attribute for dbh');
ok(!$dbh->{Taint}, '... checking Taint attribute for dbh');
ok(!$dbh->{Executed}, '... checking Executed attribute for dbh');
# other attr
cmp_ok($dbh->{ErrCount}, '==', 0, '... checking ErrCount attribute for dbh');
SKIP: {
skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if $DBI::PurePerl;
cmp_ok($dbh->{Kids}, '==', 0, '... checking Kids attribute for dbh');;
cmp_ok($dbh->{ActiveKids}, '==', 0, '... checking ActiveKids attribute for dbh');;
}
is($dbh->{CachedKids}, undef, '... checking CachedKids attribute for dbh');
ok(!defined $dbh->{HandleError}, '... checking HandleError attribute for dbh');
ok(!defined $dbh->{Profile}, '... checking Profile attribute for dbh');
ok(!defined $dbh->{Statement}, '... checking Statement attribute for dbh');
ok(!defined $dbh->{RowCacheSize}, '... checking RowCacheSize attribute for dbh');
ok(!defined $dbh->{ReadOnly}, '... checking ReadOnly attribute for dbh');
is($dbh->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute for dbh');
is($dbh->{Name}, 'dummy', '... checking Name attribute for dbh') # fails for Multiplex
unless $using_autoproxy && ok(1);
cmp_ok($dbh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for dbh');
cmp_ok($dbh->{LongReadLen}, '==', 80, '... checking LongReadLen attribute for dbh');
is_deeply [ $dbh->FETCH_many(qw(HandleError FetchHashKeyName LongReadLen ErrCount)) ],
[ undef, qw(NAME 80 0) ], 'should be able to FETCH_many';
is $dbh->{examplep_private_dbh_attrib}, 42, 'should see driver-private dbh attribute value';
# Raise an error.
eval {
$dbh->do('select foo from foo')
};
like($@, qr/^DBD::\w+::db do failed: Unknown field names: foo/ , '... catching exception');
ok(defined $dbh->err, '... $dbh->err is undefined');
like($dbh->errstr, qr/^Unknown field names: foo\b/, '... checking $dbh->errstr');
is($dbh->state, 'S1000', '... checking $dbh->state');
ok($dbh->{Executed}, '... checking Executed attribute for dbh'); # even though it failed
$dbh->{Executed} = 0; # reset(able)
cmp_ok($dbh->{Executed}, '==', 0, '... checking Executed attribute for dbh (after reset)');
cmp_ok($dbh->{ErrCount}, '==', 1, '... checking ErrCount attribute for dbh (after error was generated)');
## ----------------------------------------------------------------------------
# Test the driver handle attributes.
my $drh = $dbh->{Driver};
isa_ok( $drh, 'DBI::dr' );
ok($dbh->err, '... checking $dbh->err');
cmp_ok($drh->{ErrCount}, '==', 0, '... checking ErrCount attribute for drh');
ok( $drh->{Warn}, '... checking Warn attribute for drh');
ok( $drh->{Active}, '... checking Active attribute for drh');
ok( $drh->{AutoCommit}, '... checking AutoCommit attribute for drh');
ok(!$drh->{CompatMode}, '... checking CompatMode attribute for drh');
ok(!$drh->{InactiveDestroy}, '... checking InactiveDestory attribute for drh');
ok(!$drh->{AutoInactiveDestroy}, '... checking AutoInactiveDestory attribute for drh');
ok(!$drh->{PrintError}, '... checking PrintError attribute for drh');
ok( $drh->{PrintWarn}, '... checking PrintWarn attribute for drh'); # true because of perl -w above
ok(!$drh->{RaiseError}, '... checking RaiseError attribute for drh');
ok(!$drh->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for drh');
ok(!$drh->{ChopBlanks}, '... checking ChopBlanks attribute for drh');
ok(!$drh->{LongTruncOk}, '... checking LongTrunkOk attribute for drh');
ok(!$drh->{TaintIn}, '... checking TaintIn attribute for drh');
ok(!$drh->{TaintOut}, '... checking TaintOut attribute for drh');
ok(!$drh->{Taint}, '... checking Taint attribute for drh');
SKIP: {
skip "Executed attribute not supported under DBI::PurePerl", 1 if $DBI::PurePerl;
ok($drh->{Executed}, '... checking Executed attribute for drh') # due to the do() above
}
SKIP: {
skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if ($DBI::PurePerl or $dbh->{mx_handle_list});
cmp_ok($drh->{Kids}, '==', 1, '... checking Kids attribute for drh');
cmp_ok($drh->{ActiveKids}, '==', 1, '... checking ActiveKids attribute for drh');
}
is($drh->{CachedKids}, undef, '... checking CachedKids attribute for drh');
ok(!defined $drh->{HandleError}, '... checking HandleError attribute for drh');
ok(!defined $drh->{Profile}, '... checking Profile attribute for drh');
ok(!defined $drh->{ReadOnly}, '... checking ReadOnly attribute for drh');
cmp_ok($drh->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for drh');
cmp_ok($drh->{LongReadLen}, '==', 80, '... checking LongReadLen attribute for drh');
is($drh->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute for drh');
is($drh->{Name}, 'ExampleP', '... checking Name attribute for drh')
unless $using_autoproxy && ok(1);
## ----------------------------------------------------------------------------
# Test the statement handle attributes.
# Create a statement handle.
my $sth = $dbh->prepare("select ctime, name from ?");
isa_ok($sth, "DBI::st");
ok(!$sth->{Executed}, '... checking Executed attribute for sth');
ok(!$dbh->{Executed}, '... checking Executed attribute for dbh');
cmp_ok($sth->{ErrCount}, '==', 0, '... checking ErrCount attribute for sth');
# Trigger an exception.
eval {
$sth->execute("foo")
};
# we don't check actual opendir error msg because of locale differences
like($@, qr/^DBD::\w+::st execute failed: .*opendir\(foo\): /msi, '... checking exception');
# Test all of the statement handle attributes.
like($sth->errstr, qr/opendir\(foo\): /, '... checking $sth->errstr');
is($sth->state, 'S1000', '... checking $sth->state');
ok($sth->{Executed}, '... checking Executed attribute for sth'); # even though it failed
ok($dbh->{Executed}, '... checking Exceuted attribute for dbh'); # due to $sth->prepare, even though it failed
cmp_ok($sth->{ErrCount}, '==', 1, '... checking ErrCount attribute for sth');
eval {
$sth->{ErrCount} = 42
};
like($@, qr/STORE failed:/, '... checking exception');
cmp_ok($sth->{ErrCount}, '==', 42 , '... checking ErrCount attribute for sth (after assignment)');
$sth->{ErrCount} = 0;
cmp_ok($sth->{ErrCount}, '==', 0, '... checking ErrCount attribute for sth (after reset)');
# booleans
ok( $sth->{Warn}, '... checking Warn attribute for sth');
ok(!$sth->{Active}, '... checking Active attribute for sth');
ok(!$sth->{CompatMode}, '... checking CompatMode attribute for sth');
ok(!$sth->{InactiveDestroy}, '... checking InactiveDestroy attribute for sth');
ok(!$sth->{AutoInactiveDestroy}, '... checking AutoInactiveDestroy attribute for sth');
ok(!$sth->{PrintError}, '... checking PrintError attribute for sth');
ok( $sth->{PrintWarn}, '... checking PrintWarn attribute for sth');
ok( $sth->{RaiseError}, '... checking RaiseError attribute for sth');
ok(!$sth->{ShowErrorStatement}, '... checking ShowErrorStatement attribute for sth');
ok(!$sth->{ChopBlanks}, '... checking ChopBlanks attribute for sth');
ok(!$sth->{LongTruncOk}, '... checking LongTrunkOk attribute for sth');
ok(!$sth->{TaintIn}, '... checking TaintIn attribute for sth');
ok(!$sth->{TaintOut}, '... checking TaintOut attribute for sth');
ok(!$sth->{Taint}, '... checking Taint attribute for sth');
# common attr
SKIP: {
skip "Kids and ActiveKids attribute not supported under DBI::PurePerl", 2 if $DBI::PurePerl;
cmp_ok($sth->{Kids}, '==', 0, '... checking Kids attribute for sth');
cmp_ok($sth->{ActiveKids}, '==', 0, '... checking ActiveKids attribute for sth');
}
ok(!defined $sth->{CachedKids}, '... checking CachedKids attribute for sth');
ok(!defined $sth->{HandleError}, '... checking HandleError attribute for sth');
ok(!defined $sth->{Profile}, '... checking Profile attribute for sth');
ok(!defined $sth->{ReadOnly}, '... checking ReadOnly attribute for sth');
cmp_ok($sth->{TraceLevel}, '==', $DBI::dbi_debug & 0xF, '... checking TraceLevel attribute for sth');
cmp_ok($sth->{LongReadLen}, '==', 80, '... checking LongReadLen attribute for sth');
is($sth->{FetchHashKeyName}, 'NAME', '... checking FetchHashKeyName attribute for sth');
# sth specific attr
ok(!defined $sth->{CursorName}, '... checking CursorName attribute for sth');
cmp_ok($sth->{NUM_OF_FIELDS}, '==', 2, '... checking NUM_OF_FIELDS attribute for sth');
cmp_ok($sth->{NUM_OF_PARAMS}, '==', 1, '... checking NUM_OF_PARAMS attribute for sth');
my $name = $sth->{NAME};
is(ref($name), 'ARRAY', '... checking type of NAME attribute for sth');
cmp_ok(scalar(@{$name}), '==', 2, '... checking number of elements returned');
is_deeply($name, ['ctime', 'name' ], '... checking values returned');
my $name_lc = $sth->{NAME_lc};
is(ref($name_lc), 'ARRAY', '... checking type of NAME_lc attribute for sth');
cmp_ok(scalar(@{$name_lc}), '==', 2, '... checking number of elements returned');
is_deeply($name_lc, ['ctime', 'name' ], '... checking values returned');
my $name_uc = $sth->{NAME_uc};
is(ref($name_uc), 'ARRAY', '... checking type of NAME_uc attribute for sth');
cmp_ok(scalar(@{$name_uc}), '==', 2, '... checking number of elements returned');
is_deeply($name_uc, ['CTIME', 'NAME' ], '... checking values returned');
my $nhash = $sth->{NAME_hash};
is(ref($nhash), 'HASH', '... checking type of NAME_hash attribute for sth');
cmp_ok(scalar(keys(%{$nhash})), '==', 2, '... checking number of keys returned');
cmp_ok($nhash->{ctime}, '==', 0, '... checking values returned');
cmp_ok($nhash->{name}, '==', 1, '... checking values returned');
my $nhash_lc = $sth->{NAME_lc_hash};
is(ref($nhash_lc), 'HASH', '... checking type of NAME_lc_hash attribute for sth');
cmp_ok(scalar(keys(%{$nhash_lc})), '==', 2, '... checking number of keys returned');
cmp_ok($nhash_lc->{ctime}, '==', 0, '... checking values returned');
cmp_ok($nhash_lc->{name}, '==', 1, '... checking values returned');
my $nhash_uc = $sth->{NAME_uc_hash};
is(ref($nhash_uc), 'HASH', '... checking type of NAME_uc_hash attribute for sth');
cmp_ok(scalar(keys(%{$nhash_uc})), '==', 2, '... checking number of keys returned');
cmp_ok($nhash_uc->{CTIME}, '==', 0, '... checking values returned');
cmp_ok($nhash_uc->{NAME}, '==', 1, '... checking values returned');
my $type = $sth->{TYPE};
is(ref($type), 'ARRAY', '... checking type of TYPE attribute for sth');
cmp_ok(scalar(@{$type}), '==', 2, '... checking number of elements returned');
is_deeply($type, [ 4, 12 ], '... checking values returned');
my $null = $sth->{NULLABLE};
is(ref($null), 'ARRAY', '... checking type of NULLABLE attribute for sth');
cmp_ok(scalar(@{$null}), '==', 2, '... checking number of elements returned');
is_deeply($null, [ 0, 0 ], '... checking values returned');
# Should these work? They don't.
my $prec = $sth->{PRECISION};
is(ref($prec), 'ARRAY', '... checking type of PRECISION attribute for sth');
cmp_ok(scalar(@{$prec}), '==', 2, '... checking number of elements returned');
is_deeply($prec, [ 10, 1024 ], '... checking values returned');
my $scale = $sth->{SCALE};
is(ref($scale), 'ARRAY', '... checking type of SCALE attribute for sth');
cmp_ok(scalar(@{$scale}), '==', 2, '... checking number of elements returned');
is_deeply($scale, [ 0, 0 ], '... checking values returned');
my $params = $sth->{ParamValues};
is(ref($params), 'HASH', '... checking type of ParamValues attribute for sth');
is($params->{1}, 'foo', '... checking values returned');
is($sth->{Statement}, "select ctime, name from ?", '... checking Statement attribute for sth');
ok(!defined $sth->{RowsInCache}, '... checking type of RowsInCache attribute for sth');
is $sth->{examplep_private_sth_attrib}, 24, 'should see driver-private sth attribute value';
# $h->{TraceLevel} tests are in t/09trace.t
note "Checking inheritance\n";
SKIP: {
skip "drh->dbh->sth inheritance test skipped with DBI_AUTOPROXY", 2 if $ENV{DBI_AUTOPROXY};
sub check_inherited {
my ($drh, $attr, $value, $skip_sth) = @_;
local $drh->{$attr} = $value;
local $drh->{PrintError} = 1;
my $dbh = $drh->connect("dummy");
is $dbh->{$attr}, $drh->{$attr}, "dbh $attr value should be inherited from drh";
unless ($skip_sth) {
my $sth = $dbh->prepare("select name from .");
is $sth->{$attr}, $dbh->{$attr}, "sth $attr value should be inherited from dbh";
}
}
check_inherited($drh, "ReadOnly", 1, 0);
}
1;
# end
|
