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