1use strict; 2use Test::More; 3 4BEGIN { 5 eval "use DBD::SQLite"; 6 plan $@ ? (skip_all => 'needs DBD::SQLite for testing') : (tests => 41); 7} 8 9use lib 't/testlib'; 10use Film; 11use Director; 12@YA::Film::ISA = 'Film'; 13 14Film->create_test_film; 15 16ok my $btaste = Film->retrieve('Bad Taste'), "We have Bad Taste"; 17ok my $pj = $btaste->Director, "Bad taste has a director"; 18ok !ref($pj), ' ... which is not an object'; 19 20ok(Film->has_a('director' => 'Director'), "Link Director table"); 21ok( 22 Director->insert( 23 { 24 Name => 'Peter Jackson', 25 Birthday => -300000000, 26 IsInsane => 1 27 } 28 ), 29 'insert Director' 30); 31 32{ 33 ok $btaste = Film->retrieve('Bad Taste'), "Reretrieve Bad Taste"; 34 ok $pj = $btaste->Director, "Bad taste now hasa() director"; 35 isa_ok $pj => 'Director'; 36 { 37 no warnings 'redefine'; 38 no warnings 'once'; 39 local *Ima::DBI::st::execute = 40 sub { ::fail("Shouldn't need to query db"); }; 41 is $pj->id, 'Peter Jackson', 'ID already stored'; 42 } 43 ok $pj->IsInsane, "But we know he's insane"; 44} 45 46# Oh no! Its Peter Jacksons even twin, Skippy! Born one minute after him. 47my $sj = Director->insert( 48 { 49 Name => 'Skippy Jackson', 50 Birthday => (-300000000 + 60), 51 IsInsane => 1, 52 } 53); 54 55{ 56 eval { $btaste->Director($btaste) }; 57 like $@, qr/is not a Director/, "Can't set film as director"; 58 is $btaste->Director->id, $pj->id, "PJ still the director"; 59 60 # drop from cache so that next retrieve() is from db 61 $btaste->remove_from_object_index; 62} 63 64{ # Still inflated after update 65 my $btaste = Film->retrieve('Bad Taste'); 66 isa_ok $btaste->Director, "Director"; 67 $btaste->numexplodingsheep(17); 68 $btaste->update; 69 isa_ok $btaste->Director, "Director"; 70 71 $btaste->Director('Someone Else'); 72 $btaste->update; 73 isa_ok $btaste->Director, "Director"; 74 is $btaste->Director->id, "Someone Else", "Can change director"; 75} 76 77is $sj->id, 'Skippy Jackson', 'Create new director - Skippy'; 78Film->has_a('codirector' => 'Director'); 79{ 80 eval { $btaste->CoDirector("Skippy Jackson") }; 81 is $@, "", "Auto inflates"; 82 isa_ok $btaste->CoDirector, "Director"; 83 is $btaste->CoDirector->id, $sj->id, "To skippy"; 84} 85 86$btaste->CoDirector($sj); 87$btaste->update; 88is($btaste->CoDirector->Name, 'Skippy Jackson', 'He co-directed'); 89is( 90 $btaste->Director->Name, 91 'Peter Jackson', 92 "Didnt interfere with each other" 93); 94 95{ # Inheriting hasa 96 my $btaste = YA::Film->retrieve('Bad Taste'); 97 is(ref($btaste->Director), 'Director', 'inheriting hasa()'); 98 is(ref($btaste->CoDirector), 'Director', 'inheriting hasa()'); 99 is($btaste->CoDirector->Name, 'Skippy Jackson', ' ... correctly'); 100} 101 102{ 103 $sj = Director->retrieve('Skippy Jackson'); 104 $pj = Director->retrieve('Peter Jackson'); 105 106 my $fail; 107 eval { 108 $fail = YA::Film->insert( 109 { 110 Title => 'Tastes Bad', 111 Director => $sj, 112 codirector => $btaste, 113 Rating => 'R', 114 NumExplodingSheep => 23 115 } 116 ); 117 }; 118 ok $@, "Can't have film as codirector: $@"; 119 is $fail, undef, "We didn't get anything"; 120 121 my $tastes_bad = YA::Film->insert( 122 { 123 Title => 'Tastes Bad', 124 Director => $sj, 125 codirector => $pj, 126 Rating => 'R', 127 NumExplodingSheep => 23 128 } 129 ); 130 is($tastes_bad->Director->Name, 'Skippy Jackson', 'Director'); 131 is( 132 $tastes_bad->_director_accessor->Name, 133 'Skippy Jackson', 134 'director_accessor' 135 ); 136 is($tastes_bad->codirector->Name, 'Peter Jackson', 'codirector'); 137 is( 138 $tastes_bad->_codirector_accessor->Name, 139 'Peter Jackson', 140 'codirector_accessor' 141 ); 142} 143 144{ 145 { 146 147 YA::Film->add_relationship_type(has_a => "YA::HasA"); 148 149 package YA::HasA; 150 use base 'Class::DBI::Relationship::HasA'; 151 152 sub _inflator { 153 my $self = shift; 154 my $col = $self->accessor; 155 my $super = $self->SUPER::_inflator($col); 156 157 return $super 158 unless $col eq $self->class->find_column('Director'); 159 160 return sub { 161 my $self = shift; 162 $self->_attribute_store($col, 'Ghostly Peter') 163 if $self->_attribute_exists($col) 164 and not defined $self->_attrs($col); 165 return &$super($self); 166 }; 167 } 168 } 169 { 170 171 package Rating; 172 173 sub new { 174 my ($class, $mpaa, @details) = @_; 175 bless { 176 MPAA => $mpaa, 177 WHY => "@details" 178 }, $class; 179 } 180 sub mpaa { shift->{MPAA}; } 181 sub why { shift->{WHY}; } 182 } 183 local *Director::mapme = sub { 184 my ($class, $val) = @_; 185 $val =~ s/Skippy/Peter/; 186 $val; 187 }; 188 no warnings 'once'; 189 local *Director::sanity_check = sub { $_[0]->IsInsane ? undef: $_[0] }; 190 YA::Film->has_a( 191 director => 'Director', 192 inflate => 'mapme', 193 deflate => 'sanity_check' 194 ); 195 YA::Film->has_a( 196 rating => 'Rating', 197 inflate => sub { 198 my ($val, $parent) = @_; 199 my $sheep = $parent->find_column('NumexplodingSheep'); 200 if ($parent->_attrs($sheep) || 0 > 20) { 201 return new Rating 'NC17', 'Graphic ovine violence'; 202 } else { 203 return new Rating $val, 'Just because'; 204 } 205 }, 206 deflate => sub { 207 shift->mpaa; 208 } 209 ); 210 211 my $tbad = YA::Film->retrieve('Tastes Bad'); 212 213 isa_ok $tbad->Director, 'Director'; 214 is $tbad->Director->Name, 'Peter Jackson', 'Director shuffle'; 215 $tbad->Director('Skippy Jackson'); 216 $tbad->update; 217 is $tbad->Director, 'Ghostly Peter', 'Sanity checked'; 218 219 isa_ok $tbad->Rating, 'Rating'; 220 is $tbad->Rating->mpaa, 'NC17', 'Rating bumped'; 221 $tbad->Rating(new Rating 'NS17', 'Shaken sheep'); 222 no warnings 'redefine'; 223 local *Director::mapme = sub { 224 my ($class, $obj) = @_; 225 $obj->isa('Film') ? $obj->Director : $obj; 226 }; 227 228 $pj->IsInsane(0); 229 $pj->update; # Hush warnings 230 231 ok $tbad->Director($btaste), 'Cross-class mapping'; 232 is $tbad->Director, 'Peter Jackson', 'Yields PJ'; 233 $tbad->update; 234 235 $tbad = Film->retrieve('Tastes Bad'); 236 ok !ref($tbad->Rating), 'Unmagical rating'; 237 is $tbad->Rating, 'NS17', 'but prior change stuck'; 238} 239 240{ # Broken has_a declaration 241 eval { Film->has_a(driector => "Director") }; 242 like $@, qr/driector/, 243 "Sensible error from has_a with incorrect column: $@"; 244} 245