aad0cf426c8e4a4ede8a92e4d7615d47cc248897
[ira/wip.git] / source / 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 mapTypeName scalar_is_reference expandAlias
11                             mapScalarType addType typeIs 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         "int" => "int32",
63         "WORD" => "uint16",
64         "char" => "uint8",
65         "long" => "int32",
66         "short" => "int16",
67         "HYPER_T" => "hyper",
68         "HRESULT" => "COMRESULT",
69 );
70
71 sub expandAlias($)
72 {
73         my $name = shift;
74
75         return $aliases{$name} if defined($aliases{$name});
76
77         return $name;
78 }
79
80 # map from a IDL type to a C header type
81 sub mapScalarType($)
82 {
83         my $name = shift;
84
85         # it's a bug when a type is not in the list
86         # of known scalars or has no mapping
87         return $scalars{$name} if defined($scalars{$name});
88
89         die("Unknown scalar type $name");
90 }
91
92 sub addType($)
93 {
94         my $t = shift;
95         $types{$t->{NAME}} = $t;
96 }
97
98 sub getType($)
99 {
100         my $t = shift;
101         return ($t) if (ref($t) eq "HASH" and not defined($t->{NAME}));
102         return undef if not hasType($t);
103         return $types{$t->{NAME}} if (ref($t) eq "HASH");
104         return $types{$t};
105 }
106
107 sub typeIs($$)
108 {
109         my ($t,$tt) = @_;
110         
111         if (ref($t) eq "HASH") {
112                 return 1 if ($t->{TYPE} eq $tt);
113                 return 0;
114         }
115         return 1 if (hasType($t) and getType($t)->{TYPE} eq "TYPEDEF" and 
116                          getType($t)->{DATA}->{TYPE} eq $tt);
117         return 0;
118 }
119
120 sub hasType($)
121 {
122         my $t = shift;
123         if (ref($t) eq "HASH") {
124                 return 1 if (not defined($t->{NAME}));
125                 return 1 if (defined($types{$t->{NAME}}) and 
126                         $types{$t->{NAME}}->{TYPE} eq $t->{TYPE});
127                 return 0;
128         }
129         return 1 if defined($types{$t});
130         return 0;
131 }
132
133 sub is_scalar($)
134 {
135         sub is_scalar($);
136         my $type = shift;
137
138         return 1 if (ref($type) eq "HASH" and $type->{TYPE} eq "SCALAR");
139
140         if (my $dt = getType($type)) {
141                 return is_scalar($dt->{DATA}) if ($dt->{TYPE} eq "TYPEDEF");
142                 return 1 if ($dt->{TYPE} eq "SCALAR" or $dt->{TYPE} eq "ENUM" or 
143                                  $dt->{TYPE} eq "BITMAP");
144         }
145
146         return 0;
147 }
148
149 sub scalar_is_reference($)
150 {
151         my $name = shift;
152         
153         return 1 if (grep(/^$name$/, @reference_scalars));
154         return 0;
155 }
156
157 sub RegisterScalars()
158 {
159         foreach (keys %scalars) {
160                 addType({
161                         NAME => $_,
162                         TYPE => "TYPEDEF",
163                         DATA => {
164                                 TYPE => "SCALAR",
165                                 NAME => $_
166                         }
167                 }
168                 );
169         }
170 }
171
172 sub enum_type_fn($)
173 {
174         my $enum = shift;
175         $enum->{TYPE} eq "ENUM" or die("not an enum");
176
177         # for typedef enum { } we need to check $enum->{PARENT}
178         if (has_property($enum, "enum8bit")) {
179                 return "uint8";
180         } elsif (has_property($enum, "enum16bit")) {
181                 return "uint16";
182         } elsif (has_property($enum, "v1_enum")) {
183                 return "uint32";
184         } elsif (has_property($enum->{PARENT}, "enum8bit")) {
185                 return "uint8";
186         } elsif (has_property($enum->{PARENT}, "enum16bit")) {
187                 return "uint16";
188         } elsif (has_property($enum->{PARENT}, "v1_enum")) {
189                 return "uint32";
190         }
191         return "uint16";
192 }
193
194 sub bitmap_type_fn($)
195 {
196         my $bitmap = shift;
197
198         $bitmap->{TYPE} eq "BITMAP" or die("not a bitmap");
199
200         if (has_property($bitmap, "bitmap8bit")) {
201                 return "uint8";
202         } elsif (has_property($bitmap, "bitmap16bit")) {
203                 return "uint16";
204         } elsif (has_property($bitmap, "bitmap64bit")) {
205                 return "hyper";
206         }
207         return "uint32";
208 }
209
210 sub typeHasBody($)
211 {
212         sub typeHasBody($);
213         my ($e) = @_;
214
215         if ($e->{TYPE} eq "TYPEDEF") {
216                 return 0 unless(defined($e->{DATA}));
217                 return typeHasBody($e->{DATA});
218         }
219
220         return defined($e->{ELEMENTS});
221 }
222
223 sub mapType($$)
224 {
225         sub mapType($$);
226         my ($t, $n) = @_;
227
228         return mapType($t->{DATA}, $n) if ($t->{TYPE} eq "TYPEDEF");
229         return mapScalarType($n) if ($t->{TYPE} eq "SCALAR");
230         return "enum $n" if ($t->{TYPE} eq "ENUM");
231         return "struct $n" if ($t->{TYPE} eq "STRUCT");
232         return "union $n" if ($t->{TYPE} eq "UNION");
233         return mapScalarType(bitmap_type_fn($t)) if ($t->{TYPE} eq "BITMAP");
234         die("Unknown type $t->{TYPE}");
235 }
236
237 sub mapTypeName($)
238 {
239         my $t = shift;
240         return "void" unless defined($t);
241         my $dt;
242         $t = expandAlias($t);
243
244         unless ($dt or ($dt = getType($t))) {
245                 # Best guess
246                 return "struct $t";
247         }
248
249         return mapType($dt, $dt->{NAME});
250 }
251
252 sub LoadIdl($)
253 {
254         my ($idl) = @_;
255
256         foreach my $x (@{$idl}) {
257                 next if $x->{TYPE} ne "INTERFACE";
258
259                 foreach my $y (@{$x->{DATA}}) {
260                         addType($y) if (
261                                 $y->{TYPE} eq "TYPEDEF" 
262                                  or $y->{TYPE} eq "UNION"
263                                  or $y->{TYPE} eq "STRUCT"
264                          or $y->{TYPE} eq "ENUM"
265                          or $y->{TYPE} eq "BITMAP");
266                 }
267         }
268 }
269
270 sub GenerateTypeLib()
271 {
272         return Parse::Pidl::Util::MyDumper(\%types);
273 }
274
275 RegisterScalars();
276
277 1;