Completed update of data ownership chaining
[perl-ctypes:shlomifs-perl-ctypes.git] / t / Struct.t
1 #!perl
2
3 use Test::More tests => 0;
4 use Ctypes;
5
6 use "ct_POINT.pm";
7 use "ct_RECT.pm";
8 use "ct_SQUARE.pm";   # isa RECT with extra restrictions & field 'foo'
9
10 my $point = ct_POINT(5, 15);
11 isa_ok( $point, qw|POINT Ctypes::Type::Struct|,
12         'point is a POINT and a Struct');
13
14 # From Python docs:
15
16 # _fields_
17 #   A sequence defining the structure fields. The items must be
18 #   2-tuples or 3-tuples. The first item is the name of the field,
19 #   the second item specifies the type of the field; it can be
20 #   any ctypes data type.
21
22 is( $point->_fields_, 
23     [ [ 'x', 'Ctypes::Type::Simple' ], [ 'y', 'Ctypes::Type::Simple' ] ],
24     '$st->_fields_ returns names and type names' );
25 is( $point->y, 15, '$st-><field> returns value' );
26 is( ct_POINT->x,
27     { name => x, type => 'l', size => 4, ofs => 0 },
28     'Class methods return field info' );
29
30 #   Integer type fields like c_int, a third optional item can be
31 #   given. It must be a small positive integer defining the bit
32 #   width of the field.
33
34 # TODO Don't know how to do this yet
35 # my $struct = Struct( [ 'field', c_int, 8 ] );
36
37 #   Field names must be unique within one structure or union. This
38 #   is not checked, only one field can be accessed when names are repeated.
39 ### Can check this for dynamically made Structs though:
40
41 my $struct = Struct( [ 'field', c_int ], [ 'field', c_long ] );
42 # Should carp a warning
43 is( $stuct, undef, 'Cannot have two fields with the same name' );
44
45 ### ??? What about sub-subclasses?
46 # Will be seen to be replacing the accessor for the ancestor class I guess
47
48 #   It is possible to define the _fields_ class variable after
49 #   the class statement that defines the Structure subclass,
50 #   this allows to create data types that directly or indirectly
51 #   reference themselves:
52 #      class List(Structure):
53 #          pass
54 #      List._fields_ = [("pnext", POINTER(List)),
55 #                        ...
56 #                      ]
57 #   The _fields_ class variable must, however, be defined before the
58 #   type is first used (an instance is created, sizeof() is called
59 #   on it, and so on). Later assignments to the _fields_ class variable
60 #   will raise an AttributeError.
61 ### ??? Does this apply to Perl?
62
63 package Flower;
64 our @ISA = 'Ctypes::Type::Struct';
65
66 package main;
67
68 my $flower = Flower( 'r', 20 );
69 is( $flower, undef, 'Cannot instantiate Struct class without fields' );
70
71 Flower::_fields_ = [['colour',c_char],['height',c_ushort]];
72 $flower = Flower( 'r', 20 );
73 isa_ok( $flower,
74         qw|Flower Ctypes::Type::Struct|,
75         'Flower Struct created after defining fields' );
76
77 #   Structure and union subclass constructors accept both positional
78 #   and named arguments. Positional arguments are used to initialize
79 #   the fields in the same order as they appear in the _fields_
80 #   definition, named arguments are used to initialize the fields with
81 #   the corresponding name or create new attributes for names not
82 #   present in _fields_.
83
84 my $flower2 = Flower( { height => 30, loveliness => 10 } );
85 isa_ok( $flower, qw|Flower Ctypes::Type::Struct|, 'flower2 created' );
86 is( $flower2->loveliness, 10, 'Create new attributes with named arguments' );
87
88 # What happens with too many positional args?
89 my $flower3 = undef;
90 eval { $flower3 = Flower( 'p', 8, 5 ); }
91 is( $flower3, undef, "Can't instantiate with too many args" );
92 like( $@, qr/too many arguments/i, 'Warned about extraneous args' );
93
94 #   It is possible to defined sub-subclasses of structure types, they
95 #   inherit the fields of the base class plus the _fields_ defined in
96 #   the sub-subclass, if any.
97
98 package Daffodil;
99 our @ISA = 'Flower';
100 our $_fields_ = [ ['trumpetsize', c_ushort ] ];
101
102 package main;
103
104 my $daffodil = Daffodil( 'y', 28, 15  );
105 is( $daffodil->trumpetsize, 15, "That's a respectable trumpet" );
106 is( $daffyfields->_fields_, 
107     [ { name => colour, type => 'c', size => 1, ofs => 0 },
108       { name => height, type => 'S', size => 2, ofs => 0 },
109       { name => trumpetsize, type => 'S', size => 2, ofs => 0 }, ]
110     '$st->_fields_ returns names and type names' );
111
112 #   It is possible to defined sub-subclasses of structures, they inherit
113 #   the fields of the base class. If the subclass definition has a
114 #   separate _fields_ variable, the fields specified in this are
115 #   appended to the fields of the base class.
116
117 # _pack_
118 #   An optional small integer that allows to override the alignment
119 #   of structure fields in the instance. _pack_ must already be defined
120 #   when _fields_ is assigned, otherwise it will have no effect.
121
122 ### Don't understand the following feature; not sure it applies to our
123 ### dynamic implementation:
124
125 # _anonymous_
126 #
127 #   An optional sequence that lists the names of unnamed (anonymou 
128 #   s) fields. _anonymous_ must be already defined when _fields_ is as
129 #   signed, otherwise it will have no effect.
130 #
131 #   The fields listed in this variable must be structure or union 
132 #   type fields. ctypes will create descriptors in the structure t
133 #   ype that allows to access the nested fields directly, without 
134 #   the need to create the structure or union field.
135 #
136 #   Here is an example type (Windows):
137 #
138 #   class _U(Union):
139 #       _fields_ = [("lptdesc", POINTER(TYPEDESC)),
140 #                   ("lpadesc", POINTER(ARRAYDESC)),
141 #                   ("hreftype", HREFTYPE)]
142 #
143 #   class TYPEDESC(Structure):
144 #       _anonymous_ = ("u",)
145 #       _fields_ = [("u", _U),
146 #                   ("vt", VARTYPE)]
147 #
148 #   The TYPEDESC structure describes a COM data type, the vt field
149 #   specifies which one of the union fields is valid. Since the u 
150 #   field is defined as anonymous field, it is now possible to acc
151 #   ess the members directly off the TYPEDESC instance. td.lptdesc
152 #   and td.u.lptdesc are equivalent, but the former is faster sin
153 #   ce it does not need to create a temporary union instance:
154 #
155 #   td = TYPEDESC()
156 #   td.vt = VT_PTR
157 #   td.lptdesc = POINTER(some_type)
158 #   td.u.lptdesc = POINTER(some_type)
159 #