1use strict; 2use warnings; 3 4use Test::More; 5use Test::Warn; 6use lib qw(t/lib); 7use DBICTest; 8use Data::Dumper; 9 10{ 11 package DBICTest::ExplodingStorage::Sth; 12 use strict; 13 use warnings; 14 15 sub execute { die "Kablammo!" } 16 17 sub bind_param {} 18 19 package DBICTest::ExplodingStorage; 20 use strict; 21 use warnings; 22 use base 'DBIx::Class::Storage::DBI::SQLite'; 23 24 my $count = 0; 25 sub sth { 26 my ($self, $sql) = @_; 27 return bless {}, "DBICTest::ExplodingStorage::Sth" unless $count++; 28 return $self->next::method($sql); 29 } 30 31 sub connected { 32 return 0 if $count == 1; 33 return shift->next::method(@_); 34 } 35} 36 37my $schema = DBICTest->init_schema( sqlite_use_file => 1 ); 38 39is( ref($schema->storage), 'DBIx::Class::Storage::DBI::SQLite', 40 'Storage reblessed correctly into DBIx::Class::Storage::DBI::SQLite' ); 41 42my $storage = $schema->storage; 43$storage->ensure_connected; 44 45eval { 46 $schema->storage->throw_exception('test_exception_42'); 47}; 48like($@, qr/\btest_exception_42\b/, 'basic exception'); 49 50eval { 51 $schema->resultset('CD')->search_literal('broken +%$#$1')->all; 52}; 53like($@, qr/prepare_cached failed/, 'exception via DBI->HandleError, etc'); 54 55bless $storage, "DBICTest::ExplodingStorage"; 56$schema->storage($storage); 57 58eval { 59 $schema->resultset('Artist')->create({ name => "Exploding Sheep" }); 60}; 61 62is($@, "", "Exploding \$sth->execute was caught"); 63 64is(1, $schema->resultset('Artist')->search({name => "Exploding Sheep" })->count, 65 "And the STH was retired"); 66 67 68# testing various invocations of connect_info ([ ... ]) 69 70my $coderef = sub { 42 }; 71my $invocations = { 72 'connect_info ([ $d, $u, $p, \%attr, \%extra_attr])' => { 73 args => [ 74 'foo', 75 'bar', 76 undef, 77 { 78 on_connect_do => [qw/a b c/], 79 PrintError => 0, 80 }, 81 { 82 AutoCommit => 1, 83 on_disconnect_do => [qw/d e f/], 84 }, 85 { 86 unsafe => 1, 87 auto_savepoint => 1, 88 }, 89 ], 90 dbi_connect_info => [ 91 'foo', 92 'bar', 93 undef, 94 { 95 %{$storage->_default_dbi_connect_attributes || {} }, 96 PrintError => 0, 97 AutoCommit => 1, 98 }, 99 ], 100 }, 101 102 'connect_info ([ \%code, \%extra_attr ])' => { 103 args => [ 104 $coderef, 105 { 106 on_connect_do => [qw/a b c/], 107 PrintError => 0, 108 AutoCommit => 1, 109 on_disconnect_do => [qw/d e f/], 110 }, 111 { 112 unsafe => 1, 113 auto_savepoint => 1, 114 }, 115 ], 116 dbi_connect_info => [ 117 $coderef, 118 ], 119 }, 120 121 'connect_info ([ \%attr ])' => { 122 args => [ 123 { 124 on_connect_do => [qw/a b c/], 125 PrintError => 1, 126 AutoCommit => 0, 127 on_disconnect_do => [qw/d e f/], 128 user => 'bar', 129 dsn => 'foo', 130 }, 131 { 132 unsafe => 1, 133 auto_savepoint => 1, 134 }, 135 ], 136 dbi_connect_info => [ 137 'foo', 138 'bar', 139 undef, 140 { 141 %{$storage->_default_dbi_connect_attributes || {} }, 142 PrintError => 1, 143 AutoCommit => 0, 144 }, 145 ], 146 }, 147 'connect_info ([ \%attr_with_coderef ])' => { 148 args => [ { 149 dbh_maker => $coderef, 150 dsn => 'blah', 151 user => 'bleh', 152 on_connect_do => [qw/a b c/], 153 on_disconnect_do => [qw/d e f/], 154 } ], 155 dbi_connect_info => [ 156 $coderef 157 ], 158 warn => qr/Attribute\(s\) 'dsn', 'user' in connect_info were ignored/, 159 }, 160}; 161 162for my $type (keys %$invocations) { 163 164 # we can not use a cloner portably because of the coderef 165 # so compare dumps instead 166 local $Data::Dumper::Sortkeys = 1; 167 my $arg_dump = Dumper ($invocations->{$type}{args}); 168 169 warnings_exist ( 170 sub { $storage->connect_info ($invocations->{$type}{args}) }, 171 $invocations->{$type}{warn} || (), 172 'Warned about ignored attributes', 173 ); 174 175 is ($arg_dump, Dumper ($invocations->{$type}{args}), "$type didn't modify passed arguments"); 176 177 is_deeply ($storage->_dbi_connect_info, $invocations->{$type}{dbi_connect_info}, "$type produced correct _dbi_connect_info"); 178 ok ( (not $storage->auto_savepoint and not $storage->unsafe), "$type correctly ignored extra hashref"); 179 180 is_deeply ( 181 [$storage->on_connect_do, $storage->on_disconnect_do ], 182 [ [qw/a b c/], [qw/d e f/] ], 183 "$type correctly parsed DBIC specific on_[dis]connect_do", 184 ); 185} 186 187done_testing; 188 1891; 190