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