1use strict; 2use warnings; 3 4use Test::More; 5use Scalar::Util 'refaddr'; 6use namespace::clean; 7$| = 1; 8 9INIT { 10 use lib 't/cdbi/testlib'; 11 use Film; 12} 13 14ok(Film->can('db_Main'), 'set_db()'); 15is(Film->__driver, "SQLite", "Driver set correctly"); 16 17{ 18 my $nul = eval { Film->retrieve() }; 19 is $nul, undef, "Can't retrieve nothing"; 20 like $@, qr/./, "retrieve needs parameters"; # TODO fix this... 21} 22 23{ 24 eval { my $id = Film->id }; 25 like $@, qr/class method/, "Can't get id with no object"; 26} 27 28{ 29 eval { my $id = Film->title }; 30 #like $@, qr/class method/, "Can't get title with no object"; 31 ok $@, "Can't get title with no object"; 32} 33 34eval { my $duh = Film->insert; }; 35like $@, qr/Result object instantiation requires a hashref as argument/, "needs a hashref"; 36 37ok +Film->create_test_film; 38 39my $btaste = Film->retrieve('Bad Taste'); 40isa_ok $btaste, 'Film'; 41is($btaste->Title, 'Bad Taste', 'Title() get'); 42is($btaste->Director, 'Peter Jackson', 'Director() get'); 43is($btaste->Rating, 'R', 'Rating() get'); 44is($btaste->NumExplodingSheep, 1, 'NumExplodingSheep() get'); 45 46{ 47 my $bt2 = Film->find_or_create(Title => 'Bad Taste'); 48 is $bt2->Director, $btaste->Director, "find_or_create"; 49 my @bt = Film->search(Title => 'Bad Taste'); 50 is @bt, 1, " doesn't create a new one"; 51} 52 53ok my $gone = Film->find_or_create( 54 { 55 Title => 'Gone With The Wind', 56 Director => 'Bob Baggadonuts', 57 Rating => 'PG', 58 NumExplodingSheep => 0 59 } 60 ), 61 "Add Gone With The Wind"; 62isa_ok $gone, 'Film'; 63ok $gone = Film->retrieve(Title => 'Gone With The Wind'), 64 "Fetch it back again"; 65isa_ok $gone, 'Film'; 66 67# Shocking new footage found reveals bizarre Scarlet/sheep scene! 68is($gone->NumExplodingSheep, 0, 'NumExplodingSheep() get again'); 69$gone->NumExplodingSheep(5); 70is($gone->NumExplodingSheep, 5, 'NumExplodingSheep() set'); 71is($gone->numexplodingsheep, 5, 'numexplodingsheep() set'); 72 73is($gone->Rating, 'PG', 'Rating() get again'); 74$gone->Rating('NC-17'); 75is($gone->Rating, 'NC-17', 'Rating() set'); 76$gone->update; 77 78{ 79 my @films = eval { Film->retrieve_all }; 80 cmp_ok(@films, '==', 2, "We have 2 films in total"); 81} 82 83# EXTRA TEST: added by mst to check a bug found by Numa 84cmp_ok(Film->count_all, '==', 2, "count_all confirms 2 films"); 85 86my $gone_copy = Film->retrieve('Gone With The Wind'); 87ok($gone->NumExplodingSheep == 5, 'update()'); 88ok($gone->Rating eq 'NC-17', 'update() again'); 89 90# Grab the 'Bladerunner' entry. 91Film->create( 92 { 93 Title => 'Bladerunner', 94 Director => 'Bob Ridley Scott', 95 Rating => 'R' 96 } 97); 98 99my $blrunner = Film->retrieve('Bladerunner'); 100is(ref $blrunner, 'Film', 'retrieve() again'); 101is $blrunner->Title, 'Bladerunner', "Correct title"; 102is $blrunner->Director, 'Bob Ridley Scott', " and Director"; 103is $blrunner->Rating, 'R', " and Rating"; 104is $blrunner->NumExplodingSheep, undef, " and sheep"; 105 106# Make a copy of 'Bladerunner' and create an entry of the directors cut 107my $blrunner_dc = $blrunner->copy( 108 { 109 title => "Bladerunner: Director's Cut", 110 rating => "15", 111 } 112); 113is(ref $blrunner_dc, 'Film', "copy() produces a film"); 114is($blrunner_dc->Title, "Bladerunner: Director's Cut", 'Title correct'); 115is($blrunner_dc->Director, 'Bob Ridley Scott', 'Director correct'); 116is($blrunner_dc->Rating, '15', 'Rating correct'); 117is($blrunner_dc->NumExplodingSheep, undef, 'Sheep correct'); 118 119# Set up own SQL: 120{ 121 Film->add_constructor(title_asc => "title LIKE ? ORDER BY title"); 122 Film->add_constructor(title_desc => "title LIKE ? ORDER BY title DESC"); 123 Film->add_constructor(title_asc_nl => q{ 124 title LIKE ? 125 ORDER BY title 126 LIMIT 1 127 }); 128 129 { 130 my @films = Film->title_asc("Bladerunner%"); 131 is @films, 2, "We have 2 Bladerunners"; 132 is $films[0]->Title, $blrunner->Title, "Ordered correctly"; 133 } 134 { 135 my @films = Film->title_desc("Bladerunner%"); 136 is @films, 2, "We have 2 Bladerunners"; 137 is $films[0]->Title, $blrunner_dc->Title, "Ordered correctly"; 138 } 139 { 140 my @films = Film->title_asc_nl("Bladerunner%"); 141 is @films, 1, "We have 2 Bladerunners"; 142 is $films[0]->Title, $blrunner->Title, "Ordered correctly"; 143 } 144} 145 146# Multi-column search 147{ 148 my @films = $blrunner->search (title => { -like => "Bladerunner%"}, rating => '15'); 149 is @films, 1, "Only one Bladerunner is a 15"; 150} 151 152# Inline SQL 153{ 154 my @films = Film->retrieve_from_sql("numexplodingsheep > 0 ORDER BY title"); 155 is @films, 2, "Inline SQL"; 156 is $films[0]->id, $btaste->id, "Correct film"; 157 is $films[1]->id, $gone->id, "Correct film"; 158} 159 160# Inline SQL removes WHERE 161{ 162 my @films = 163 Film->retrieve_from_sql(" WHErE numexplodingsheep > 0 ORDER BY title"); 164 is @films, 2, "Inline SQL"; 165 is $films[0]->id, $btaste->id, "Correct film"; 166 is $films[1]->id, $gone->id, "Correct film"; 167} 168 169eval { 170 my $ishtar = Film->insert({ Title => 'Ishtar', Director => 'Elaine May' }); 171 my $mandn = 172 Film->insert({ Title => 'Mikey and Nicky', Director => 'Elaine May' }); 173 my $new_leaf = 174 Film->insert({ Title => 'A New Leaf', Director => 'Elaine May' }); 175 176#use Data::Dumper; die Dumper(Film->search( Director => 'Elaine May' )); 177 cmp_ok(Film->search(Director => 'Elaine May'), '==', 3, 178 "3 Films by Elaine May"); 179 ok(Film->retrieve('Ishtar')->delete, 180 "Ishtar doesn't deserve an entry any more"); 181 ok(!Film->retrieve('Ishtar'), 'Ishtar no longer there'); 182 { 183 my $deprecated = 0; 184 local $SIG{__WARN__} = sub { $deprecated++ if $_[0] =~ /deprecated/ }; 185 ok( 186 Film->delete(Director => 'Elaine May'), 187 "In fact, delete all films by Elaine May" 188 ); 189 cmp_ok(Film->search(Director => 'Elaine May'), '==', 190 0, "0 Films by Elaine May"); 191 is $deprecated, 0, "No deprecated warnings from compat layer"; 192 } 193}; 194is $@, '', "No problems with deletes"; 195 196# Find all films which have a rating of NC-17. 197my @films = Film->search('Rating', 'NC-17'); 198is(scalar @films, 1, ' search returns one film'); 199is($films[0]->id, $gone->id, ' ... the correct one'); 200 201# Find all films which were directed by Bob 202@films = Film->search ( { 'Director' => { -like => 'Bob %' } }); 203is(scalar @films, 3, ' search_like returns 3 films'); 204ok( 205 eq_array( 206 [ sort map { $_->id } @films ], 207 [ sort map { $_->id } $blrunner_dc, $gone, $blrunner ] 208 ), 209 'the correct ones' 210); 211 212# Find Ridley Scott films which don't have vomit 213@films = 214 Film->search(numExplodingSheep => undef, Director => 'Bob Ridley Scott'); 215is(scalar @films, 2, ' search where attribute is null returns 2 films'); 216ok( 217 eq_array( 218 [ sort map { $_->id } @films ], 219 [ sort map { $_->id } $blrunner_dc, $blrunner ] 220 ), 221 'the correct ones' 222); 223 224# Test that a disconnect doesnt harm anything. 225{ 226 # SQLite is loud on disconnect/reconnect. 227 # This is solved in DBIC but not in ContextualFetch 228 local $SIG{__WARN__} = sub { 229 warn @_ unless $_[0] =~ 230 /active statement handles|inactive database handle/; 231 }; 232 233 Film->db_Main->disconnect; 234 @films = Film->search({ Rating => 'NC-17' }); 235 ok(@films == 1 && $films[0]->id eq $gone->id, 'auto reconnection'); 236 237 # Test discard_changes(). 238 my $orig_director = $btaste->Director; 239 $btaste->Director('Lenny Bruce'); 240 is($btaste->Director, 'Lenny Bruce', 'set new Director'); 241 $btaste->discard_changes; 242 is($btaste->Director, $orig_director, 'discard_changes()'); 243} 244 245SKIP: { 246 skip "ActiveState perl produces additional warnings", 3 247 if ($^O eq 'MSWin32'); 248 249 Film->autoupdate(1); 250 my $btaste2 = Film->retrieve($btaste->id); 251 $btaste->NumExplodingSheep(18); 252 my @warnings; 253 local $SIG{__WARN__} = sub { push(@warnings, @_); }; 254 { 255 256 # unhook from live object cache, so next one is not from cache 257 $btaste2->remove_from_object_index; 258 my $btaste3 = Film->retrieve($btaste->id); 259 is $btaste3->NumExplodingSheep, 18, "Class based AutoCommit"; 260 $btaste3->autoupdate(0); # obj a/c should override class a/c 261 is @warnings, 0, "No warnings so far"; 262 $btaste3->NumExplodingSheep(13); 263 } 264 is @warnings, 1, "DESTROY without update warns"; 265 Film->autoupdate(0); 266} 267 268{ # update unchanged object 269 my $film = Film->retrieve($btaste->id); 270 my $retval = $film->update; 271 is $retval, -1, "Unchanged object"; 272} 273 274{ # update deleted object 275 my $rt = "Royal Tenenbaums"; 276 my $ten = Film->insert({ title => $rt, Rating => "R" }); 277 $ten->rating(18); 278 Film->set_sql(drt => "DELETE FROM __TABLE__ WHERE title = ?"); 279 Film->sql_drt->execute($rt); 280 my @films = Film->search({ title => $rt }); 281 is @films, 0, "RT gone"; 282 my $retval = eval { $ten->update }; 283 like $@, qr/row not found/, "Update deleted object throws error"; 284 $ten->discard_changes; 285} 286 287{ 288 $btaste->autoupdate(1); 289 $btaste->NumExplodingSheep(32); 290 my $btaste2 = Film->retrieve($btaste->id); 291 is $btaste2->NumExplodingSheep, 32, "Object based AutoCommit"; 292 $btaste->autoupdate(0); 293} 294 295# Primary key of 0 296{ 297 my $zero = Film->insert({ Title => 0, Rating => "U" }); 298 ok defined $zero, "Create 0"; 299 ok my $ret = Film->retrieve(0), "Retrieve 0"; 300 is $ret->Title, 0, "Title OK"; 301 is $ret->Rating, "U", "Rating OK"; 302} 303 304# Change after_update policy 305SKIP: { 306 skip "DBIx::Class compat doesn't handle the exists stuff quite right yet", 4; 307 my $bt = Film->retrieve($btaste->id); 308 $bt->autoupdate(1); 309 310 $bt->rating("17"); 311 ok !$bt->_attribute_exists('rating'), "changed column needs reloaded"; 312 ok $bt->_attribute_exists('title'), "but we still have the title"; 313 314 # Don't re-load 315 $bt->add_trigger( 316 after_update => sub { 317 my ($self, %args) = @_; 318 my $discard_columns = $args{discard_columns}; 319 @$discard_columns = qw/title/; 320 } 321 ); 322 $bt->rating("19"); 323 ok $bt->_attribute_exists('rating'), "changed column needs reloaded"; 324 ok !$bt->_attribute_exists('title'), "but no longer have the title"; 325} 326 327# Make sure that we can have other accessors. (Bugfix in 0.28) 328if (0) { 329 Film->mk_accessors(qw/temp1 temp2/); 330 my $blrunner = Film->retrieve('Bladerunner'); 331 $blrunner->temp1("Foo"); 332 $blrunner->NumExplodingSheep(2); 333 eval { $blrunner->update }; 334 ok(!$@, "Other accessors"); 335} 336 337# overloading 338{ 339 is "$blrunner", "Bladerunner", "stringify"; 340 341 ok(Film->columns(Stringify => 'rating'), "Can change stringify column"); 342 is "$blrunner", "R", "And still stringifies correctly"; 343 344 ok( 345 Film->columns(Stringify => qw/title rating/), 346 "Can have multiple stringify columns" 347 ); 348 is "$blrunner", "Bladerunner/R", "And still stringifies correctly"; 349 350 no warnings 'once'; 351 local *Film::stringify_self = sub { join ":", $_[0]->title, $_[0]->rating }; 352 is "$blrunner", "Bladerunner:R", "Provide stringify_self()"; 353} 354 355{ 356 { 357 ok my $byebye = DeletingFilm->insert( 358 { 359 Title => 'Goodbye Norma Jean', 360 Rating => 'PG', 361 } 362 ), 363 "Add a deleting Film"; 364 365 isa_ok $byebye, 'DeletingFilm'; 366 isa_ok $byebye, 'Film'; 367 ok(Film->retrieve('Goodbye Norma Jean'), "Fetch it back again"); 368 } 369 my $film; 370 eval { $film = Film->retrieve('Goodbye Norma Jean') }; 371 ok !$film, "It destroys itself"; 372} 373 374SKIP: { 375 skip "Caching has been removed", 5 376 if Film->isa("DBIx::Class::CDBICompat::NoObjectIndex"); 377 378 # my bad taste is your bad taste 379 my $btaste = Film->retrieve('Bad Taste'); 380 my $btaste2 = Film->retrieve('Bad Taste'); 381 is refaddr $btaste, refaddr $btaste2, 382 "Retrieving twice gives ref to same object"; 383 384 my ($btaste5) = Film->search(title=>'Bad Taste'); 385 is refaddr $btaste, refaddr $btaste5, 386 "Searching also gives ref to same object"; 387 388 $btaste2->remove_from_object_index; 389 my $btaste3 = Film->retrieve('Bad Taste'); 390 isnt refaddr $btaste2, refaddr $btaste3, 391 "Removing from object_index and retrieving again gives new object"; 392 393 $btaste3->clear_object_index; 394 my $btaste4 = Film->retrieve('Bad Taste'); 395 isnt refaddr $btaste2, refaddr $btaste4, 396 "Clearing cache and retrieving again gives new object"; 397 398 $btaste=Film->insert({ 399 Title => 'Bad Taste 2', 400 Director => 'Peter Jackson', 401 Rating => 'R', 402 NumExplodingSheep => 2, 403 }); 404 $btaste2 = Film->retrieve('Bad Taste 2'); 405 is refaddr $btaste, refaddr $btaste2, 406 "Creating and retrieving gives ref to same object"; 407 408} 409 410done_testing; 411