t/cdbi-t/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 => 55);
  12 }
  13
  14 INIT {
  15     #local $SIG{__WARN__} =
  16         #sub { like $_[0], qr/clashes with built-in method/, $_[0] };
  17     use lib 't/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 sub Film::mutator_name {
  29     my ($class, $col) = @_;
  30     return "set_sheep" if lc $col eq "numexplodingsheep";
  31     return $col;
  32 }
  33
  34 sub Film::accessor_name {
  35     my ($class, $col) = @_;
  36     return "sheep" if lc $col eq "numexplodingsheep";
  37     return $col;
  38 }
  39
  40 sub Actor::accessor_name_for {
  41     my ($class, $col) = @_;
  42     return "movie" if lc $col eq "film";
  43     return $col;
  44 }
  45
  46 # This is a class with accessor_name_for() but no corresponding mutator_name_for()
  47 sub Director::accessor_name_for {
  48     my($class, $col) = @_;
  49     return "nutty_as_a_fruitcake" if lc $col eq "isinsane";
  50     return $col;
  51 }
  52
  53 my $data = {
  54     Title    => 'Bad Taste',
  55     Director => 'Peter Jackson',
  56     Rating   => 'R',
  57 };
  58
  59 eval {
  60     my $data = $data;
  61     $data->{NumExplodingSheep} = 1;
  62     ok my $bt = Film->create($data), "Modified accessor - with column name";
  63     isa_ok $bt, "Film";
  64 };
  65 is $@, '', "No errors";
  66
  67 eval {
  68     my $data = $data;
  69     $data->{sheep} = 1;
  70     ok my $bt = Film->create($data), "Modified accessor - with accessor";
  71     isa_ok $bt, "Film";
  72 };
  73 is $@, '', "No errors";
  74
  75 eval {
  76     my @film = Film->search({ sheep => 1 });
  77     is @film, 2, "Can search with modified accessor";
  78 };
  79
  80 {
  81
  82     eval {
  83         local $data->{set_sheep} = 1;
  84         ok my $bt = Film->create($data), "Modified mutator - with mutator";
  85         isa_ok $bt, "Film";
  86     };
  87     is $@, '', "No errors";
  88
  89     eval {
  90         local $data->{NumExplodingSheep} = 1;
  91         ok my $bt = Film->create($data), "Modified mutator - with column name";
  92         isa_ok $bt, "Film";
  93     };
  94     is $@, '', "No errors";
  95
  96     eval {
  97         local $data->{sheep} = 1;
  98         ok my $bt = Film->create($data), "Modified mutator - with accessor";
  99         isa_ok $bt, "Film";
 100     };
 101     is $@, '', "No errors";
 102
 103 }
 104
 105 {
 106     my $p_data = {
 107         name => 'Peter Jackson',
 108         film => 'Bad Taste',
 109     };
 110     my $bt = Film->create($data);
 111     my $ac = Actor->create($p_data);
 112
 113     ok !eval { my $f = $ac->film; 1 };
 114     like $@, qr/film/, "no hasa film";
 115
 116     eval {
 117         local $SIG{__WARN__} = sub {
 118             warn @_ unless $_[0] =~ /Query returned more than one row/;
 119         };
 120         ok my $f = $ac->movie, "hasa movie";
 121         isa_ok $f, "Film";
 122         is $f->id, $bt->id, " - Bad Taste";
 123     };
 124     is $@, '', "No errors";
 125
 126     {
 127         local $data->{Title} = "Another film";
 128         my $film = Film->create($data);
 129
 130         eval { $ac->film($film) };
 131         ok $@, $@;
 132
 133         eval { $ac->movie($film) };
 134         ok $@, $@;
 135
 136         eval {
 137             ok $ac->set_film($film), "Set movie through hasa";
 138             $ac->update;
 139             ok my $f = $ac->movie, "hasa movie";
 140             isa_ok $f, "Film";
 141             is $f->id, $film->id, " - Another Film";
 142         };
 143         is $@, '', "No problem";
 144     }
 145
 146 }
 147
 148
 149 # Make sure a class with an accessor_name() method has a similar mutator.
 150 {
 151     my $aki = Director->create({
 152         name     => "Aki Kaurismaki",
 153     });
 154
 155     $aki->nutty_as_a_fruitcake(1);
 156     is $aki->nutty_as_a_fruitcake, 1,
 157         "a custom accessor without a custom mutator is setable";
 158     $aki->update;
 159 }
 160
 161 {
 162     Film->columns(TEMP => qw/nonpersistent/);
 163     ok(Film->find_column('nonpersistent'), "nonpersistent is a column");
 164     ok(!Film->has_real_column('nonpersistent'), " - but it's not real");
 165
 166     {
 167         my $film = Film->create({ Title => "Veronique", nonpersistent => 42 });
 168         is $film->title,         "Veronique", "Title set OK";
 169         is $film->nonpersistent, 42,          "As is non persistent value";
 170         $film->remove_from_object_index;
 171         ok $film = Film->retrieve('Veronique'), "Re-retrieve film";
 172         is $film->title, "Veronique", "Title still OK";
 173         is $film->nonpersistent, undef, "Non persistent value gone";
 174         ok $film->nonpersistent(40), "Can set it";
 175         is $film->nonpersistent, 40, "And it's there again";
 176         ok $film->update, "Commit the film";
 177         is $film->nonpersistent, 40, "And it's still there";
 178     }
 179 }
 180
 181 {
 182     is_deeply(
 183         [Actor->columns('Essential')],
 184         [Actor->columns('Primary')],
 185         "Actor has no specific essential columns"
 186     );
 187     ok(Actor->find_column('nonpersistent'), "nonpersistent is a column");
 188     ok(!Actor->has_real_column('nonpersistent'), " - but it's not real");
 189     my $pj = eval { Actor->search(name => "Peter Jackson")->first };
 190     is $@, '', "no problems retrieving actors";
 191     isa_ok $pj => "Actor";
 192 }
 193
 194 {
 195     Film->autoupdate(1);
 196     my $naked = Film->create({ title => 'Naked' });
 197     my $sandl = Film->create({ title => 'Secrets and Lies' });
 198
 199     my $rating = 1;
 200     my $update_failure = sub {
 201         my $obj = shift;
 202         eval { $obj->rating($rating++) };
 203         return $@ =~ /read only/;
 204     };
 205
 206     ok !$update_failure->($naked), "Can update Naked";
 207     ok $naked->make_read_only, "Make Naked read only";
 208     ok $update_failure->($naked), "Can't update Naked any more";
 209     ok !$update_failure->($sandl), "But can still update Secrets and Lies";
 210     my $july4 = eval { Film->create({ title => "4 Days in July" }) };
 211     isa_ok $july4 => "Film", "And can still create new films";
 212
 213     ok(Film->make_read_only, "Make all Films read only");
 214     ok $update_failure->($naked), "Still can't update Naked";
 215     ok $update_failure->($sandl), "And can't update S&L any more";
 216     eval { $july4->delete };
 217     like $@, qr/read only/, "And can't delete 4 Days in July";
 218     my $abigail = eval { Film->create({ title => "Abigail's Party" }) };
 219     like $@, qr/read only/, "Or create new films";
 220
 221     $sandl->discard_changes;
 222 }