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