1# Before `make install' is performed this script should be runnable with 2# `make test'. After `make install' it should work as `perl test.pl' 3 4######################### We start with some black magic to print on failure. 5 6# Change 1..1 below to 1..last_test_to_print . 7# (It may become useful if the test is moved to ./t subdirectory.) 8 9BEGIN { $| = 1; print "1..23\n"; } 10END {print "not ok 1\n" unless $loaded;} 11# use blib; 12$loaded = 1; 13$i=1; 14result($loaded); 15 16######################### End of black magic. 17 18# Insert your test code below (better if it prints "ok 13" 19# (correspondingly "not ok 13") depending on the success of chunk 13 20# of the test code): 21 22BEGIN { 23 unshift (@INC, '.'); 24 open(F,">Foo.pm") or die "Couldn't write Foo.pm"; 25 26 print F <<'EOF'; 27package Foo; 28use Class::ObjectTemplate; 29@ISA = qw(Class::ObjectTemplate); 30attributes(one, two, three); 31 321; 33EOF 34 close(F); 35} 36use lib '.'; 37require Foo; 38my $f = new Foo(one=>23); 39 40# 41# test that a value defined at object creation is properly set 42# 43result($f->one() == 23); 44 45# 46# test that a value not defined at object creation is undefined 47# 48result(! defined $f->two()); 49 50# 51# test that we can set and retrieve a value 52# 53$f->two(45); 54result($f->two() == 45); 55 56END { 1 while unlink 'Foo.pm'} 57 58BEGIN { 59 open(F,">Baz.pm") or die "Couldn't write Baz.pm"; 60 61 print F <<'EOF'; 62package Baz; 63use Class::ObjectTemplate; 64use subs qw(undefined); 65@ISA = qw(Class::ObjectTemplate); 66attributes('one', 'two'); 67 68package BazINC; 69use Class::ObjectTemplate; 70@ISA = qw(Baz); 71attributes(); 72 73package BazINC2; 74use Class::ObjectTemplate; 75@ISA = qw(Baz); 76 77attributes('three','four'); 78 791; 80EOF 81 close(F); 82} 83 84require Baz; 85$baz = new Baz(); 86$baz->two(27); 87result($baz->two() == 27); 88 89# 90# test that the data for attributes is being stored in the 'Baz::' namespace 91# this is to monitor a bug that was storing lookup data in the 'main::' 92# namespace 93result(scalar @Baz::_two); 94 95# test that @Baz::_ATTRIBUTES_ and is being properly set. This is to 96# check a bug that overwrote it on each call to attributes() 97result(scalar @Baz::_ATTRIBUTES_ == 2); 98 99# 100# Test an inherited class that defines no new attributes 101# 102$baz_inc = new BazINC(); 103 104# test that @BazINC::_ATTRIBUTES_ *is* being set. 105# each base class now maintains all its inherited attributes 106result(scalar @BazINC::_ATTRIBUTES_ == 2); 107 108$baz_inc->one(34); 109result($baz_inc->one() == 34); 110 111# 112# !!!! WARNING ALL THESE TESTS SHOULD FAIL !!!! 113# 114# they are here to illustrate bugs in the original code, v0.1 115# 116 117# 118# test that the data is being stored in the 'BazINC::' namespace 119# this is to monitor a bug that was storing lookup data in the 'main::' 120# namespace 121result(scalar @BazINC::_one); 122 123# 124# test that Baz and BazINC not interfering with one another 125# even though their attribute arrays are in Baz's namespace 126$baz->one(45); 127$baz_inc->one(56); 128result($baz_inc->one() != $baz->one()); 129 130# 131# test that $baz_inc->DESTROY properly modifies that @_free array in 132# BazINC and does not add one to Baz 133$old_free = scalar @BazINC::_free; 134$baz_inc->DESTROY(); 135result(! scalar @Baz::_free); 136 137result($old_free != scalar @BazINC::_free); 138 139END { 1 while unlink 'Baz.pm'} 140 141# 142# End of v0.1 bug tests 143# 144 145# 146# Now test inheritance from a class that defines new attributes 147# 148$baz_inc2 = BazINC2->new(); 149$baz_inc2->one(34); 150result($baz_inc2->one() == 34); 151 152$baz_inc2->three(34); 153result($baz_inc2->three() == 34); 154 155$old_free = scalar @BazINC2::_free; 156$baz_inc2->DESTROY(); 157result(! scalar @Baz::_free); 158 159result($old_free != scalar @BazINC2::_free); 160 161BEGIN { 162 open(F,">Bar.pm") or die "Couldn't write Bar.pm"; 163 164 print F <<'EOF'; 165package Bar; 166use Class::ObjectTemplate; 167use subs qw(undefined); 168@ISA = qw(Class::ObjectTemplate); 169attributes('one', 'two'); 170attributes('three'); 171 1721; 173EOF 174 close(F); 175} 176 177# 178# Test that we get an error trying to call attributes() twice 179# 180eval "require Bar;"; 181result($@); 182 183END { 1 while unlink 'Bar.pm'} 184 185# 186# test that attributes works properly when a subroutine 187# of the same name already exists 188# 189BEGIN { 190 open(F,">Foo2.pm") or die "Couldn't write Foo2.pm"; 191 print F <<'EOT'; 192package Foo2; 193use Class::ObjectTemplate; 194@ISA = qw(Class::ObjectTemplate); 195attributes(one, two, three); 196sub one {return 1;} 197 1981; 199EOT 200 close(F); 201} 202require Foo2; 203 204my $f = Foo2->new(); 205 206# the original subroutine gets called 207result($f->one() == 1); 208 209# but the attribute is undefined 210result(!defined $f->get_attribute('one')); 211 212# set the attribute and check its value 213my $value = 5; 214$f->set_attribute('one',$value); 215result($f->get_attribute('one') == $value); 216 217# check that the subroutine is still called 218result($f->one() == 1); 219 220# test get_attributes() 221$f->two(24); 222$f->three(24); 223my @list = ($f->two,$f->three); 224my @list2 = $f->get_attributes('two','three'); 225my $equal = 1; 226for (my $i=0;$i<scalar @list;$i++) { 227 if ($list[$i] != $list2[$i]) { 228 $equal = 0; 229 last; 230 } 231} 232result($equal); 233 234END { 1 while unlink 'Foo2.pm'} 235 236sub result { 237 my $cond = shift; 238 print STDERR "not " unless $cond; 239 print STDERR "ok ", $i++, "\n"; 240} 241