t/cdbi/15-accessor.t

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