r7122: Some cleanups, simplification of the code.
[samba.git] / source / 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 $pos = shift;
16         my $s = shift;
17         die("$pos->{FILE}:$pos->{LINE}:$s\n");
18 }
19
20 sub nonfatal($$)
21 {
22         my $pos = shift;
23         my $s = shift;
24         warn ("$pos->{FILE}:$pos->{LINE}:warning:$s\n");
25 }
26
27 sub el_name($)
28 {
29         my $e = shift;
30
31         if ($e->{PARENT} && $e->{PARENT}->{NAME}) {
32                 return "$e->{PARENT}->{NAME}.$e->{NAME}";
33         }
34
35         if ($e->{PARENT} && $e->{PARENT}->{PARENT}->{NAME}) {
36                 return "$e->{PARENT}->{PARENT}->{NAME}.$e->{NAME}";
37         }
38
39         if ($e->{PARENT}) {
40                 return "$e->{PARENT}->{NAME}.$e->{NAME}";
41         }
42         return $e->{NAME};
43 }
44
45 ###################################
46 # find a sibling var in a structure
47 sub find_sibling($$)
48 {
49         my($e) = shift;
50         my($name) = shift;
51         my($fn) = $e->{PARENT};
52
53         if ($name =~ /\*(.*)/) {
54                 $name = $1;
55         }
56
57         for my $e2 (@{$fn->{ELEMENTS}}) {
58                 return $e2 if ($e2->{NAME} eq $name);
59         }
60
61         return undef;
62 }
63
64
65 my %property_list = (
66         # interface
67         "helpstring" => ["INTERFACE", "FUNCTION"],
68         "version" => ["INTERFACE"],
69         "uuid" => ["INTERFACE"],
70         "endpoint" => ["INTERFACE"],
71         "pointer_default" => ["INTERFACE"],
72         "pointer_default_top" => ["INTERFACE"],
73         "depends" => ["INTERFACE"],
74         "authservice" => ["INTERFACE"],
75
76         # dcom
77         "object" => ["INTERFACE"],
78         "local"  => ["INTERFACE", "FUNCTION"],
79         "iid_is" => ["ELEMENT"],
80         "call_as" => ["FUNCTION"],
81         "idempotent" => ["FUNCTION"],
82
83         # function
84         "noopnum" => ["FUNCTION"],
85         "in" => ["ELEMENT"],
86         "out" => ["ELEMENT"],
87
88         # pointer
89         "ref" => ["ELEMENT"],
90         "ptr" => ["ELEMENT"],
91         "unique" => ["ELEMENT"],
92         "relative" => ["ELEMENT"],
93
94         "gensize"       => ["TYPEDEF"],
95         "value"         => ["ELEMENT"],
96         "flag"          => ["ELEMENT", "TYPEDEF"],
97
98         # generic
99         "public"        => ["FUNCTION", "TYPEDEF"],
100         "nopush"        => ["FUNCTION", "TYPEDEF"],
101         "nopull"        => ["FUNCTION", "TYPEDEF"],
102         "noprint"       => ["FUNCTION", "TYPEDEF"],
103
104         # union
105         "switch_is"      => ["ELEMENT"],
106         "switch_type"   => ["ELEMENT", "TYPEDEF"],
107         "nodiscriminant" => ["TYPEDEF"],
108         "case"                  => ["ELEMENT"],
109         "default"               => ["ELEMENT"],
110
111         # subcontext
112         "subcontext" => ["ELEMENT"],
113         "subcontext_size"       => ["ELEMENT"],
114         "compression"           => ["ELEMENT"],
115         "obfuscation"           => ["ELEMENT"],
116
117         # enum
118         "enum8bit"              => ["TYPEDEF"],
119         "enum16bit"             => ["TYPEDEF"],
120         "v1_enum"               => ["TYPEDEF"],
121
122         # bitmap
123         "bitmap8bit"    => ["TYPEDEF"],
124         "bitmap16bit"   => ["TYPEDEF"],
125         "bitmap32bit"   => ["TYPEDEF"],
126         "bitmap64bit"   => ["TYPEDEF"],
127
128         # array
129         "range"                 => ["ELEMENT"],
130         "size_is"               => ["ELEMENT"],
131         "length_is"             => ["ELEMENT"],
132 );
133
134 #####################################################################
135 # check for unknown properties
136 sub ValidProperties($$)
137 {
138         my $e = shift;
139         my $t = shift;
140
141         return unless defined $e->{PROPERTIES};
142
143         foreach my $key (keys %{$e->{PROPERTIES}}) {
144                 fatal($e, el_name($e) . ": unknown property '$key'\n")
145                         unless defined($property_list{$key});
146
147                 fatal($e, el_name($e) . ": property '$key' not allowed on '$t'\n")
148                         unless grep($t, @{$property_list{$key}});
149         }
150 }
151
152 #####################################################################
153 # parse a struct
154 sub ValidElement($)
155 {
156         my $e = shift;
157
158         ValidProperties($e,"ELEMENT");
159
160         if (util::has_property($e, "ptr")) {
161                 fatal($e, el_name($e) . " : pidl does not support full NDR pointers yet\n");
162         }
163
164         # Check whether switches are used correctly.
165         if (my $switch = util::has_property($e, "switch_is")) {
166                 my $e2 = find_sibling($e, $switch);
167                 my $type = typelist::getType($e->{TYPE});
168
169                 if (defined($type) and $type->{DATA}->{TYPE} ne "UNION") {
170                         fatal($e, el_name($e) . ": switch_is() used on non-union type $e->{TYPE} which is a $type->{DATA}->{TYPE}");
171                 }
172
173                 if (!util::has_property($type, "nodiscriminant") and defined($e2)) {
174                         my $discriminator_type = util::has_property($type, "switch_type");
175                         $discriminator_type = "uint32" unless defined ($discriminator_type);
176
177                         if ($e2->{TYPE} ne $discriminator_type) {
178                                 print el_name($e) . ": Warning: switch_is() is of type $e2->{TYPE}, while discriminator type for union $type->{NAME} is $discriminator_type\n";
179                         }
180                 }
181         }
182
183         if (defined (util::has_property($e, "subcontext_size")) and not defined(util::has_property($e, "subcontext"))) {
184                 fatal($e, el_name($e) . " : subcontext_size() on non-subcontext element");
185         }
186
187         if (defined (util::has_property($e, "compression")) and not defined(util::has_property($e, "subcontext"))) {
188                 fatal($e, el_name($e) . " : compression() on non-subcontext element");
189         }
190
191         if (defined (util::has_property($e, "obfuscation")) and not defined(util::has_property($e, "subcontext"))) {
192                 fatal($e, el_name($e) . " : obfuscation() on non-subcontext element");
193         }
194
195         if (!$e->{POINTERS} && (
196                 util::has_property($e, "ptr") or
197                 util::has_property($e, "unique") or
198                 util::has_property($e, "relative") or
199                 util::has_property($e, "ref"))) {
200                 fatal($e, el_name($e) . " : pointer properties on non-pointer element\n");      
201         }
202 }
203
204 #####################################################################
205 # parse a struct
206 sub ValidStruct($)
207 {
208         my($struct) = shift;
209
210         ValidProperties($struct,"STRUCT");
211
212         foreach my $e (@{$struct->{ELEMENTS}}) {
213                 $e->{PARENT} = $struct;
214                 ValidElement($e);
215         }
216 }
217
218 #####################################################################
219 # parse a union
220 sub ValidUnion($)
221 {
222         my($union) = shift;
223
224         ValidProperties($union,"UNION");
225
226         if (util::has_property($union->{PARENT}, "nodiscriminant") and util::has_property($union->{PARENT}, "switch_type")) {
227                 fatal($union->{PARENT}, $union->{PARENT}->{NAME} . ": switch_type() on union without discriminant");
228         }
229         
230         foreach my $e (@{$union->{ELEMENTS}}) {
231                 $e->{PARENT} = $union;
232
233                 if (defined($e->{PROPERTIES}->{default}) and 
234                         defined($e->{PROPERTIES}->{case})) {
235                         fatal $e, "Union member $e->{NAME} can not have both default and case properties!\n";
236                 }
237                 
238                 unless (defined ($e->{PROPERTIES}->{default}) or 
239                                 defined ($e->{PROPERTIES}->{case})) {
240                         fatal $e, "Union member $e->{NAME} must have default or case property\n";
241                 }
242
243                 if (util::has_property($e, "ref")) {
244                         fatal($e, el_name($e) . " : embedded ref pointers are not supported yet\n");
245                 }
246
247
248                 ValidElement($e);
249         }
250 }
251
252 #####################################################################
253 # parse a typedef
254 sub ValidTypedef($)
255 {
256         my($typedef) = shift;
257         my $data = $typedef->{DATA};
258
259         ValidProperties($typedef,"TYPEDEF");
260
261         $data->{PARENT} = $typedef;
262
263         if (ref($data) eq "HASH") {
264                 if ($data->{TYPE} eq "STRUCT") {
265                         ValidStruct($data);
266                 }
267
268                 if ($data->{TYPE} eq "UNION") {
269                         ValidUnion($data);
270                 }
271         }
272 }
273
274 #####################################################################
275 # parse a function
276 sub ValidFunction($)
277 {
278         my($fn) = shift;
279
280         ValidProperties($fn,"FUNCTION");
281
282         foreach my $e (@{$fn->{ELEMENTS}}) {
283                 $e->{PARENT} = $fn;
284                 if (util::has_property($e, "ref") && !$e->{POINTERS}) {
285                         fatal $e, "[ref] variables must be pointers ($fn->{NAME}/$e->{NAME})\n";
286                 }
287                 ValidElement($e);
288         }
289 }
290
291 #####################################################################
292 # parse the interface definitions
293 sub ValidInterface($)
294 {
295         my($interface) = shift;
296         my($data) = $interface->{DATA};
297
298         ValidProperties($interface,"INTERFACE");
299
300         if (util::has_property($interface, "pointer_default") && 
301                 $interface->{PROPERTIES}->{pointer_default} eq "ptr") {
302                 fatal $interface, "Full pointers are not supported yet\n";
303         }
304
305         if (util::has_property($interface, "object")) {
306                 if (util::has_property($interface, "version") && 
307                         $interface->{PROPERTIES}->{version} != 0) {
308                         fatal $interface, "Object interfaces must have version 0.0 ($interface->{NAME})\n";
309                 }
310
311                 if (!defined($interface->{BASE}) && 
312                         not ($interface->{NAME} eq "IUnknown")) {
313                         fatal $interface, "Object interfaces must all derive from IUnknown ($interface->{NAME})\n";
314                 }
315         }
316                 
317         foreach my $d (@{$data}) {
318                 ($d->{TYPE} eq "TYPEDEF") &&
319                     ValidTypedef($d);
320                 ($d->{TYPE} eq "FUNCTION") && 
321                     ValidFunction($d);
322         }
323
324 }
325
326 #####################################################################
327 # parse a parsed IDL into a C header
328 sub Validate($)
329 {
330         my($idl) = shift;
331
332         foreach my $x (@{$idl}) {
333                 ($x->{TYPE} eq "INTERFACE") && 
334                     ValidInterface($x);
335         }
336 }
337
338 1;