c61c89392b6e3da4822fd9ffee70ce51bac4c35b
[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         if ($e->{POINTERS} && $e->{POINTERS} > 1) {
44                 fatal(el_name($e) . " : pidl cannot handle multiple pointer levels. Use a sub-structure containing a pointer instead\n");
45         }
46
47         if ($e->{POINTERS} && $e->{ARRAY_LEN}) {
48                 fatal(el_name($e) . " : pidl cannot handle pointers to arrays. Use a substructure instead\n");
49         }
50         
51         if (util::has_property($e, "ptr")) {
52                 fatal(el_name($e) . " : pidl does not support full NDR pointers yet\n");
53         }
54         
55         if (!$e->{POINTERS} && (
56                 util::has_property($e, "ptr") or
57                 util::has_property($e, "unique") or
58                 util::has_property($e, "relative") or
59                 util::has_property($e, "ref"))) {
60                 fatal(el_name($e) . " : pointer properties on non-pointer element\n");  
61         }
62 }
63
64 #####################################################################
65 # parse a struct
66 sub ValidStruct($)
67 {
68         my($struct) = shift;
69
70         foreach my $e (@{$struct->{ELEMENTS}}) {
71                 if (util::has_property($e, "ref")) {
72                         fatal(el_name($e) . " : embedded ref pointers are not supported yet\n");
73                 }
74         
75                 $e->{PARENT} = $struct;
76                 ValidElement($e);
77         }
78 }
79
80 #####################################################################
81 # parse a union
82 sub ValidUnion($)
83 {
84         my($union) = shift;
85         foreach my $e (@{$union->{ELEMENTS}}) {
86                 $e->{PARENT} = $union;
87
88                 if (defined($e->{PROPERTIES}->{default}) and 
89                         defined($e->{PROPERTIES}->{case})) {
90                         fatal "Union member $e->{NAME} can not have both default and case properties!\n";
91                 }
92                 
93                 unless (defined ($e->{PROPERTIES}->{default}) or 
94                                 defined ($e->{PROPERTIES}->{case})) {
95                         fatal "Union member $e->{NAME} must have default or case property\n";
96                 }
97
98                 if (util::has_property($e, "ref")) {
99                         fatal(el_name($e) . " : embedded ref pointers are not supported yet\n");
100                 }
101
102
103                 ValidElement($e);
104         }
105 }
106
107 #####################################################################
108 # parse a typedef
109 sub ValidTypedef($)
110 {
111         my($typedef) = shift;
112         my $data = $typedef->{DATA};
113
114         $data->{PARENT} = $typedef;
115
116         if (ref($data) eq "HASH") {
117                 if ($data->{TYPE} eq "STRUCT") {
118                         ValidStruct($data);
119                 }
120
121                 if ($data->{TYPE} eq "UNION") {
122                         ValidUnion($data);
123                 }
124         }
125 }
126
127 #####################################################################
128 # parse a function
129 sub ValidFunction($)
130 {
131         my($fn) = shift;
132
133         foreach my $e (@{$fn->{ELEMENTS}}) {
134                 $e->{PARENT} = $fn;
135                 if (util::has_property($e, "ref") && !$e->{POINTERS}) {
136                         fatal "[ref] variables must be pointers ($fn->{NAME}/$e->{NAME})\n";
137                 }
138                 ValidElement($e);
139         }
140 }
141
142 #####################################################################
143 # parse the interface definitions
144 sub ValidInterface($)
145 {
146         my($interface) = shift;
147         my($data) = $interface->{DATA};
148
149         if (util::has_property($interface, "pointer_default") && 
150                 $interface->{PROPERTIES}->{pointer_default} eq "ptr") {
151                 fatal "Full pointers are not supported yet\n";
152         }
153
154         if (util::has_property($interface, "object")) {
155         if(util::has_property($interface, "version") && 
156                         $interface->{PROPERTIES}->{version} != 0) {
157                         fatal "Object interfaces must have version 0.0 ($interface->{NAME})\n";
158                 }
159
160                 if(!defined($interface->{BASE}) && 
161                         not ($interface->{NAME} eq "IUnknown")) {
162                         fatal "Object interfaces must all derive from IUnknown ($interface->{NAME})\n";
163                 }
164         }
165                 
166         foreach my $d (@{$data}) {
167                 ($d->{TYPE} eq "TYPEDEF") &&
168                     ValidTypedef($d);
169                 ($d->{TYPE} eq "FUNCTION") && 
170                     ValidFunction($d);
171         }
172
173 }
174
175 #####################################################################
176 # parse a parsed IDL into a C header
177 sub Validate($)
178 {
179         my($idl) = shift;
180
181         foreach my $x (@{$idl}) {
182                 ($x->{TYPE} eq "INTERFACE") && 
183                     ValidInterface($x);
184         }
185 }
186
187 1;