line |
stmt |
bran |
cond |
sub |
pod |
time |
code |
1
|
|
|
|
|
|
|
package DBD::Mock::dr; |
2
|
|
|
|
|
|
|
|
3
|
40
|
|
|
40
|
|
272
|
use strict; |
|
40
|
|
|
|
|
82
|
|
|
40
|
|
|
|
|
1265
|
|
4
|
40
|
|
|
40
|
|
202
|
use warnings; |
|
40
|
|
|
|
|
74
|
|
|
40
|
|
|
|
|
1481
|
|
5
|
|
|
|
|
|
|
|
6
|
40
|
|
|
40
|
|
241
|
use List::Util qw(reduce); |
|
40
|
|
|
|
|
84
|
|
|
40
|
|
|
|
|
37107
|
|
7
|
|
|
|
|
|
|
|
8
|
|
|
|
|
|
|
our $imp_data_size = 0; |
9
|
|
|
|
|
|
|
|
10
|
|
|
|
|
|
|
my @connect_callbacks; |
11
|
|
|
|
|
|
|
|
12
|
|
|
|
|
|
|
|
13
|
|
|
|
|
|
|
sub connect { |
14
|
83
|
|
|
83
|
0
|
9871
|
my ( $drh, $dbname, $user, $auth, $attributes ) = @_; |
15
|
83
|
100
|
|
|
|
308
|
if ( $drh->{'mock_connect_fail'} == 1 ) { |
16
|
1
|
|
|
|
|
15
|
$drh->set_err( 1, "Could not connect to mock database" ); |
17
|
1
|
|
|
|
|
14
|
return; |
18
|
|
|
|
|
|
|
} |
19
|
82
|
|
100
|
|
|
275
|
$attributes ||= {}; |
20
|
|
|
|
|
|
|
|
21
|
82
|
|
|
|
|
254
|
my %driverParameters = _parse_driver_dsn( $dbname ); |
22
|
|
|
|
|
|
|
|
23
|
82
|
100
|
100
|
|
|
362
|
if ( $dbname && $DBD::Mock::AttributeAliasing ) { |
24
|
|
|
|
|
|
|
|
25
|
|
|
|
|
|
|
# this is the DB we are mocking |
26
|
|
|
|
|
|
|
$attributes->{mock_attribute_aliases} = |
27
|
7
|
|
|
|
|
24
|
DBD::Mock::_get_mock_attribute_aliases($driverParameters{database}); |
28
|
6
|
|
|
|
|
15
|
$attributes->{mock_database_name} = $driverParameters{database}; |
29
|
|
|
|
|
|
|
} |
30
|
|
|
|
|
|
|
|
31
|
|
|
|
|
|
|
# holds statement parsing coderefs/objects |
32
|
81
|
|
|
|
|
238
|
$attributes->{mock_parser} = []; |
33
|
|
|
|
|
|
|
|
34
|
|
|
|
|
|
|
# holds all statements applied to handle until manually cleared |
35
|
81
|
|
|
|
|
211
|
$attributes->{mock_statement_history} = []; |
36
|
|
|
|
|
|
|
|
37
|
|
|
|
|
|
|
# ability to fake a failed DB connection |
38
|
81
|
|
|
|
|
198
|
$attributes->{mock_can_connect} = 1; |
39
|
|
|
|
|
|
|
|
40
|
|
|
|
|
|
|
# ability to make other things fail :) |
41
|
81
|
|
|
|
|
187
|
$attributes->{mock_can_prepare} = 1; |
42
|
81
|
|
|
|
|
197
|
$attributes->{mock_can_execute} = 1; |
43
|
81
|
|
|
|
|
157
|
$attributes->{mock_can_fetch} = 1; |
44
|
|
|
|
|
|
|
|
45
|
81
|
|
50
|
|
|
363
|
my $dbh = DBI::_new_dbh( $drh, { Name => $dbname } ) |
46
|
|
|
|
|
|
|
|| return; |
47
|
|
|
|
|
|
|
|
48
|
81
|
|
|
|
|
3561
|
foreach my $callback (@connect_callbacks) { |
49
|
5
|
|
|
|
|
11
|
$callback->( $dbh, $dbname, $user, $auth, $attributes ); |
50
|
|
|
|
|
|
|
} |
51
|
|
|
|
|
|
|
|
52
|
81
|
|
|
|
|
356
|
return $dbh; |
53
|
|
|
|
|
|
|
} |
54
|
|
|
|
|
|
|
|
55
|
|
|
|
|
|
|
sub FETCH { |
56
|
4
|
|
|
4
|
|
22
|
my ( $drh, $attr ) = @_; |
57
|
4
|
100
|
|
|
|
23
|
if ( $attr =~ /^mock_/ ) { |
58
|
3
|
50
|
|
|
|
13
|
if ( $attr eq 'mock_connect_fail' ) { |
|
|
100
|
|
|
|
|
|
59
|
0
|
|
|
|
|
0
|
return $drh->{'mock_connect_fail'}; |
60
|
|
|
|
|
|
|
} |
61
|
|
|
|
|
|
|
elsif ( $attr eq 'mock_data_sources' ) { |
62
|
2
|
50
|
|
|
|
9
|
unless ( defined $drh->{'mock_data_sources'} ) { |
63
|
2
|
|
|
|
|
7
|
$drh->{'mock_data_sources'} = ['DBI:Mock:']; |
64
|
|
|
|
|
|
|
} |
65
|
2
|
|
|
|
|
10
|
return $drh->{'mock_data_sources'}; |
66
|
|
|
|
|
|
|
} |
67
|
|
|
|
|
|
|
else { |
68
|
1
|
|
|
|
|
14
|
return $drh->SUPER::FETCH($attr); |
69
|
|
|
|
|
|
|
} |
70
|
|
|
|
|
|
|
} |
71
|
|
|
|
|
|
|
else { |
72
|
1
|
|
|
|
|
7
|
return $drh->SUPER::FETCH($attr); |
73
|
|
|
|
|
|
|
} |
74
|
|
|
|
|
|
|
} |
75
|
|
|
|
|
|
|
|
76
|
|
|
|
|
|
|
sub STORE { |
77
|
7
|
|
|
7
|
|
417
|
my ( $drh, $attr, $value ) = @_; |
78
|
7
|
100
|
|
|
|
36
|
if ( $attr =~ /^mock_/ ) { |
79
|
6
|
100
|
|
|
|
33
|
if ( $attr eq 'mock_connect_fail' ) { |
|
|
100
|
|
|
|
|
|
|
|
100
|
|
|
|
|
|
80
|
2
|
100
|
|
|
|
10
|
return $drh->{'mock_connect_fail'} = $value ? 1 : 0; |
81
|
|
|
|
|
|
|
} |
82
|
|
|
|
|
|
|
elsif ( $attr eq 'mock_data_sources' ) { |
83
|
1
|
50
|
|
|
|
6
|
if ( ref($value) ne 'ARRAY' ) { |
84
|
0
|
|
|
|
|
0
|
$drh->set_err( 1, |
85
|
|
|
|
|
|
|
"You must pass an array ref of data sources" ); |
86
|
0
|
|
|
|
|
0
|
return; |
87
|
|
|
|
|
|
|
} |
88
|
1
|
|
|
|
|
5
|
return $drh->{'mock_data_sources'} = $value; |
89
|
|
|
|
|
|
|
} |
90
|
|
|
|
|
|
|
elsif ( $attr eq 'mock_add_data_sources' ) { |
91
|
2
|
|
|
|
|
5
|
return push @{ $drh->{'mock_data_sources'} } => $value; |
|
2
|
|
|
|
|
12
|
|
92
|
|
|
|
|
|
|
} |
93
|
|
|
|
|
|
|
} |
94
|
|
|
|
|
|
|
else { |
95
|
1
|
|
|
|
|
11
|
return $drh->SUPER::STORE( $attr, $value ); |
96
|
|
|
|
|
|
|
} |
97
|
|
|
|
|
|
|
} |
98
|
|
|
|
|
|
|
|
99
|
|
|
|
|
|
|
sub data_sources { |
100
|
5
|
|
|
5
|
0
|
3231
|
my $drh = shift; |
101
|
|
|
|
|
|
|
return |
102
|
9
|
100
|
|
|
|
62
|
map { (/^DBI\:Mock\:/i) ? $_ : "DBI:Mock:$_" } |
103
|
5
|
|
|
|
|
7
|
@{ $drh->FETCH('mock_data_sources') }; |
|
5
|
|
|
|
|
29
|
|
104
|
|
|
|
|
|
|
} |
105
|
|
|
|
|
|
|
|
106
|
|
|
|
|
|
|
# Necessary to support DBI < 1.34 |
107
|
|
|
|
|
|
|
# from CPAN RT bug #7057 |
108
|
|
|
|
|
|
|
|
109
|
|
|
|
38
|
0
|
|
sub disconnect_all { |
110
|
|
|
|
|
|
|
|
111
|
|
|
|
|
|
|
# no-op |
112
|
|
|
|
|
|
|
} |
113
|
|
|
|
|
|
|
|
114
|
0
|
|
|
0
|
|
0
|
sub DESTROY { undef } |
115
|
|
|
|
|
|
|
|
116
|
|
|
|
|
|
|
sub set_connect_callbacks { |
117
|
3
|
50
|
|
3
|
0
|
110
|
@connect_callbacks = map { die "connect callbacks needs to be a reference to a function " unless ref $_ eq "CODE"; $_ } @_; |
|
3
|
|
|
|
|
11
|
|
|
3
|
|
|
|
|
19
|
|
118
|
|
|
|
|
|
|
} |
119
|
|
|
|
|
|
|
|
120
|
|
|
|
|
|
|
sub add_connect_callbacks { |
121
|
1
|
50
|
|
1
|
0
|
12
|
push @connect_callbacks, map { die "connect callbacks needs to be a reference to a function " unless ref $_ eq "CODE"; $_ } @_; |
|
1
|
|
|
|
|
6
|
|
|
1
|
|
|
|
|
4
|
|
122
|
|
|
|
|
|
|
} |
123
|
|
|
|
|
|
|
|
124
|
|
|
|
|
|
|
sub _parse_driver_dsn { |
125
|
82
|
|
|
82
|
|
192
|
my ( $driverDsn ) = @_; |
126
|
|
|
|
|
|
|
|
127
|
82
|
100
|
|
|
|
290
|
$driverDsn = $driverDsn ? $driverDsn : ''; |
128
|
|
|
|
|
|
|
|
129
|
82
|
|
|
|
|
147
|
my %driverParameters; |
130
|
|
|
|
|
|
|
|
131
|
82
|
|
|
|
|
299
|
foreach my $parameter ( split /;/, $driverDsn ) { |
132
|
14
|
100
|
|
|
|
69
|
if ( my ( $key, $value ) = $parameter =~ m/^(.*?)=(.*)$/ ) { |
133
|
8
|
|
|
|
|
22
|
$driverParameters{ $key } = $value; |
134
|
|
|
|
|
|
|
} |
135
|
|
|
|
|
|
|
} |
136
|
|
|
|
|
|
|
|
137
|
82
|
100
|
|
|
|
306
|
$driverParameters{database} = $driverDsn unless %driverParameters; |
138
|
|
|
|
|
|
|
|
139
|
82
|
|
|
|
|
362
|
return %driverParameters; |
140
|
|
|
|
|
|
|
} |
141
|
|
|
|
|
|
|
|
142
|
|
|
|
|
|
|
1; |