File Coverage

blib/lib/DBD/Mock/dr.pm
Criterion Covered Total %
statement 63 67 94.0
branch 31 36 86.1
condition 6 7 85.7
subroutine 11 12 91.6
pod 0 5 0.0
total 111 127 87.4


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;