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