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