|
3
|
1 package Test::Object::Common;
|
|
|
2 use strict;
|
|
|
3 use warnings;
|
|
|
4
|
|
|
5 use base qw( IMPL::Test::Unit );
|
|
|
6 use IMPL::Test qw(test failed cmparray);
|
|
|
7
|
|
|
8 __PACKAGE__->PassThroughArgs;
|
|
|
9
|
|
|
10 {
|
|
|
11 package Foo;
|
|
|
12 use base qw(IMPL::Object);
|
|
|
13
|
|
|
14 sub CTOR {
|
|
|
15 my ($this,$refarg) = @_;
|
|
|
16 $$refarg = 1;
|
|
|
17 }
|
|
|
18
|
|
|
19 package Bar;
|
|
|
20 use base qw(Foo);
|
|
|
21
|
|
|
22 __PACKAGE__->PassThroughArgs;
|
|
|
23
|
|
|
24 sub CTOR {
|
|
|
25 my ($this,$ref,$array) = @_;
|
|
|
26
|
|
|
27 push @$array,__PACKAGE__;
|
|
|
28 }
|
|
|
29
|
|
|
30 package Baz;
|
|
|
31 use base qw(Bar);
|
|
|
32
|
|
|
33 our %CTOR = (
|
|
|
34 Bar => sub {
|
|
|
35 my $t;
|
|
|
36 (\$t,$_[0]);
|
|
|
37 }
|
|
|
38 );
|
|
|
39
|
|
|
40 sub CTOR {
|
|
|
41 my ($this,$array) = @_;
|
|
|
42 push @$array,__PACKAGE__;
|
|
|
43 }
|
|
|
44
|
|
|
45 package Zoo;
|
|
|
46 use base qw(Bar);
|
|
|
47
|
|
|
48 __PACKAGE__->PassThroughArgs;
|
|
|
49
|
|
|
50 sub CTOR {
|
|
|
51 my ($this,$ref,$array) = @_;
|
|
|
52
|
|
|
53 push @$array,__PACKAGE__;
|
|
|
54 };
|
|
|
55
|
|
|
56 package Complex;
|
|
|
57 use base qw(Baz Zoo);
|
|
|
58
|
|
|
59 our %CTOR = (
|
|
|
60 Baz => sub { @_ },
|
|
|
61 Zoo => sub {
|
|
|
62 my $t;
|
|
|
63 (\$t,$_[0]);
|
|
|
64 }
|
|
|
65 );
|
|
|
66
|
|
|
67 }
|
|
|
68
|
|
|
69 test Creation => sub {
|
|
|
70 my $flag = 0;
|
|
|
71
|
|
|
72 my $obj = new Foo(\$flag);
|
|
|
73
|
|
|
74 die new IMPL::Test::FailException("Object is undef") unless $obj;
|
|
|
75 die new IMPL::Test::FailException("Contructor doesn't run") unless $obj;
|
|
|
76 };
|
|
|
77
|
|
|
78 test SimpleInheritance => sub {
|
|
|
79 my $sequence = [];
|
|
|
80 my $flag = 0;
|
|
|
81 my $obj = new Bar(\$flag,$sequence);
|
|
|
82
|
|
|
83 failed "Object is undef" unless $obj;
|
|
|
84 failed "Base class constructor isn't called" unless $flag;
|
|
|
85 failed "Class constructor isn't called" unless @$sequence;
|
|
|
86 };
|
|
|
87
|
|
|
88 test SimpleInheritance2 => sub {
|
|
|
89 my $sequence = [];
|
|
|
90 my $expected = [qw(Bar Baz)];
|
|
|
91 my $obj = new Baz($sequence);
|
|
|
92
|
|
|
93 failed "Object is undef" unless $obj;
|
|
|
94 failed "Wrong constructor sequence","expected: " . join(', ',@$expected),"actual: ".join(', ',@$sequence) unless cmparray $sequence,$expected;
|
|
|
95 };
|
|
|
96
|
|
|
97 test MultipleInheritance => sub {
|
|
|
98 my $sequence = [];
|
|
|
99 my $expected = [qw(Bar Baz Bar Zoo)];
|
|
|
100 my $obj = new Complex($sequence);
|
|
|
101
|
|
|
102 failed "Object is undef" unless $obj;
|
|
|
103 failed "Wrong constructor sequence","expected: " . join(', ',@$expected),"actual: ".join(', ',@$sequence) unless cmparray $sequence,$expected;
|
|
|
104 };
|
|
|
105
|
|
|
106 1;
|
