← Back to branch summary

~ubuntu-branches/ubuntu/edgy/libdbi-perl/edgy

« back to all changes in this revision

Viewing changes to t/03handle.t

  • Committer: Bazaar Package Importer
  • Author(s): Christian Hammers
  • Date: 2004-06-10 19:18:10 UTC
  • Revision ID: james.westby@ubuntu.com-20040610191810-me1zbh33ym9ltdi8
Tags: upstream-1.42
Import upstream version 1.42

Show diffs side-by-side

added added

removed removed

Lines of Context:
t/03handle.t
 
1
#!perl -w
 
2
 
 
3
use strict;
 
4
use Test::More;
 
5
use Data::Dumper;
 
6
 
 
7
# handle tests
 
8
 
 
9
BEGIN { plan tests => 52 }
 
10
 
 
11
use DBI;
 
12
 
 
13
my $driver = "ExampleP";
 
14
 
 
15
do {
 
16
    my $dbh = DBI->connect("dbi:$driver:", '', '');
 
17
 
 
18
    my $sql = "select name from ?";
 
19
    my $sth1 = $dbh->prepare_cached($sql);
 
20
    ok($sth1->execute("."));
 
21
    my $ck = $dbh->{CachedKids};
 
22
    ok(keys %$ck == 1);
 
23
 
 
24
    my $warn = 0;
 
25
    local $SIG{__WARN__} = sub { ++$warn if $_[0] =~ /still active/ };
 
26
    my $sth2 = $dbh->prepare_cached($sql);
 
27
    ok($sth1 == $sth2);
 
28
    ok($warn == 1);
 
29
    ok(!$sth1->{Active});
 
30
 
 
31
       $sth2 = $dbh->prepare_cached($sql, { foo => 1 });
 
32
    ok($sth1 != $sth2);
 
33
    ok(keys %$ck == 2);
 
34
 
 
35
    ok($sth1->execute("."));
 
36
    ok($sth1->{Active});
 
37
       $sth2 = $dbh->prepare_cached($sql, undef, 3);
 
38
    ok($sth1 != $sth2);
 
39
    ok($sth1->{Active}); # active but no longer cached
 
40
    $sth1->finish;
 
41
 
 
42
    ok($sth2->execute("."));
 
43
    ok($sth2->{Active});
 
44
       $sth1 = $dbh->prepare_cached($sql, undef, 1);
 
45
    ok($sth1 == $sth2);
 
46
    ok(!$sth2->{Active});
 
47
 
 
48
    ok($warn == 1);
 
49
    $dbh->disconnect;
 
50
};
 
51
 
 
52
my $drh = DBI->install_driver($driver);
 
53
ok($drh);
 
54
is($drh->{Kids}, 0);
 
55
 
 
56
 
 
57
# --- handle reference leak tests
 
58
 
 
59
sub work {
 
60
    my (%args) = @_;
 
61
    my $dbh = DBI->connect("dbi:$driver:", '', '');
 
62
    ok(ref $dbh->{Driver}) if $args{Driver};
 
63
    my $sth = $dbh->prepare_cached("select name from ?");
 
64
    ok(ref $sth->{Database}) if $args{Database};
 
65
    $dbh->disconnect;
 
66
    # both handles should be freed here
 
67
}
 
68
 
 
69
foreach my $args (
 
70
        {},
 
71
        { Driver   => 1 },
 
72
        { Database => 1 },
 
73
        { Driver   => 1, Database => 1 },
 
74
) {
 
75
    print "ref leak using @{[ %$args ]}\n";
 
76
    work( %$args );
 
77
    is($drh->{Kids}, 0);
 
78
}
 
79
 
 
80
# --- handle take_imp_data test
 
81
 
 
82
print "take_imp_data\n";
 
83
unless ($DBI::PurePerl) {
 
84
 
 
85
my $dbh = DBI->connect("dbi:$driver:", '', '');
 
86
 
 
87
#DBI->trace(9);
 
88
my $imp_data = $dbh->take_imp_data;
 
89
ok($imp_data);
 
90
# generally length($imp_data) = 112 for 32bit, 116 for 64 bit
 
91
# (as of DBI 1.37) but it can differ on some platforms
 
92
# depending on structure packing by the compiler
 
93
# so we just test that it's something reasonable:
 
94
ok(length($imp_data) >= 80);
 
95
#print Dumper($imp_data);
 
96
 
 
97
{
 
98
my ($tmp, $warn);
 
99
local $SIG{__WARN__} = sub { ++$warn if $_[0] =~ /after take_imp_data/ };
 
100
is($tmp=$dbh->{Driver}, undef);
 
101
is($tmp=$dbh->{TraceLevel}, undef);
 
102
is($dbh->disconnect, undef);
 
103
is($dbh->quote(42), undef);
 
104
is($warn, 4);
 
105
}
 
106
 
 
107
print "use dbi_imp_data\n";
 
108
my $dbh2 = DBI->connect("dbi:$driver:", '', '', { dbi_imp_data => $imp_data });
 
109
ok($dbh2);
 
110
# need a way to test dbi_imp_data has been used
 
111
 
 
112
}
 
113
else {
 
114
    ok(1) for (1..8);
 
115
}
 
116
 
 
117
print "NullP statement handle attributes without execute\n";
 
118
my $dbh = DBI->connect("dbi:NullP:", '', '');
 
119
my $sth = $dbh->prepare("foo bar");
 
120
is $sth->{NUM_OF_PARAMS}, 0;
 
121
is $sth->{NUM_OF_FIELDS}, undef;
 
122
is $sth->{Statement}, "foo bar";
 
123
is $sth->{NAME}, undef;
 
124
is $sth->{TYPE}, undef;
 
125
is $sth->{SCALE}, undef;
 
126
is $sth->{PRECISION}, undef;
 
127
is $sth->{NULLABLE}, undef;
 
128
is $sth->{RowsInCache}, undef;
 
129
is $sth->{ParamValues}, undef;
 
130
# derived NAME attributes
 
131
is $sth->{NAME_uc}, undef;
 
132
is $sth->{NAME_lc}, undef;
 
133
is $sth->{NAME_hash}, undef;
 
134
is $sth->{NAME_uc_hash}, undef;
 
135
is $sth->{NAME_lc_hash}, undef;
 
136
 
 
137
ok  ref($dbh)->can("prepare");
 
138
ok !ref($dbh)->can("nonesuch");
 
139
ok  ref($sth)->can("execute");
 
140
 
 
141
# I don't know why this warning has the "(perhaps ...)" suffix, it shouldn't:
 
142
# Can't locate object method "nonesuch" via package "DBI::db" (perhaps you forgot to load "DBI::db"?)
 
143
eval { ref($dbh)->nonesuch; };
 
144
 
 
145
exit 0;