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