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