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