Struct indirection working
[perl-ctypes:perl-ctypes.git] / t / Struct.t
1 #!perl
2
3 BEGIN { unshift @INC, './t' }
4
5 use Test::More tests => 5;
6 use Ctypes;
7 use Data::Dumper;
8 use attributes;
9 my $Debug = 0;
10
11 use t_POINT;
12
13 my $point = new t_POINT(5, 15);
14 isa_ok( $point, qw|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 ok( $point->field_list->[0][0] eq 'x'
24   && $point->field_list->[1][1]->type eq 'i',
25   '$st->_fields_ returns names and type names' );
26  is( $$point->x, '5', '$st-><field> returns value' );
27  is( $$point->y, '15', '$st-><field> returns value' );
28 $point->y->(20);
29 is( $$point->y, 20, '$st->field->(20) sets value' );
30 $struct = Struct({ fields => [ ['foo',c_int], ['bar',c_double] ] });
31 my $int = c_int(4);
32 $int->allow_overflow(0);
33 $struct->foo->($int);
34 eval{ $struct->foo->(20000000000000000000000000) };
35 is( $$struct->foo, 4, 'Simple types maintain attributes' );
36 $struct->foo->(7);
37 is( $$int, 7, 'Modify members without squashing' );
38
39 $struct->bar->(14);
40 my $data = pack('i',7) . pack('d',14);
41 is( ${$struct->_data}, $data, '_data looks alright' );
42 my $twentyfive = pack('i',25);
43 my $dataref = $struct->_data;
44 substr( ${$dataref}, 0, length($twentyfive) ) = $twentyfive;
45 is( $$int, 25, 'Data modifications percolate down' );
46
47 subtest 'Multiple indirection' => sub {
48   plan tests => 5;
49   
50   my $flowerbed = Struct({ fields => [
51     [ roses => 3 ],
52     [ heather => 5 ],
53     [ weeds => 2 ],
54   ] });
55   
56   my $garden = Struct({ fields => [
57     [ fence => 30 ],
58     [ flowerbed => $flowerbed ],
59     [ lawn => 20 ],
60   ] });
61   
62   #print '$garden->flowerbed: ',$garden->flowerbed, "\n";
63   #print '$$garden->flowerbed: ', $$garden->flowerbed, "\n\n";
64   
65   #print '$garden->flowerbed->contents: ',$garden->flowerbed->contents, "\n";
66   #print '$$garden->flowerbed->contents: ',$$garden->flowerbed->contents, "\n\n";
67   
68   #print '$garden->flowerbed->roses: ',$garden->flowerbed->roses, "\n";
69   #print '$$garden->flowerbed->roses: ',$$garden->flowerbed->roses, "\n\n";
70   
71   #print '$garden->flowerbed->contents->roses: ',$garden->flowerbed->contents->roses, "\n";
72   #print '$$garden->flowerbed->contents->roses: ', $$garden->flowerbed->contents->roses, "\n\n";
73   
74   is( $garden->flowerbed->contents->roses,
75       '<Field type=c_short, ofs=0, size=2>',
76       '$st->field->contents->x gives field' );
77   is( $$garden->flowerbed->contents->roses,
78       '3','$$st->field->contents->x gives value' );
79   
80   my $home = Struct({ fields => [
81     [ house => 40 ],
82     [ driveway => 20 ],
83     [ garden => $garden ],
84   ] });
85   
86   # print $home->garden->contents->flowerbed->contents->heather, "\n";
87   # print $$home->garden->contents->flowerbed->contents->heather, "\n";
88   
89   is( $home->garden->contents->flowerbed->contents->heather,
90       '<Field type=c_short, ofs=2, size=2>',
91       '$st->field->contents->x gives field' );
92   is( $$home->garden->contents->flowerbed->contents->heather,
93       '5', '$$st->field->contents->x gives value' );
94   $home->garden->contents->flowerbed->contents->heather->(500);
95   is( $$garden->heather, 500, "That's a quare load o' heather" );
96 };
97