t/cdbi/15-accessor.t

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