1# This script should be runnable with 'make test'.
2
3######################### We start with some black magic to print on failure.
4
5BEGIN { $| = 1 }
6END { print "not ok 1\n"  unless $loaded }
7
8use lib qw( ./t );
9use Magic;
10
11use Class::Contract;
12$loaded = 1;
13print "ok 1\n";
14
15######################### End of black magic.
16
17::ok('desc'   => 'Simple Contract',
18     'expect' => 1,
19     'code'   => <<'CODE');
20package Simple;
21use Class::Contract;
22contract {
23  method 'my_method'; impl {1};
24  abstract method 'my_abstract_method';
25  class abstract method 'my_class_abstract_method';
26  abstract class method 'my_abstract_class_method';
27
28  attr 'my_attr';
29  class attr 'my_class_attr';
30};
31CODE
32
33::ok('desc'   => 'Extended Contracts',
34     'expect' => 1,
35     'code'   => <<'CODE');
36package Grandfather;
37use Class::Contract;
38
39contract {
40  ctor 'new';
41    impl { shift if $Class::Contract::VERSION < 1.10; push @::test, [0, @_]; };
42  class method 'incr';
43    pre  { $::test{'pre'}++;  1 };
44    impl { $::test{'impl'}++; 1 };
45    post { $::test{'post'}++; 1 };
46  eval qq|class method '_$_'; pre {1}; impl {1}| foreach qw(a b c d e f g h i);
47  eval qq|class method '_$_'; impl {1}         | foreach qw(j k l m n o p q r);
48  eval qq|class method '_$_'; pre {0}; impl {1}| foreach qw(s t u v w x y z 1);
49  die $@  if $@;
50};
51
52package Father;
53use Class::Contract;
54contract {
55  inherits 'Grandfather';
56  ctor 'new';
57    impl { shift if $Class::Contract::VERSION < 1.10; push @::test, [1, @_]; };
58  class method 'incr';
59    pre  { $::test{'pre'}++;  0 };
60    impl { $::test{'impl'}++; 1 };
61    post { $::test{'post'}++; 1 };
62  eval qq|class method '_$_'; pre {1}; impl {1}| foreach qw(a b c j k l s t u);
63  eval qq|class method '_$_'; impl {1}         | foreach qw(d e f m n o v w x);
64  eval qq|class method '_$_'; pre {0}; impl {1}| foreach qw(g h i p q r y z 1);
65  die $@  if $@;
66};
67
68package Son;
69use Class::Contract;
70contract {
71  inherits 'Father';
72  ctor 'new';
73    impl { shift if $Class::Contract::VERSION < 1.10; push @::test, [2, @_]; };
74  class method 'incr';
75    pre  { $::test{'pre'}++;  0 };
76    impl { $::test{'impl'}++; 1 };
77    post { $::test{'post'}++; 1 };
78  eval qq|class method '_$_'; pre {1}; impl {1}| foreach qw(a d g j m p s v y);
79  eval qq|class method '_$_'; impl {1}         | foreach qw(b e h k n q t w z);
80  eval qq|class method '_$_'; pre {0}; impl {1}| foreach qw(c f i l o r u x 1);
81  die $@  if $@;
82};
83
84package Args;
85use Class::Contract;
86contract {
87  ctor 'new';
88    pre  { $::test{'pre'}  = \@_; 1 };
89    impl { $::test{'impl'} = \@_; 1 };
90    post { $::test{'post'} = \@_; 1 };
91  class method 'same';
92    pre  { @{$::test{'same_pre'}}  = (@_); 1 };
93    impl { @{$::test{'same_impl'}} = (@_); 1 };
94    post { @{$::test{'same_post'}} = (@_); 1 };
95  class method 'modify_pre';
96    pre  {
97      shift  if $Class::Contract::VERSION < 1.10;
98      $_[0] = 'pre'; $::test{'pre'} = $_[0]; 1;
99    };
100    impl { shift if $Class::Contract::VERSION < 1.10; $::test{'impl'}=$_[0]; 1};
101    post { shift if $Class::Contract::VERSION < 1.10; $::test{'post'}=$_[0]; 1};
102  class method 'modify_impl';
103    pre  { shift if $Class::Contract::VERSION < 1.10; $::test{'pre'}=$_[0]; 1};
104    impl {
105      shift  if $Class::Contract::VERSION < 1.10;
106      $_[0] = 'impl'; $::test{'impl'} = $_[0]; 1;
107    };
108    post {
109      shift  if $Class::Contract::VERSION < 1.10;
110      $::test{'post'} = $_[0]; 1
111    };
112  class method 'modify_post';
113    pre  {
114      shift  if $Class::Contract::VERSION < 1.10;
115      $::test{'pre'}=$_[0]; 1
116    };
117    impl {
118      shift  if $Class::Contract::VERSION < 1.10;
119      $::test{'impl'}=$_[0]; 1
120    };
121    post {
122      shift  if $Class::Contract::VERSION < 1.10;
123      $_[0] = 'post'; $::test{'post'} = $_[0]; 1;
124    };
125};
126CODE
127
128
129::ok('desc' => "pre gets shallow copy of args to be passed to impl",
130     'expect' => 1,
131     'need'   => 'Extended Contracts',
132     'code'   => <<'CODE');
133package main;
134undef %::test;
135my @args = qw(1 a 2 b 4 c);
136Args->same(@args);
137
138my $fail = 0;
139foreach (0..$#args) {
140  $fail++
141    if $::test{'same_pre'}->[$_] ne $::test{'same_impl'}->[$_]
142}
143$fail ? 0 : 1;
144CODE
145
146
147::ok('desc' => "pre can't modify args passed to method or impl",
148     'expect' => 1,
149     'need'   => 'Extended Contracts',
150     'code'   => <<'CODE');
151package main;
152%test = ();
153my $arg = 'foo';
154Args->modify_pre($arg);
155join('', $arg, @test{qw(pre impl post)}) eq 'fooprefoofoo';
156CODE
157
158
159::ok('desc' => "impl can modify args passed to method and post",
160     'expect' => 1,
161     'need'   => 'Extended Contracts',
162     'code'   => <<'CODE');
163package main;
164%test = ();
165my $arg = 'foo';
166Args->modify_impl($arg);
167join('', $arg, @test{qw( pre impl post )}) eq 'implfooimplimpl';
168CODE
169
170
171::ok('desc'    => "post can't modify args passed to method",
172     'expect'  => 1,
173     'need'    => 'Extended Contracts',
174     'code'    => <<'CODE');
175package main;
176%test = ();
177my $arg = 'foo';
178Args->modify_post($arg);
179join('', $arg, @test{qw( pre impl post )}) eq 'foofoofoopost';
180CODE
181
182
183::ok('desc'   => 'invoking abstract method raises exception',
184     'expect' => qr/^Can\'t call abstract method/s,
185     'need'   => 'Simple Contract',
186     'code'   => <<'CODE');
187package main;
188Simple->my_class_abstract_method;
189CODE
190
191
192::ok('desc'   => 'missing impl raise an exception',
193     'expect' => qr/^No implementation for method foo/s,
194     'code'   => <<'CODE');
195package UnDeclared_Method;
196use Class::Contract;
197contract { method 'foo' };
198CODE
199
200
201::ok('desc'   => 'simple implementation based on abstract',
202     'expect' => 1,
203     'need'   => 'Simple Contract',
204     'code'   => <<'CODE');
205package Inherited_Class_Method;
206use Class::Contract;
207contract {
208  inherits 'Simple';
209  class method 'my_class_abstract_method';
210    impl { 1 };
211};
212
213package main;
214Inherited_Class_Method->my_class_abstract_method,
215CODE
216
217
218::ok('desc'   => "implementation not inherited",
219     'expect' => 1,
220     'need'   => 'Extended Contracts',
221     'code'   => <<'CODE');
222package main;
223%test = ();
224Son->incr;
225$test{'impl'};
226CODE
227
228::ok('desc'   => 'post-conditions are inherited',
229     'expect' => 3,
230     'need'   => 'Extended Contracts',
231     'code'   => <<'CODE');
232package main;
233%test = ();
234Son->incr;
235$test{'post'};
236CODE
237
238::ok('desc'   => 'pre check must satisfy self or an ascending ancestor',
239     'expect' => '',
240     'need'   => 'Extended Contracts',
241     'code'   => <<'CODE');
242package main;
243undef $@;
244$fail = '';
245
246# No inheritence involvement                                    G
247eval qq|Grandfather->_a|; $fail .= 'a' if $@;               #   1
248eval qq|Grandfather->_j|; $fail .= 'j' if $@;               #  null
249eval qq|Grandfather->_s|; $fail .= 's' unless $@; undef $@; #   0
250
251# Parent Child inheritence                                  G    F
252eval qq|Father->_a|; $fail .= 'a' if $@;                #   1    1
253eval qq|Father->_d|; $fail .= 'd' if $@;                #   1   null
254eval qq|Father->_g|; $fail .= 'g' if $@;                #   1    0
255eval qq|Father->_j|; $fail .= 'j' if $@;                #  null  1
256eval qq|Father->_m|; $fail .= 'm' if $@;                #  null null
257eval qq|Father->_p|; $fail .= 'p' unless $@; undef $@;  #  null  0
258eval qq|Father->_s|; $fail .= 's' if $@;                #   0    1
259eval qq|Father->_v|; $fail .= 'v' unless $@; undef $@;  #   0   null
260eval qq|Father->_y|; $fail .= 'y' unless $@; undef $@;  #   0    0
261
262# Grandparent Parent Child inheritence                      G    F    S
263eval qq|Son->_a|; $fail .= 'a' if $@;                   #   1    1    1
264eval qq|Son->_b|; $fail .= 'b' if $@;                   #   1    1   null
265eval qq|Son->_c|; $fail .= 'c' if $@;                   #   1    1    0
266eval qq|Son->_d|; $fail .= 'd' if $@;                   #   1   null  1
267eval qq|Son->_e|; $fail .= 'e' if $@;                   #   1   null null
268eval qq|Son->_f|; $fail .= 'f' if $@;                   #   1   null  0
269eval qq|Son->_g|; $fail .= 'g' if $@;                   #   1    0    1
270eval qq|Son->_h|; $fail .= 'h' if $@;                   #   1    0   null
271eval qq|Son->_i|; $fail .= 'i' if $@;                   #   1    0    0
272eval qq|Son->_j|; $fail .= 'j' if $@;                   #  null  1    1
273eval qq|Son->_k|; $fail .= 'k' if $@;                   #  null  1   null
274eval qq|Son->_l|; $fail .= 'l' if $@;                   #  null  1    0
275eval qq|Son->_m|; $fail .= 'm' if $@;                   #  null null  1
276eval qq|Son->_n|; $fail .= 'n' if $@;                   #  null null null
277eval qq|Son->_o|; $fail .= 'o' unless $@; undef $@;     #  null null  0
278eval qq|Son->_p|; $fail .= 'p' if $@;                   #  null  0    1
279eval qq|Son->_q|; $fail .= 'q' unless $@; undef $@;     #  null  0   null
280eval qq|Son->_r|; $fail .= 'r' unless $@; undef $@;     #  null  0    0
281eval qq|Son->_s|; $fail .= 's' if $@;                   #   0    1    1
282eval qq|Son->_t|; $fail .= 't' if $@;                   #   0    1   null
283eval qq|Son->_u|; $fail .= 'u' if $@;                   #   0    1    0
284eval qq|Son->_v|; $fail .= 'v' if $@;                   #   0   null  1
285eval qq|Son->_w|; $fail .= 'w' unless $@; undef $@;     #   0   null null
286eval qq|Son->_x|; $fail .= 'x' unless $@; undef $@;     #   0   null  0
287eval qq|Son->_y|; $fail .= 'y' if $@;                   #   0    0    1
288eval qq|Son->_z|; $fail .= 'z' unless $@; undef $@;     #   0    0   null
289eval qq|Son->_1|; $fail .= '1' unless $@; undef $@;     #   0    0    0
290print "fail: $fail\n"  if $fail;
291$fail;
292CODE
293
294::ok('desc'   => 'private inheritance stays private',
295     'expect' => qr/^Forget 'private'?/s,
296     'code'   => <<'CODE');
297package Private;
298use Class::Contract;
299contract {
300  private class method 'foo';
301    impl {1};
302};
303
304package Private::Still;
305use Class::Contract;
306contract {
307  inherits 'Private';
308  class method 'foo';
309    impl {1};
310};
311
312CODE
313
314__DATA__
315
316##ok('desc'   => 'ancestor class method derived as object method',
317#     'expect' => 1,
318#     'need'   => 'additional thought',
319#     'code'   => <<'CODE');
320#1
321#CODE
322
323# REQ:	Pre and post conditions for methods shall receive the same argument
324#       list as the implementation (Pre gets copy, Post identical)
325
326# ?:  Do attribute preconditions get argument list?
327
328# ?:  Are there limits as to where &old, &self, and &value can be called?
329
330# REQ:  Invariant, pre, and post conditions may be declared optional.
331
332# REQ:  Optional condition checking may be switched on or off using the
333#       &check method (see examples below).
334
335# REQ:  The implementation's return value shall be available in the
336#	method's post condition(s) through the subroutine &value,
337#       which returns a reference to a scalar or an array
338#	(depending on the calling context).
339
340# REQ:  &value shall also provide access to the value of an attribute within
341#	that attribute's pre and post conditions.
342
343# REQ:  The value of the object prior to a method shall be available in the
344#	post-conditions via the &old subroutine, which returns a copy
345#	of the object as it was prior to the method call.
346
347
348### Garrett's additions ###
349
350# REQ:  C<method> and C<ctor> shall croak if the naming clashes with the
351#       subroutines exported by Class::Contract
352
353# REQ:  It shall not be possible to redefine a Contract
354
355# REQ:  ctor plays nicely with Overload.pm
356
357# REQ:  &value plays nicely with Overload.pm
358