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