1#!/usr/bin/perl -w 2# 3# test script for Tangram::Object 4# 5 6use strict 'vars', 'subs'; 7use lib "../blib/lib"; 8use Test::More tests => 88; 9use Data::Dumper; 10use Date::Manip qw(ParseDate); 11 12#--------------------------------------------------------------------- 13# Test 1: Check Class::Tangram loads 14 15use_ok("Class::Tangram"); 16use_ok("Set::Object"); 17 18#--------------------------------------------------------------------- 19# define our movie database 20package Movie; 21use vars qw(@ISA $schema); 22@ISA = qw(Class::Tangram); 23 24$schema = { 25 fields => { 26 string => [ qw(title) ], 27 int => [ qw(release_year) ], 28 # this means there is a set of 'Credit' objects 29 # related to this 'Movie' object. 30 iset => 31 { 32 credits => 'Credit', 33 }, 34 }, 35 }; 36 37package Person; 38use vars qw(@ISA $schema); 39@ISA = qw(Class::Tangram); 40$schema = { 41 fields => { 42 string => [ qw(name) ], 43 rawdatetime => [ qw(birthdate) ], 44 ref => [ qw(birth_location) ], 45 flat_hash => [ qw(flat_hash) ], 46 flat_array => [ qw(flat_array) ], 47 real => { height => undef, }, 48 # This person also has a set of credits 49 iset => 50 { 51 credits => 'Credit', 52 }, 53 }, 54 }; 55 56package Job; 57use vars qw(@ISA $schema); 58@ISA = qw(Class::Tangram); 59$schema = { 60 fields => { 61 string => [ qw(job_title) ], 62 # As does this job 63 iset => 64 { 65 credits => 'Credit', 66 }, 67 } 68 }; 69 70package Credit; 71use vars qw($schema); 72use base qw(Class::Tangram); 73 74my $counter; 75 76$schema = { 77 fields => { 78 string => 79 { 80 foo => { 81 check_func => sub { 82 die if (${$_[0]} !~ /^ba[rz]$|cheese|banana/); 83 }, 84 init_default => "baz", 85 }, 86 bar => { 87 init_default => sub { 88 ++$counter; 89 } 90 } 91 }, 92 int => 93 { 94 cheese => { 95 check_func => sub { 96 die "too big" if (${$_[0]} > 15); 97 }, 98 init_default => 15, 99 }, 100 }, 101 }, 102 }; 103 104package Location; 105use vars qw(@ISA $schema); 106@ISA = qw(Class::Tangram); 107$schema = { 108 fields => { 109 string => [ qw(location) ], 110 ref => [ qw(parent_location) ], 111 } 112 }; 113 114package Testing; 115use vars qw(@ISA $schema); 116@ISA = qw(Class::Tangram); 117# a testing class, contains lots of different types 118$schema = { 119 fields => { 120 array => { test_a => { class => "Credit" } }, 121 hash => { test_h => { class => "Credit" } }, 122 rawdatetime => [ qw( birth death ) ], 123 rawdate => [ qw( depart return ) ], 124 rawtime => [ qw( breakfast lunch dinner ) ], 125 dmdatetime => [ qw( attack retreat ) ], 126 127 string => 128 { 129 enum_t => { sql => ("enum('bucket', 'green', " 130 ."'ambiguity')") }, 131 enum_G => { sql => ('enum("dat", "is", "wot",' 132 .'"I", "as", "erd")') }, 133 set_t => { sql => ("set ('bucket', 'green', " 134 ."'ambiguity')") }, 135 set_G => { sql => ('set ("dat", "is", "wot",' 136 .'"I", "as", "erd")') }, 137 138 }, 139 transient => 140 { 141 transient_t => 142 { 143 check_func => sub { 144 die "not a code ref" 145 unless (ref ${ (shift) } eq "CODE"); 146 } 147 } 148 }, 149 idbif => 150 { 151 i_say_poof => # there goes another one 152 undef, 153 }, 154 } 155 }; 156 157# empty subclass test 158package Testing::One; 159use vars qw(@ISA); 160@ISA=qw(Testing); 161 162package Testing::One::Two; 163use vars qw(@ISA); 164@ISA=qw(Testing::One Date::Manip); 165 166package Testing::One::Two::Three; 167use vars qw(@ISA); 168@ISA=qw(Testing::One::Two); 169 170#--------------------------------------------------------------------- 171# for "required" test 172package Fussy; 173use vars qw(@ISA $schema); 174@ISA=qw(Class::Tangram); 175 176$schema = 177 { 178 fields => 179 { 180 string => { 181 foo => { required => 1, 182 init_default => "banana" }, 183 bar => { required => "" }, 184 baz => { 185 required => 1, 186 check_func => sub { 187 die "bad boy" 188 unless (${$_[0]} =~ m/cheese|^$/) 189 }, 190 }, 191 }, 192 } 193 }; 194 195sub create { 196 my $class = shift; 197 198 my $self = $class->SUPER::new(@_); 199} 200 201 202package MoreFussy; 203use vars qw(@ISA); 204@ISA = qw(Fussy); 205 206#--------------------------------------------------------------------- 207package main; 208use strict; 209 210for my $pkg (qw(Movie Person Job Credit Location)) { 211 eval { Class::Tangram::import_schema($pkg) }; 212 is($@, "", "import_schema('$pkg')"); 213} 214 215my (@locations, @credits, @jobs, @movies, @actors); 216 217eval { 218 @locations = 219 ( 220 new Location( location => "Grappenhall", 221 parent_location => new Location 222 ( location => "Warrington", 223 parent_location => new Location 224 ( location => "Cheshire", 225 parent_location => new Location 226 ( location => "England", 227 parent_location => new Location 228 ( location => "United Kingdom" ) ) ) ) ), 229 new Location( location => "Dallas", 230 parent_location => new Location 231 ( location => "Texas", 232 parent_location => new Location 233 ( location => "United States" ) ) ), 234 ); 235 236 @credits = ( map { new Credit } (1..5) ); 237 238 @jobs = 239 ( 240 new Job( job_title => "Dr. Frank-N-Furter", 241 credits => Set::Object->new( $credits[0] ) ), 242 new Job( job_title => "Wadsworth", 243 credits => Set::Object->new( $credits[1] ) ), 244 new Job( job_title => "Prosecutor", 245 credits => Set::Object->new( $credits[2] ) ), 246 new Job( job_title => "Long John Silver", 247 credits => Set::Object->new( $credits[3] ) ), 248 new Job( job_title => "Dr. Scott", 249 credits => Set::Object->new( $credits[4] ) ), 250 ); 251 252 @movies = 253 ( 254 new Movie( title => "Rocky Horror Picture Show", 255 release_year => 1975, 256 credits => Set::Object->new( @credits[0, 4] ) ), 257 new Movie( title => "Clue", 258 release_year => 1985, 259 credits => Set::Object->new( $credits[1] ) ), 260 new Movie( title => "The Wall: Live in Berlin", 261 release_year => 1990, 262 credits => Set::Object->new( $credits[2] ) ), 263 new Movie( title => "Muppet Treasure Island", 264 release_year => 1996, 265 credits => Set::Object->new( $credits[3] ) ), 266 ); 267 268 @actors = 269 ( 270 new Person( name => "Tim Curry", 271 birthdate => "1946-04-19 12:00:00", 272 birth_location => $locations[0], 273 credits => 274 Set::Object->new( @credits[0..3] ) ), 275 new Person( name => "Marvin Lee Aday", 276 birthdate => "1947-09-27 12:00:00", 277 birth_location => $locations[1], 278 credits => 279 Set::Object->new( $credits[4] ) ), 280 new Person(), 281 ); 282 283}; 284 285is($@, "", "new of various objects"); 286 287is($locations[0]->location, "Grappenhall", "new Location"); 288 289#--------------------------------------------------------------------- 290# test set 291 292# string 293eval { $actors[0]->set_name("Timothy Curry"); }; 294is ($@, "", "Set string to legal value"); 295eval { $actors[0]->set_name("Tim Curry" x 100); }; 296isnt ($@, "", "Set string to illegal value"); 297 298# string sub-types: tinyblob, blob, longblob 299eval { 300 my $test_obj = Testing->new(); 301 302 $test_obj->set_enum_t("bucket"); 303 $test_obj->set_enum_t("AmBiGuIty"); 304 $test_obj->set_enum_G("wOt"); 305 $test_obj->set_enum_G("erD"); 306 $test_obj->set_set_t("bucket,ambiguity"); 307 $test_obj->set_set_G("wot,dat , I, as,erd"); 308 $test_obj->set_i_say_poof("der goz an udda un innit"); 309}; 310is ($@, "", "Set set/enum to legal value"); 311 312my $test_obj = Testing->new(); 313my $allbad = 1; 314eval { $test_obj->set_enum_t("wot"); }; $@ or ($allbad = 0); 315eval { $test_obj->set_enum_G("bucket"); }; $@ or ($allbad = 0); 316eval { $test_obj->set_set_t("bucket,cheese"); }; $@ or ($allbad = 0); 317eval { $test_obj->set_set_G("blue"); }; $@ or ($allbad = 0); 318 319ok($allbad, "Set set/enum to illegal value"); 320 321# int 322eval { $movies[0]->set_release_year("-2000"); }; 323is ($@, "", "Set int to legal value"); 324 325eval { $movies[0]->set_release_year("2000BC"); }; 326isnt ($@, "", "Set int to illegal value"); 327 328# real 329eval { 330 $actors[0]->set_height("1.3e7"); 331 $actors[0]->set_height("1.3"); 332 $actors[0]->set_height("-12345678735"); 333}; 334is ($@, "", "Set real to legal value"); 335 336eval { $actors[0]->set_height("12345i"); }; 337isnt ($@, "", "Set real to illegal value"); 338 339# obj 340eval { 341 $actors[1]->set_birth_location($locations[int rand scalar @locations]); 342 $actors[1]->set_birth_location($locations[int rand scalar @locations]); 343 $actors[1]->set_birth_location($locations[int rand scalar @locations]); 344}; 345is ($@, "", "Set ref to legal value"); 346 347eval { $actors[0]->set_birth_location("Somewhere, over the rainbow"); }; 348isnt ($@, "", "Set ref to illegal value"); 349 350# array 351{ 352 my @array = $test_obj->test_a; 353 my $scalar = $test_obj->test_a; 354 355 ok((@array == 0 and ref $scalar eq "ARRAY"), 356 "Class->get(array_type) for uninitialised array"); 357}; 358 359# rawdatetime 360eval { $actors[0]->set_birthdate("yesterday"); }; 361isnt ($@, "", "Set rawdatetime to illegal value"); 362 363eval { $actors[0]->set_birthdate("1234-02-02 12:34:56") }; 364is ($@, "", "Set rawdatetime to legal value"); 365 366# time 367eval { $actors[0]->set_birthdate("yesterday"); }; 368isnt ($@, "", "Set rawdatetime to illegal value"); 369eval { $actors[0]->set_birthdate("1234-02-02 12:34:56") }; 370is ($@, "", "Set rawdatetime to legal value"); 371 372# rawdate 373eval { $test_obj->set_depart("2002-03-22"); }; 374is ($@, "", "Set rawdatetime to legal value"); 375eval { $test_obj->set_depart("2002-03-22 12:34:56"); }; 376isnt ($@, "", "Set rawdate to illegal value"); 377 378# rawtime 379eval { $test_obj->set_breakfast("5:45") }; 380is ($@, "", "Set breakfast to insane time"); 381eval { $test_obj->set_breakfast("sparrowfart") }; 382isnt ($@, "", "Set breakfast to insane and illegal value"); 383 384# dmdatetime 385eval { $test_obj->set_attack(ParseDate("today")) }; 386is ($@, "", "Set dmdatetime to valid value"); 387 388# ooh, wouldn't this be nice if it worked? 389eval { $test_obj->set_attack("yestoday") }; 390isnt ($@, "", "Set dmdatetime to invalid value"); 391 392# empty hash 393eval { 394 while ( my ($k, $v) = each %{$test_obj->test_h}) { 395 1; 396 } 397}; 398is ($@, "", "Interate over undef hash attribute"); 399 400# flat_hash 401eval { 402 while ( my ($k, $v) = each %{$actors[0]->flat_hash}) { 403 die "empty hash not so empty; $k => $v"; 404 } 405}; 406is ($@, "", "Interate over undef flat_hash attribute"); 407is_deeply( [ $actors[0]->flat_hash ], [ ], 408 "Array context get flat_hash"); 409 410# flat_array 411eval { 412 for (@{$actors[0]->flat_array}) { 413 die "empty array not so empty; $_"; 414 } 415}; 416is_deeply( [ $actors[0]->flat_array ], [ ], 417 "Array context get flat_array"); 418is ($@, "", "Interate over undef flat_array attribute"); 419 420#--------------------------------------------------------------------- 421# check init_default 422is($credits[0]->foo, "baz", "init_default scalar"); 423is($credits[0]->bar, 1, "init_default sub"); 424is($credits[3]->bar, 4, "init_default sub"); 425 426$credits[0]->set_init_default(foo => "cheese"); 427is(Credit->new()->foo, "cheese", 428 "set_init_default as instance method"); 429Credit->set_init_default(foo => "banana"); 430is(Credit->new()->foo, "banana", 431 "set_init_default as Class method"); 432 433 434#--------------------------------------------------------------------- 435# check check_func 436eval { 437 $credits[0]->set_foo("Anything"); 438}; 439isnt($@, "", "check_func string illegal"); 440eval { 441 $credits[0]->set_foo("bar"); 442}; 443is($@, "", "check_func string legal"); 444 445eval { $credits[0]->set_cheese(16); }; 446isnt($@, "", "check_func int illegal"); 447eval { $credits[0]->set_cheese(-1); }; 448is($@, "", "check_func int legal"); 449 450#--------------------------------------------------------------------- 451# check clear_refs 452my $movie = new Movie; 453$movie->{credits} = "something illegal"; 454eval { $movie->clear_refs(); }; 455is($@, "", "clear_refs on bogus set OK"); 456 457#--------------------------------------------------------------------- 458# check get on invalid fields 459eval { $actors[0]->set_karma("high"); }; 460isnt($@, "", "Set invalid field"); 461eval { $locations[0]->set("cheese", "high"); }; 462isnt($@, "", "Set invalid field"); 463 464#--------------------------------------------------------------------- 465# Set::Object functions 466is(ref $actors[2]->{credits}, "Set::Object", "iset init_default"); 467my @foo = $actors[0]->credits; 468is ($#foo, 3, "list context get of set"); 469my $foo = $actors[0]->credits; 470ok($foo->isa("Set::Object"), "scalar context get of set"); 471ok($actors[0]->credits_includes($foo[2]), "AUTOLOAD _includes"); 472$actors[0]->credits_remove($foo[2]); 473ok(!$actors[0]->credits_includes($foo[2]), "AUTOLOAD _remove"); 474$actors[0]->credits_clear; 475ok(!$actors[0]->credits_includes($foo[1]), "AUTOLOAD _clear"); 476$actors[0]->credits_insert($foo[1]); 477ok($actors[0]->credits_includes($foo[1]), "AUTOLOAD _insert"); 478is($actors[0]->credits_size, 1, "AUTOLOAD _size"); 479 480#--------------------------------------------------------------------- 481# empty subclass test 482my $test = Testing::One->new(); 483eval { $test->attack }; 484is ($@, "", "Empty subclass test 1 passed"); 485 486$test = Testing::One::Two->new(); 487eval { $test->attack }; 488is ($@, "", "Empty subclass test 2 passed"); 489 490$test = Testing::One::Two::Three->new(); 491eval { $test->attack }; 492is ($@, "", "Empty subclass test 3 passed"); 493 494#--------------------------------------------------------------------- 495# transient types 496eval { $test->set_transient_t(sub { 37 }); }; 497is ($@, "", "Set transient type to legal value"); 498is ($test->transient_t->(), 37, "Execute transient type"); 499eval { $test->set_transient_t("test"); }; 500isnt ($@, "", "Set transient type to illegal value"); 501 502#--------------------------------------------------------------------- 503# "required" fields 504eval { new Fussy(baz => "Wednesleydale cheese", foo => "this" ) }; 505isnt ($@, "", "'required' - new w/missing attribute"); 506eval { new Fussy(baz => "Wednesleydale cheese", bar => "hi" ) }; 507is ($@, "", "'required' - new w/missing attribute + default"); 508eval { new Fussy(baz => "Wednesleydale cheese", bar => "hi", foo => "" ) }; 509isnt ($@, "", "'required' - new w/missing attr + default + blank"); 510eval { new Fussy(foo => "bar", bar => "hi", baz => "Edam cheese")}; 511is ($@, "", "'required' - new all non-empty"); 512eval { new Fussy(foo => "bar", baz => "Gloucester cheese" ) }; 513isnt ($@, "", "'required' - new w/empty OK field missing"); 514eval { new Fussy(bar => "", foo => "bar", baz => "Leicester cheese" )}; 515is ($@, "", "'required' - new w/empty OK field empty"); 516eval { new Fussy(bar => "", foo => "bar", baz => "cheesy" )}; 517isnt ($@, "", "'required' - new w/reqd field that fails check_func"); 518eval { new Fussy(bar => "", foo => "bar", baz => "" )}; 519isnt ($@, "", "'required' - new w/reqd field that passes check_func"); 520 521# Does a derived class behave exactly the same? 522eval { new MoreFussy(baz => "Wednesleydale cheese", foo => "this" ) }; 523isnt ($@, "", "subclass 'required' - new w/missing attribute"); 524eval { new MoreFussy(baz => "Wednesleydale cheese", bar => "hi" ) }; 525is ($@, "", "subclass 'required' - new w/missing attribute + default"); 526eval { new MoreFussy(baz => "Wednesleydale cheese", bar => "hi", foo => "" ) }; 527isnt ($@, "", "subclass 'required' - new w/missing attr + default + blank"); 528eval { new MoreFussy(foo => "bar", bar => "hi", baz => "Edam cheese")}; 529is ($@, "", "subclass 'required' - new all non-empty"); 530eval { new MoreFussy(foo => "bar", baz => "Gloucester cheese" ) }; 531isnt ($@, "", "subclass 'required' - new w/empty OK field missing"); 532eval { new MoreFussy(bar => "", foo => "bar", baz => "Leicester cheese" )}; 533is ($@, "", "subclass 'required' - new w/empty OK field empty"); 534eval { new MoreFussy(bar => "", foo => "bar", baz => "cheesy" )}; 535isnt ($@, "", "subclass 'required' - new w/reqd field that fails check_func"); 536eval { new MoreFussy(bar => "", foo => "bar", baz => "" )}; 537isnt ($@, "", "subclass 'required' - new w/reqd field that passes check_func"); 538 539# check when loading from DB with missing field 540package Tangram::Toaster; 541 542sub toast { Fussy->new(baz => "More cheese", bar => "hi"); } 543sub burn { Fussy->new() } 544sub fry { Fussy->create() } 545sub dodge { (shift)->(); } 546 547package main; 548 549# new() should only moan about 'required' attributes missing when 550# constructed from packages that aren't Tangram::, or something in 551# @{(ref $self).::ISA} 552 553eval { Tangram::Toaster::toast }; 554is ($@, "", "'required' - full object, Tangram:: caller, CT::new"); 555eval { Tangram::Toaster::burn }; 556is ($@, "", "'required' - short object, Tangram:: caller, CT::new"); 557eval { Tangram::Toaster::fry }; 558is ($@, "", "'required' - short object, Tangram:: caller, subclass::new"); 559 560eval { Fussy->create() }; 561isnt ($@, "", "'required' - short object, main:: caller, subclass::new"); 562eval { Fussy->create(baz => "cheese", bar => "gaga") }; 563is ($@, "", "'required' - short object, main:: caller, subclass::new"); 564 565eval { Tangram::Toaster::dodge(sub { Fussy->create(); }) }; 566isnt ($@, "", "'required' - short object, Tangram::+main:: caller, subclass::new"); 567eval { Tangram::Toaster::dodge ( sub { Fussy->create(baz => "cheese", bar => "thrrppp"); }) }; 568is ($@, "", "'required' - full object, Tangram::+main:: caller, subclass::new"); 569 570#---------------------------------------- 571# $object->new() 572my $doppelgaenger = $actors[0]->new(); 573is($doppelgaenger->name, $actors[0]->name, "\$object->new()"); 574isnt($doppelgaenger, $actors[0], "\$object->new() returns a copy"); 575 576$doppelgaenger = $actors[0]->new(name => "Joe Sullivan"); 577isnt($doppelgaenger->name, $actors[0]->name, 578 "\$object->new() can take arguments"); 579 580*Person::get_name = sub { return "John Malcovich" }; 581my $john = $actors[0]->new(); 582undef *Person::get_name; 583is($john->name, "John Malcovich", "copy uses getters"); 584 585# Still to write tests for: 586# - run time type information functions 587# - checking that fields are not auto-vivified unnecessarily 588# - function overriding works as expected 589