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