Many changes
[perl-ctypes:shlomifs-perl-ctypes.git] / t / Struct.t
1 #!perl
2
3 BEGIN { unshift @INC, './t' }
4
5 use Test::More tests => 12;
6 use Ctypes;
7 use Data::Dumper;
8 my $Debug = 0;
9
10 use t_POINT;
11
12 my $point = new t_POINT(5, 15);
13
14 isa_ok( $point, 'Ctypes::Type::Struct', 't_POINT' );
15 my $struct;
16 eval { 
17   $struct
18     = Struct({ fields => [ [ 'field', c_int ], [ 'field', c_long ] ] });
19      };
20 like( $@, qr/defined more than once/,
21      'Cannot have two fields with the same name' );
22
23 # Getting
24 ok( $point->field_list->[0][0] eq 'x'
25   && $point->field_list->[1][1]->typecode eq 'i',
26   '$st->field_list returns names and type names' );
27  is( $$point->x, '5', '$st-><field> returns value' );
28  is( $$point->y, '15', '$st-><field> returns value' );
29
30 # Setting
31 $point->y->(20);
32 is( $$point->y, 20, '$st->field->(20) sets value' );
33 $struct = Struct({ fields => [ ['foo',c_int], ['bar',c_double] ] });
34 my $int = c_int(4);
35 $int->allow_overflow(0);
36 $struct->foo->($int);
37 eval{ $struct->foo->(20000000000000000000000000) };
38 is( $$struct->foo, 4, 'Simple types maintain attributes' );
39 $struct->foo->(7);
40 is( $$int, 7, 'Modify members without squashing' );
41
42 # {_data}
43 $struct->bar->(14);
44 my $data = pack('i',7) . pack('d',14);
45 is( ${$struct->data}, $data, '_data looks alright' );
46 my $twentyfive = pack('i',25);
47 my $dataref = $struct->data;
48 substr( ${$dataref}, 0, length($twentyfive) ) = $twentyfive;
49 is( $$int, 25, 'Data modifications percolate down' );
50
51 # Nesting is nice
52 subtest 'Arrays in structs' => sub {
53   plan tests => 1;
54
55   my $grades = Array( 49, 80, 55, 75, 89, 31, 45, 65, 40, 71 );
56   my $class = Struct({ fields => [
57     [ teacher => 'P' ],
58     [ grades  => $grades ],
59   ] });
60
61   my $total;
62   for( @{$$class->grades} ) { $total += $_ };
63   my $average = $total /  scalar @{$$class->grades};
64   is( $average, 60, "Mr Peterson's could do better" );
65 };
66
67 subtest 'Structs in structs' => sub {
68   plan tests => 5;
69   
70   my $flowerbed = Struct({ fields => [
71     [ roses => 3 ],
72     [ heather => 5 ],
73     [ weeds => 2 ],
74   ] });
75   
76   my $garden = Struct({ fields => [
77     [ fence => 30 ],
78     [ flowerbed => $flowerbed ],
79     [ lawn => 20 ],
80   ] });
81   
82   #print '$garden->flowerbed: ',$garden->flowerbed, "\n";
83   #print '$$garden->flowerbed: ', $$garden->flowerbed, "\n\n";
84   
85   #print '$garden->flowerbed->contents: ',$garden->flowerbed->contents, "\n";
86   #print '$$garden->flowerbed->contents: ',$$garden->flowerbed->contents, "\n\n";
87   
88   #print '$garden->flowerbed->roses: ',$garden->flowerbed->roses, "\n";
89   #print '$$garden->flowerbed->roses: ',$$garden->flowerbed->roses, "\n\n";
90   
91   #print '$garden->flowerbed->contents->roses: ',$garden->flowerbed->contents->roses, "\n";
92   #print '$$garden->flowerbed->contents->roses: ', $$garden->flowerbed->contents->roses, "\n\n";
93   
94   is( $garden->flowerbed->contents->roses,
95       '<Field type=c_short, ofs=0, size=2>',
96       '$garden->flowerbed->contents->roses gives field (how nice...)' );
97   is( $$garden->flowerbed->contents->roses,
98       '3','$$garden->flowerbed->contents->roses gives 3' );
99   
100   my $home = Struct({ fields => [
101     [ house => 40 ],
102     [ driveway => 20 ],
103     [ garden => $garden ],
104   ] });
105   
106   # print $home->garden->contents->flowerbed->contents->heather, "\n";
107   # print $$home->garden->contents->flowerbed->contents->heather, "\n";
108   
109   is( $home->garden->contents->flowerbed->contents->heather,
110       '<Field type=c_short, ofs=2, size=2>',
111       '$home->garden->contents->flowerbed->contents->heather gives field' );
112   is( $$home->garden->contents->flowerbed->contents->heather,
113       '5', '$$home->garden->contents->flowerbed->contents->heather gives 5' );
114   $home->garden->contents->flowerbed->contents->heather->(500);
115   is( $$garden->heather, 500, "That's a quare load o' heather - garden updated via \$home" );
116 };
117