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