Reorganize CDBICompat tests - centralize prereq checks in one place
[dbsrgits/DBIx-Class-Historic.git] / t / cdbi / 15-accessor.t
1 use strict;
2 use Test::More;
3
4 INIT {
5     #local $SIG{__WARN__} =
6         #sub { like $_[0], qr/clashes with built-in method/, $_[0] };
7     use lib 't/cdbi/testlib';
8     require Film;
9     require Actor;
10     require Director;
11
12     Actor->has_a(film => 'Film');
13     Film->has_a(director => 'Director');
14
15     sub Class::DBI::sheep { ok 0; }
16 }
17
18 # Install the deprecation warning intercept here for the rest of the 08 dev cycle
19 local $SIG{__WARN__} = sub {
20   warn @_ unless (DBIx::Class->VERSION < 0.09 and $_[0] =~ /Query returned more than one row/);
21 };
22
23 sub Film::mutator_name {
24     my ($class, $col) = @_;
25     return "set_sheep" if lc $col eq "numexplodingsheep";
26     return $col;
27 }
28
29 sub Film::accessor_name {
30     my ($class, $col) = @_;
31     return "sheep" if lc $col eq "numexplodingsheep";
32     return $col;
33 }
34
35 sub Actor::accessor_name_for {
36     my ($class, $col) = @_;
37     return "movie" if lc $col eq "film";
38     return $col;
39 }
40
41 # This is a class with accessor_name_for() but no corresponding mutator_name_for()
42 sub Director::accessor_name_for {
43     my($class, $col) = @_;
44     return "nutty_as_a_fruitcake" if lc $col eq "isinsane";
45     return $col;
46 }
47
48 my $data = {
49     Title    => 'Bad Taste',
50     Director => 'Peter Jackson',
51     Rating   => 'R',
52 };
53
54 eval {
55     my $data = { %$data };
56     $data->{NumExplodingSheep} = 1;
57     ok my $bt = Film->create($data), "Modified accessor - with column name";
58     isa_ok $bt, "Film";
59     is $bt->sheep, 1, 'sheep bursting violently';
60 };
61 is $@, '', "No errors";
62
63 eval {
64     my $data = { %$data };
65     $data->{sheep} = 2;
66     ok my $bt = Film->create($data), "Modified accessor - with accessor";
67     isa_ok $bt, "Film";
68     is $bt->sheep, 2, 'sheep bursting violently';
69 };
70 is $@, '', "No errors";
71
72 eval {
73     my $data = { %$data };
74     $data->{NumExplodingSheep} = 1;
75     ok my $bt = Film->find_or_create($data),
76     "find_or_create Modified accessor - find with column name";
77     isa_ok $bt, "Film";
78     is $bt->sheep, 1, 'sheep bursting violently';
79 };
80 is $@, '', "No errors";
81
82 eval {
83     my $data = { %$data };
84     $data->{sheep} = 1;
85     ok my $bt = Film->find_or_create($data),
86     "find_or_create Modified accessor - find with accessor";
87     isa_ok $bt, "Film";
88     is $bt->sheep, 1, 'sheep bursting violently';
89 };
90 is $@, '', "No errors";
91
92 TODO: { local $TODO = 'TODOifying failing tests, waiting for Schwern'; ok (1, 'remove me');
93 eval {
94     my $data = { %$data };
95     $data->{NumExplodingSheep} = 3;
96     ok my $bt = Film->find_or_create($data),
97     "find_or_create Modified accessor - create with column name";
98     isa_ok $bt, "Film";
99     is $bt->sheep, 3, 'sheep bursting violently';
100 };
101 is $@, '', "No errors";
102
103 eval {
104     my $data = { %$data };
105     $data->{sheep} = 4;
106     ok my $bt = Film->find_or_create($data),
107     "find_or_create Modified accessor - create with accessor";
108     isa_ok $bt, "Film";
109     is $bt->sheep, 4, 'sheep bursting violently';
110 };
111 is $@, '', "No errors";
112
113 eval {
114     my @film = Film->search({ sheep => 1 });
115     is @film, 2, "Can search with modified accessor";
116 };
117 is $@, '', "No errors";
118
119 }
120
121 {
122
123     eval {
124         local $data->{set_sheep} = 1;
125         ok my $bt = Film->create($data), "Modified mutator - with mutator";
126         isa_ok $bt, "Film";
127     };
128     is $@, '', "No errors";
129
130     eval {
131         local $data->{NumExplodingSheep} = 1;
132         ok my $bt = Film->create($data), "Modified mutator - with column name";
133         isa_ok $bt, "Film";
134     };
135     is $@, '', "No errors";
136
137     eval {
138         local $data->{sheep} = 1;
139         ok my $bt = Film->create($data), "Modified mutator - with accessor";
140         isa_ok $bt, "Film";
141     };
142     is $@, '', "No errors";
143
144 }
145
146 {
147     my $p_data = {
148         name => 'Peter Jackson',
149         film => 'Bad Taste',
150     };
151     my $bt = Film->create($data);
152     my $ac = Actor->create($p_data);
153
154     ok !eval { my $f = $ac->film; 1 };
155     like $@, qr/film/, "no hasa film";
156
157     eval {
158         ok my $f = $ac->movie, "hasa movie";
159         isa_ok $f, "Film";
160         is $f->id, $bt->id, " - Bad Taste";
161     };
162     is $@, '', "No errors";
163
164     {
165         local $data->{Title} = "Another film";
166         my $film = Film->create($data);
167
168         eval { $ac->film($film) };
169         ok $@, $@;
170
171         eval { $ac->movie($film) };
172         ok $@, $@;
173
174         eval {
175             ok $ac->set_film($film), "Set movie through hasa";
176             $ac->update;
177             ok my $f = $ac->movie, "hasa movie";
178             isa_ok $f, "Film";
179             is $f->id, $film->id, " - Another Film";
180         };
181         is $@, '', "No problem";
182     }
183
184 }
185
186
187 # Make sure a class with an accessor_name() method has a similar mutator.
188 {
189     my $aki = Director->create({
190         name     => "Aki Kaurismaki",
191     });
192
193     $aki->nutty_as_a_fruitcake(1);
194     is $aki->nutty_as_a_fruitcake, 1,
195         "a custom accessor without a custom mutator is setable";
196     $aki->update;
197 }
198
199 {
200     Film->columns(TEMP => qw/nonpersistent/);
201     ok(Film->find_column('nonpersistent'), "nonpersistent is a column");
202     ok(!Film->has_real_column('nonpersistent'), " - but it's not real");
203
204     {
205         my $film = Film->create({ Title => "Veronique", nonpersistent => 42 });
206         is $film->title,         "Veronique", "Title set OK";
207         is $film->nonpersistent, 42,          "As is non persistent value";
208         $film->remove_from_object_index;
209         ok $film = Film->retrieve('Veronique'), "Re-retrieve film";
210         is $film->title, "Veronique", "Title still OK";
211         is $film->nonpersistent, undef, "Non persistent value gone";
212         ok $film->nonpersistent(40), "Can set it";
213         is $film->nonpersistent, 40, "And it's there again";
214         ok $film->update, "Commit the film";
215         is $film->nonpersistent, 40, "And it's still there";
216     }
217 }
218
219 {
220     is_deeply(
221         [Actor->columns('Essential')],
222         [Actor->columns('Primary')],
223         "Actor has no specific essential columns"
224     );
225     ok(Actor->find_column('nonpersistent'), "nonpersistent is a column");
226     ok(!Actor->has_real_column('nonpersistent'), " - but it's not real");
227     my $pj = eval { Actor->search(name => "Peter Jackson")->first };
228     is $@, '', "no problems retrieving actors";
229     isa_ok $pj => "Actor";
230 }
231
232 {
233     Film->autoupdate(1);
234     my $naked = Film->create({ title => 'Naked' });
235     my $sandl = Film->create({ title => 'Secrets and Lies' });
236
237     my $rating = 1;
238     my $update_failure = sub {
239         my $obj = shift;
240         eval { $obj->rating($rating++) };
241         return $@ =~ /read only/;
242     };
243
244     ok !$update_failure->($naked), "Can update Naked";
245     ok $naked->make_read_only, "Make Naked read only";
246     ok $update_failure->($naked), "Can't update Naked any more";
247     ok !$update_failure->($sandl), "But can still update Secrets and Lies";
248     my $july4 = eval { Film->create({ title => "4 Days in July" }) };
249     isa_ok $july4 => "Film", "And can still create new films";
250
251     ok(Film->make_read_only, "Make all Films read only");
252     ok $update_failure->($naked), "Still can't update Naked";
253     ok $update_failure->($sandl), "And can't update S&L any more";
254     eval { $july4->delete };
255     like $@, qr/read only/, "And can't delete 4 Days in July";
256     my $abigail = eval { Film->create({ title => "Abigail's Party" }) };
257     like $@, qr/read only/, "Or create new films";
258
259     $_->discard_changes for ($naked, $sandl);
260 }
261
262 done_testing;