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