t/cdbi/15-accessor.t

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