r5672: Use switch_type() and the token storage mechanism for unions:
[samba.git] / source4 / build / pidl / validator.pm
1 ###################################################
2 # check that a parsed IDL file is valid
3 # Copyright tridge@samba.org 2003
4 # released under the GNU GPL
5
6 package IdlValidator;
7 use Data::Dumper;
8
9 use strict;
10
11 #####################################################################
12 # signal a fatal validation error
13 sub fatal($)
14 {
15         my $s = shift;
16         print "$s\n";
17         die "IDL is not valid\n";
18 }
19
20 sub el_name($)
21 {
22         my $e = shift;
23
24         if ($e->{PARENT} && $e->{PARENT}->{NAME}) {
25                 return "$e->{PARENT}->{NAME}.$e->{NAME}";
26         }
27
28         if ($e->{PARENT} && $e->{PARENT}->{PARENT}->{NAME}) {
29                 return "$e->{PARENT}->{PARENT}->{NAME}.$e->{NAME}";
30         }
31
32         if ($e->{PARENT}) {
33                 return "$e->{PARENT}->{NAME}.$e->{NAME}";
34         }
35         return $e->{NAME};
36 }
37
38 #####################################################################
39 # parse a struct
40 sub ValidElement($)
41 {
42         my $e = shift;
43         
44         if (util::has_property($e, "ptr")) {
45                 fatal(el_name($e) . " : pidl does not support full NDR pointers yet\n");
46         }
47
48         # Check whether switches are used correctly.
49         if (my $switch = util::has_property($e, "switch_is")) {
50                 my $e2 = util::find_sibling($e, $switch);
51                 my $type = typelist::getType($e->{TYPE});
52
53                 if (defined($type) and $type->{DATA}->{TYPE} ne "UNION") {
54                         fatal(el_name($e) . ": switch_is() used on non-union type $e->{TYPE} which is a $type->{DATA}->{TYPE}");
55                 }
56
57                 if (!util::has_property($type, "nodiscriminant") and defined($e2)) {
58                         my $discriminator_type = util::has_property($type, "switch_type");
59                         $discriminator_type = "uint32" unless defined ($discriminator_type);
60
61                         if ($e2->{TYPE} ne $discriminator_type) {
62                                 print el_name($e) . ": Warning: switch_is() is of type $e2->{TYPE}, while discriminator type for union $type->{NAME} is $discriminator_type\n";
63                         }
64                 }
65         }
66
67         if (util::has_property($e, "size_is") and not defined ($e->{ARRAY_LEN})) {
68                 fatal(el_name($e) . " : size_is() on non-array element");
69         }
70
71         if (util::has_property($e, "length_is") and not defined ($e->{ARRAY_LEN})) {
72                 fatal(el_name($e) . " : length_is() on non-array element");
73         }
74
75         if (!$e->{POINTERS} && (
76                 util::has_property($e, "ptr") or
77                 util::has_property($e, "unique") or
78                 util::has_property($e, "relative") or
79                 util::has_property($e, "ref"))) {
80                 fatal(el_name($e) . " : pointer properties on non-pointer element\n");  
81         }
82 }
83
84 #####################################################################
85 # parse a struct
86 sub ValidStruct($)
87 {
88         my($struct) = shift;
89
90         foreach my $e (@{$struct->{ELEMENTS}}) {
91                 if (util::has_property($e, "ref")) {
92                         fatal(el_name($e) . " : embedded ref pointers are not supported yet\n");
93                 }
94         
95                 $e->{PARENT} = $struct;
96                 ValidElement($e);
97         }
98 }
99
100 #####################################################################
101 # parse a union
102 sub ValidUnion($)
103 {
104         my($union) = shift;
105
106         if (util::has_property($union->{PARENT}, "nodiscriminant") and util::has_property($union->{PARENT}, "switch_type")) {
107                 fatal($union->{PARENT}->{NAME} . ": switch_type() on union without discriminant");
108         }
109         
110         foreach my $e (@{$union->{ELEMENTS}}) {
111                 $e->{PARENT} = $union;
112
113                 if (defined($e->{PROPERTIES}->{default}) and 
114                         defined($e->{PROPERTIES}->{case})) {
115                         fatal "Union member $e->{NAME} can not have both default and case properties!\n";
116                 }
117                 
118                 unless (defined ($e->{PROPERTIES}->{default}) or 
119                                 defined ($e->{PROPERTIES}->{case})) {
120                         fatal "Union member $e->{NAME} must have default or case property\n";
121                 }
122
123                 if (util::has_property($e, "ref")) {
124                         fatal(el_name($e) . " : embedded ref pointers are not supported yet\n");
125                 }
126
127
128                 ValidElement($e);
129         }
130 }
131
132 #####################################################################
133 # parse a typedef
134 sub ValidTypedef($)
135 {
136         my($typedef) = shift;
137         my $data = $typedef->{DATA};
138
139         $data->{PARENT} = $typedef;
140
141         if (ref($data) eq "HASH") {
142                 if ($data->{TYPE} eq "STRUCT") {
143                         ValidStruct($data);
144                 }
145
146                 if ($data->{TYPE} eq "UNION") {
147                         ValidUnion($data);
148                 }
149         }
150 }
151
152 #####################################################################
153 # parse a function
154 sub ValidFunction($)
155 {
156         my($fn) = shift;
157
158         foreach my $e (@{$fn->{ELEMENTS}}) {
159                 $e->{PARENT} = $fn;
160                 if (util::has_property($e, "ref") && !$e->{POINTERS}) {
161                         fatal "[ref] variables must be pointers ($fn->{NAME}/$e->{NAME})\n";
162                 }
163                 ValidElement($e);
164         }
165 }
166
167 #####################################################################
168 # parse the interface definitions
169 sub ValidInterface($)
170 {
171         my($interface) = shift;
172         my($data) = $interface->{DATA};
173
174         if (util::has_property($interface, "pointer_default") && 
175                 $interface->{PROPERTIES}->{pointer_default} eq "ptr") {
176                 fatal "Full pointers are not supported yet\n";
177         }
178
179         if (util::has_property($interface, "object")) {
180         if(util::has_property($interface, "version") && 
181                         $interface->{PROPERTIES}->{version} != 0) {
182                         fatal "Object interfaces must have version 0.0 ($interface->{NAME})\n";
183                 }
184
185                 if(!defined($interface->{BASE}) && 
186                         not ($interface->{NAME} eq "IUnknown")) {
187                         fatal "Object interfaces must all derive from IUnknown ($interface->{NAME})\n";
188                 }
189         }
190                 
191         foreach my $d (@{$data}) {
192                 ($d->{TYPE} eq "TYPEDEF") &&
193                     ValidTypedef($d);
194                 ($d->{TYPE} eq "FUNCTION") && 
195                     ValidFunction($d);
196         }
197
198 }
199
200 #####################################################################
201 # parse a parsed IDL into a C header
202 sub Validate($)
203 {
204         my($idl) = shift;
205
206         foreach my $x (@{$idl}) {
207                 ($x->{TYPE} eq "INTERFACE") && 
208                     ValidInterface($x);
209         }
210 }
211
212 1;