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