pidl: add support for 'pipe' at the NDR layer
[kai/samba.git] / pidl / lib / Parse / Pidl / Typelist.pm
1 ###################################################
2 # Samba4 parser generator for IDL structures
3 # Copyright jelmer@samba.org 2005
4 # released under the GNU GPL
5
6 package Parse::Pidl::Typelist;
7
8 require Exporter;
9 @ISA = qw(Exporter);
10 @EXPORT_OK = qw(hasType getType resolveType mapTypeName scalar_is_reference expandAlias
11         mapScalarType addType typeIs is_signed is_scalar enum_type_fn
12         bitmap_type_fn mapType typeHasBody is_fixed_size_scalar
13 );
14 use vars qw($VERSION);
15 $VERSION = '0.01';
16
17 use Parse::Pidl::Util qw(has_property);
18 use strict;
19
20 my %types = ();
21
22 my @reference_scalars = (
23         "string", "string_array", "nbt_string", "dns_string",
24         "wrepl_nbt_name", "dnsp_name", "dnsp_string",
25         "ipv4address", "ipv6address"
26 );
27
28 my @non_fixed_size_scalars = (
29         "string", "string_array", "nbt_string", "dns_string",
30         "wrepl_nbt_name", "dnsp_name", "dnsp_string"
31 );
32
33 # a list of known scalar types
34 my %scalars = (
35         "void"          => "void",
36         "char"          => "char",
37         "int8"          => "int8_t",
38         "uint8"         => "uint8_t",
39         "int16"         => "int16_t",
40         "uint16"        => "uint16_t",
41         "int1632"       => "int16_t",
42         "uint1632"      => "uint16_t",
43         "int32"         => "int32_t",
44         "uint32"        => "uint32_t",
45         "int3264"       => "int32_t",
46         "uint3264"      => "uint32_t",
47         "hyper"         => "uint64_t",
48         "dlong"         => "int64_t",
49         "udlong"        => "uint64_t",
50         "udlongr"       => "uint64_t",
51         "double"        => "double",
52         "pointer"       => "void*",
53         "DATA_BLOB"     => "DATA_BLOB",
54         "string"        => "const char *",
55         "string_array"  => "const char **",
56         "time_t"        => "time_t",
57         "uid_t"         => "uid_t",
58         "gid_t"         => "gid_t",
59         "NTTIME"        => "NTTIME",
60         "NTTIME_1sec"   => "NTTIME",
61         "NTTIME_hyper"  => "NTTIME",
62         "WERROR"        => "WERROR",
63         "NTSTATUS"      => "NTSTATUS",
64         "COMRESULT" => "COMRESULT",
65         "dns_string"    => "const char *",
66         "nbt_string"    => "const char *",
67         "wrepl_nbt_name"=> "struct nbt_name *",
68         "ipv4address"   => "const char *",
69         "ipv6address"   => "const char *",
70         "dnsp_name"     => "const char *",
71         "dnsp_string"   => "const char *",
72 );
73
74 my %aliases = (
75         "error_status_t" => "uint32",
76         "boolean8" => "uint8",
77         "boolean32" => "uint32",
78         "DWORD" => "uint32",
79         "uint" => "uint32",
80         "int" => "int32",
81         "WORD" => "uint16",
82         "char" => "uint8",
83         "long" => "int32",
84         "short" => "int16",
85         "HYPER_T" => "hyper",
86         "HRESULT" => "COMRESULT",
87 );
88
89 sub expandAlias($)
90 {
91         my $name = shift;
92
93         return $aliases{$name} if defined($aliases{$name});
94
95         return $name;
96 }
97
98 # map from a IDL type to a C header type
99 sub mapScalarType($)
100 {
101         my $name = shift;
102
103         # it's a bug when a type is not in the list
104         # of known scalars or has no mapping
105         return $scalars{$name} if defined($scalars{$name});
106
107         die("Unknown scalar type $name");
108 }
109
110 sub addType($)
111 {
112         my $t = shift;
113         $types{$t->{NAME}} = $t;
114 }
115
116 sub resolveType($)
117 {
118         my ($ctype) = @_;
119
120         if (not hasType($ctype)) {
121                 # assume struct typedef
122                 return { TYPE => "TYPEDEF", NAME => $ctype, DATA => { TYPE => "STRUCT" } };
123         } else {
124                 return getType($ctype);
125         }
126
127         return $ctype;
128 }
129
130 sub getType($)
131 {
132         my $t = shift;
133         return ($t) if (ref($t) eq "HASH" and not defined($t->{NAME}));
134         return undef if not hasType($t);
135         return $types{$t->{NAME}} if (ref($t) eq "HASH");
136         return $types{$t};
137 }
138
139 sub typeIs($$);
140 sub typeIs($$)
141 {
142         my ($t,$tt) = @_;
143
144         if (ref($t) eq "HASH") {
145                 return 1 if ($t->{TYPE} eq "TYPEDEF" and $t->{DATA}->{TYPE} eq $tt);
146                 return 1 if ($t->{TYPE} eq $tt);
147                 return 0;
148         }
149         if (hasType($t) and getType($t)->{TYPE} eq "TYPEDEF") {
150                 return typeIs(getType($t)->{DATA}, $tt);
151          }
152         return 0;
153 }
154
155 sub hasType($)
156 {
157         my $t = shift;
158         if (ref($t) eq "HASH") {
159                 return 1 if (not defined($t->{NAME}));
160                 return 1 if (defined($types{$t->{NAME}}) and 
161                         $types{$t->{NAME}}->{TYPE} eq $t->{TYPE});
162                 return 0;
163         }
164         return 1 if defined($types{$t});
165         return 0;
166 }
167
168 sub is_signed($)
169 {
170     my $t = shift;
171
172     return ($t eq "int8"
173             or $t eq "int16"
174             or $t eq "int32"
175             or $t eq "dlong"
176             or $t eq "int"
177             or $t eq "long"
178             or $t eq "short");
179 }
180
181 sub is_scalar($)
182 {
183         sub is_scalar($);
184         my $type = shift;
185
186         return 1 if (ref($type) eq "HASH" and 
187                 ($type->{TYPE} eq "SCALAR" or $type->{TYPE} eq "ENUM" or 
188                  $type->{TYPE} eq "BITMAP"));
189
190         if (my $dt = getType($type)) {
191                 return is_scalar($dt->{DATA}) if ($dt->{TYPE} eq "TYPEDEF");
192                 return 1 if ($dt->{TYPE} eq "SCALAR" or $dt->{TYPE} eq "ENUM" or 
193                                  $dt->{TYPE} eq "BITMAP");
194         }
195
196         return 0;
197 }
198
199 sub is_fixed_size_scalar($)
200 {
201         my $name = shift;
202
203         return 0 unless is_scalar($name);
204         return 0 if (grep(/^$name$/, @non_fixed_size_scalars));
205         return 1;
206 }
207
208 sub scalar_is_reference($)
209 {
210         my $name = shift;
211
212         return 1 if (grep(/^$name$/, @reference_scalars));
213         return 0;
214 }
215
216 sub RegisterScalars()
217 {
218         foreach (keys %scalars) {
219                 addType({
220                         NAME => $_,
221                         TYPE => "TYPEDEF",
222                         BASEFILE => "<builtin>",
223                         DATA => {
224                                 TYPE => "SCALAR",
225                                 NAME => $_
226                         }
227                 }
228                 );
229         }
230 }
231
232 sub enum_type_fn($)
233 {
234         my $enum = shift;
235         $enum->{TYPE} eq "ENUM" or die("not an enum");
236
237         # for typedef enum { } we need to check $enum->{PARENT}
238         if (has_property($enum, "enum8bit")) {
239                 return "uint8";
240         } elsif (has_property($enum, "enum16bit")) {
241                 return "uint16";
242         } elsif (has_property($enum, "v1_enum")) {
243                 return "uint32";
244         } elsif (has_property($enum->{PARENT}, "enum8bit")) {
245                 return "uint8";
246         } elsif (has_property($enum->{PARENT}, "enum16bit")) {
247                 return "uint16";
248         } elsif (has_property($enum->{PARENT}, "v1_enum")) {
249                 return "uint32";
250         }
251         return "uint1632";
252 }
253
254 sub bitmap_type_fn($)
255 {
256         my $bitmap = shift;
257
258         $bitmap->{TYPE} eq "BITMAP" or die("not a bitmap");
259
260         if (has_property($bitmap, "bitmap8bit")) {
261                 return "uint8";
262         } elsif (has_property($bitmap, "bitmap16bit")) {
263                 return "uint16";
264         } elsif (has_property($bitmap, "bitmap64bit")) {
265                 return "hyper";
266         }
267         return "uint32";
268 }
269
270 sub typeHasBody($)
271 {
272         sub typeHasBody($);
273         my ($e) = @_;
274
275         if ($e->{TYPE} eq "TYPEDEF") {
276                 return 0 unless(defined($e->{DATA}));
277                 return typeHasBody($e->{DATA});
278         }
279
280         return defined($e->{ELEMENTS});
281 }
282
283 sub mapType($$)
284 {
285         sub mapType($$);
286         my ($t, $n) = @_;
287
288         return mapType($t->{DATA}, $n) if ($t->{TYPE} eq "TYPEDEF");
289         return mapScalarType($n) if ($t->{TYPE} eq "SCALAR");
290         return "enum $n" if ($t->{TYPE} eq "ENUM");
291         return "struct $n" if ($t->{TYPE} eq "STRUCT" or $t->{TYPE} eq "INTERFACE");
292         return "union $n" if ($t->{TYPE} eq "UNION");
293         return mapScalarType(bitmap_type_fn($t)) if ($t->{TYPE} eq "BITMAP");
294         return "struct $n" if ($t->{TYPE} eq "PIPE");
295         die("Unknown type $t->{TYPE}");
296 }
297
298 sub mapTypeName($)
299 {
300         my $t = shift;
301         return "void" unless defined($t);
302         my $dt;
303         $t = expandAlias($t);
304
305         if ($dt = getType($t)) {
306                 return mapType($dt, $dt->{NAME});
307         } elsif (ref($t) eq "HASH" and defined($t->{NAME})) {
308                 return mapType($t, $t->{NAME});
309         } else {
310                 # Best guess
311                 return "struct $t";
312         }
313
314 }
315
316 sub LoadIdl($;$)
317 {
318         my $idl = shift;
319         my $basename = shift;
320
321         foreach my $x (@{$idl}) {
322                 next if $x->{TYPE} ne "INTERFACE";
323
324                 # DCOM interfaces can be types as well
325                 addType({
326                         NAME => $x->{NAME},
327                         TYPE => "TYPEDEF",
328                         DATA => $x,
329                         BASEFILE => $basename,
330                         }) if (has_property($x, "object"));
331
332                 foreach my $y (@{$x->{DATA}}) {
333                         if ($y->{TYPE} eq "TYPEDEF"
334                             or $y->{TYPE} eq "UNION"
335                             or $y->{TYPE} eq "STRUCT"
336                             or $y->{TYPE} eq "ENUM"
337                             or $y->{TYPE} eq "BITMAP"
338                             or $y->{TYPE} eq "PIPE") {
339                                 $y->{BASEFILE} = $basename;
340                                 addType($y);
341                         }
342                 }
343         }
344 }
345
346 sub GenerateTypeLib()
347 {
348         return Parse::Pidl::Util::MyDumper(\%types);
349 }
350
351 RegisterScalars();
352
353 1;