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 eval {
  93     my $data = { %$data };
  94     $data->{NumExplodingSheep} = 3;
  95     ok my $bt = Film->find_or_create($data),
  96     "find_or_create Modified accessor - create with column name";
  97     isa_ok $bt, "Film";
  98
  99     local $TODO = 'TODOifying failing tests, waiting for Schwern';
 100     is $bt->sheep, 3, 'sheep bursting violently';
 101 };
 102 is $@, '', "No errors";
 103
 104 eval {
 105     my $data = { %$data };
 106     $data->{sheep} = 4;
 107     ok my $bt = Film->find_or_create($data),
 108     "find_or_create Modified accessor - create with accessor";
 109     isa_ok $bt, "Film";
 110
 111     local $TODO = 'TODOifying failing tests, waiting for Schwern';
 112     is $bt->sheep, 4, 'sheep bursting violently';
 113 };
 114 is $@, '', "No errors";
 115
 116 eval {
 117     my @film = Film->search({ sheep => 1 });
 118     is @film, 2, "Can search with modified accessor";
 119 };
 120 {
 121   local $TODO = 'TODOifying failing tests, waiting for Schwern';
 122   is $@, '', "No errors";
 123 }
 124
 125 {
 126
 127     eval {
 128         local $data->{set_sheep} = 1;
 129         ok my $bt = Film->create($data), "Modified mutator - with mutator";
 130         isa_ok $bt, "Film";
 131     };
 132     is $@, '', "No errors";
 133
 134     eval {
 135         local $data->{NumExplodingSheep} = 1;
 136         ok my $bt = Film->create($data), "Modified mutator - with column name";
 137         isa_ok $bt, "Film";
 138     };
 139     is $@, '', "No errors";
 140
 141     eval {
 142         local $data->{sheep} = 1;
 143         ok my $bt = Film->create($data), "Modified mutator - with accessor";
 144         isa_ok $bt, "Film";
 145     };
 146     is $@, '', "No errors";
 147
 148 }
 149
 150 {
 151     my $p_data = {
 152         name => 'Peter Jackson',
 153         film => 'Bad Taste',
 154     };
 155     my $bt = Film->create($data);
 156     my $ac = Actor->create($p_data);
 157
 158     ok !eval { my $f = $ac->film; 1 };
 159     like $@, qr/film/, "no hasa film";
 160
 161     eval {
 162         ok my $f = $ac->movie, "hasa movie";
 163         isa_ok $f, "Film";
 164         is $f->id, $bt->id, " - Bad Taste";
 165     };
 166     is $@, '', "No errors";
 167
 168     {
 169         local $data->{Title} = "Another film";
 170         my $film = Film->create($data);
 171
 172         eval { $ac->film($film) };
 173         ok $@, $@;
 174
 175         eval { $ac->movie($film) };
 176         ok $@, $@;
 177
 178         eval {
 179             ok $ac->set_film($film), "Set movie through hasa";
 180             $ac->update;
 181             ok my $f = $ac->movie, "hasa movie";
 182             isa_ok $f, "Film";
 183             is $f->id, $film->id, " - Another Film";
 184         };
 185         is $@, '', "No problem";
 186     }
 187
 188 }
 189
 190
 191 # Make sure a class with an accessor_name() method has a similar mutator.
 192 {
 193     my $aki = Director->create({
 194         name     => "Aki Kaurismaki",
 195     });
 196
 197     $aki->nutty_as_a_fruitcake(1);
 198     is $aki->nutty_as_a_fruitcake, 1,
 199         "a custom accessor without a custom mutator is setable";
 200     $aki->update;
 201 }
 202
 203 {
 204     Film->columns(TEMP => qw/nonpersistent/);
 205     ok(Film->find_column('nonpersistent'), "nonpersistent is a column");
 206     ok(!Film->has_real_column('nonpersistent'), " - but it's not real");
 207
 208     {
 209         my $film = Film->create({ Title => "Veronique", nonpersistent => 42 });
 210         is $film->title,         "Veronique", "Title set OK";
 211         is $film->nonpersistent, 42,          "As is non persistent value";
 212         $film->remove_from_object_index;
 213         ok $film = Film->retrieve('Veronique'), "Re-retrieve film";
 214         is $film->title, "Veronique", "Title still OK";
 215         is $film->nonpersistent, undef, "Non persistent value gone";
 216         ok $film->nonpersistent(40), "Can set it";
 217         is $film->nonpersistent, 40, "And it's there again";
 218         ok $film->update, "Commit the film";
 219         is $film->nonpersistent, 40, "And it's still there";
 220     }
 221 }
 222
 223 {
 224     is_deeply(
 225         [Actor->columns('Essential')],
 226         [Actor->columns('Primary')],
 227         "Actor has no specific essential columns"
 228     );
 229     ok(Actor->find_column('nonpersistent'), "nonpersistent is a column");
 230     ok(!Actor->has_real_column('nonpersistent'), " - but it's not real");
 231     my $pj = eval { Actor->search(name => "Peter Jackson")->first };
 232     is $@, '', "no problems retrieving actors";
 233     isa_ok $pj => "Actor";
 234 }
 235
 236 {
 237     Film->autoupdate(1);
 238     my $naked = Film->create({ title => 'Naked' });
 239     my $sandl = Film->create({ title => 'Secrets and Lies' });
 240
 241     my $rating = 1;
 242     my $update_failure = sub {
 243         my $obj = shift;
 244         eval { $obj->rating($rating++) };
 245         return $@ =~ /read only/;
 246     };
 247
 248     ok !$update_failure->($naked), "Can update Naked";
 249     ok $naked->make_read_only, "Make Naked read only";
 250     ok $update_failure->($naked), "Can't update Naked any more";
 251     ok !$update_failure->($sandl), "But can still update Secrets and Lies";
 252     my $july4 = eval { Film->create({ title => "4 Days in July" }) };
 253     isa_ok $july4 => "Film", "And can still create new films";
 254
 255     ok(Film->make_read_only, "Make all Films read only");
 256     ok $update_failure->($naked), "Still can't update Naked";
 257     ok $update_failure->($sandl), "And can't update S&L any more";
 258     eval { $july4->delete };
 259     like $@, qr/read only/, "And can't delete 4 Days in July";
 260     my $abigail = eval { Film->create({ title => "Abigail's Party" }) };
 261     like $@, qr/read only/, "Or create new films";
 262
 263     $_->discard_changes for ($naked, $sandl);
 264 }
 265
 266 done_testing;