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
|
#!perl -w
use strict;
use Test::More tests => 20;
BEGIN{ use_ok( 'DBI' ) }
my $expect_active;
## main Test Driver Package
{
package DBD::Test;
use strict;
use warnings;
my $drh = undef;
sub driver {
return $drh if $drh;
my ($class, $attr) = @_;
$class = "${class}::dr";
($drh) = DBI::_new_drh($class, {
Name => 'Test',
Version => '1.0',
}, 77 );
return $drh;
}
sub CLONE { undef $drh }
}
## Test Driver
{
package DBD::Test::dr;
use warnings;
use Test::More;
sub connect { # normally overridden, but a handy default
my($drh, $dbname, $user, $auth, $attrs)= @_;
my ($outer, $dbh) = DBI::_new_dbh($drh);
$dbh->STORE(Active => 1);
$dbh->STORE(AutoCommit => 1);
$dbh->STORE( $_ => $attrs->{$_}) for keys %$attrs;
return $outer;
}
$DBD::Test::dr::imp_data_size = 0;
cmp_ok($DBD::Test::dr::imp_data_size, '==', 0, '... check DBD::Test::dr::imp_data_size to avoid typo');
}
## Test db package
{
package DBD::Test::db;
use strict;
use warnings;
use Test::More;
$DBD::Test::db::imp_data_size = 0;
cmp_ok($DBD::Test::db::imp_data_size, '==', 0, '... check DBD::Test::db::imp_data_size to avoid typo');
sub STORE {
my ($dbh, $attrib, $value) = @_;
# would normally validate and only store known attributes
# else pass up to DBI to handle
if ($attrib eq 'AutoCommit') {
# convert AutoCommit values to magic ones to let DBI
# know that the driver has 'handled' the AutoCommit attribute
$value = ($value) ? -901 : -900;
}
return $dbh->{$attrib} = $value if $attrib =~ /^examplep_/;
return $dbh->SUPER::STORE($attrib, $value);
}
sub DESTROY {
if ($expect_active < 0) { # inside child
my $self = shift;
exit $self->FETCH('Active') || 0 unless $^O eq 'MSWin32';
# On Win32, the forked child is actually a thread. So don't exit,
# and report failure directly.
fail 'Child should be inactive on DESTROY' if $self->FETCH('Active');
} else {
return $expect_active
? ok( shift->FETCH('Active'), 'Should be active in DESTROY')
: ok( !shift->FETCH('Active'), 'Should not be active in DESTROY');
}
}
}
my $dsn = 'dbi:ExampleP:dummy';
$INC{'DBD/Test.pm'} = 'dummy'; # required to fool DBI->install_driver()
ok my $drh = DBI->install_driver('Test'), 'Install test driver';
NOSETTING: {
# Try defaults.
ok my $dbh = $drh->connect, 'Connect to test driver';
ok $dbh->{Active}, 'Should start active';
$expect_active = 1;
}
IAD: {
# Try InactiveDestroy.
ok my $dbh = $drh->connect($dsn, '', '', { InactiveDestroy => 1 }),
'Create with ActiveDestroy';
ok $dbh->{InactiveDestroy}, 'InactiveDestroy should be set';
ok $dbh->{Active}, 'Should start active';
$expect_active = 0;
}
AIAD: {
# Try AutoInactiveDestroy.
ok my $dbh = $drh->connect($dsn, '', '', { AutoInactiveDestroy => 1 }),
'Create with AutoInactiveDestroy';
ok $dbh->{AutoInactiveDestroy}, 'InactiveDestroy should be set';
ok $dbh->{Active}, 'Should start active';
$expect_active = 1;
}
FORK: {
# Try AutoInactiveDestroy and fork.
ok my $dbh = $drh->connect($dsn, '', '', { AutoInactiveDestroy => 1 }),
'Create with AutoInactiveDestroy again';
ok $dbh->{AutoInactiveDestroy}, 'InactiveDestroy should be set';
ok $dbh->{Active}, 'Should start active';
my $pid = eval { fork() };
if (not defined $pid) {
chomp $@;
my $msg = "AutoInactiveDestroy destroy test skipped";
diag "$msg because $@\n";
pass $msg; # in lieu of the child status test
}
elsif ($pid) {
# parent.
$expect_active = 1;
wait;
ok $? == 0, 'Child should be inactive on DESTROY';
} else {
# child.
$expect_active = -1;
}
}
|
