08047377479d830c45808a68a468ee36588cc497
[samba.git] / source / build / pidl / ndr.pm
1 ###################################################
2 # Samba4 NDR info tree generator
3 # Copyright tridge@samba.org 2000-2003
4 # Copyright tpot@samba.org 2001
5 # Copyright jelmer@samba.org 2004-2005
6 # released under the GNU GPL
7
8 package Ndr;
9
10 use strict;
11 use typelist;
12
13 #####################################################################
14 # return a table describing the order in which the parts of an element
15 # should be parsed
16 # Possible level types:
17 #  - POINTER
18 #  - ARRAY
19 #  - SUBCONTEXT
20 #  - SWITCH
21 #  - DATA
22 sub GetElementLevelTable($)
23 {
24         my $e = shift;
25
26         return ($e->{NDR_ORDER_TABLE}) if (defined $e->{NDR_ORDER_TABLE});
27
28         my $order = [];
29         my $is_deferred = 0;
30         
31         # FIXME: Process {ARRAY_SIZE} kinds of arrays
32
33         # First, all the pointers
34         foreach my $i (1..need_wire_pointer($e)) {
35                 push (@$order, { 
36                         TYPE => "POINTER",
37                         # for now, there can only be one pointer type per element
38                         POINTER_TYPE => pointer_type($e),
39                         IS_DEFERRED => "$is_deferred"
40                 });
41                 # everything that follows will be deferred
42                 $is_deferred = 1;
43                 # FIXME: Process array here possibly (in case of multi-dimensional arrays, etc)
44         }
45
46         if (defined($e->{ARRAY_LEN})) {
47                 push (@$order, {
48                         TYPE => "ARRAY",
49                         ARRAY_TYPE => array_type($e),
50                         SIZE_IS => util::has_property($e, "size_is"),
51                         LENGTH_IS => util::has_property($e, "length_is"),
52                         IS_DEFERRED => "$is_deferred"
53                 });
54         }
55
56         if (my $sub_size = util::has_property($e, "subcontext")) {
57                 push (@$order, {
58                         TYPE => "SUBCONTEXT",
59                         SUBCONTEXT_SIZE => $sub_size,
60                         IS_DEFERRED => $is_deferred,
61                         COMPRESSION => util::has_property($e, "compression")
62                 });
63         }
64
65         if (my $switch = util::has_property($e, "switch_is")) {
66                 push (@$order, {
67                         TYPE => "SWITCH", 
68                         SWITCH_IS => $switch,
69                         IS_DEFERRED => $is_deferred
70                 });
71         }
72
73         push (@$order, {
74                 TYPE => "DATA",
75                 DATA_TYPE => $e->{TYPE},
76                 NAME => $e->{NAME},
77                 IS_DEFERRED => $is_deferred,
78                 CONTAINS_DEFERRED => can_contain_deferred($e)
79         });
80
81         $e->{NDR_ORDER_TABLE} = $order;
82
83         return $order;
84 }
85
86 #####################################################################
87 # see if a type contains any deferred data 
88 sub can_contain_deferred
89 {
90         my $e = shift;
91
92         return 1 if ($e->{POINTERS});
93         return 0 if (is_scalar_type($e->{TYPE}));
94         return 0 if (util::has_property($e, "subcontext"));
95         return 1 unless (typelist::hasType($e->{TYPE})); # assume the worst
96
97         my $type = typelist::getType($e->{TYPE});
98
99         foreach my $x (@{$type->{DATA}->{ELEMENTS}}) {
100                 return 1 if (can_contain_deferred ($x));
101         }
102         
103         return 0;
104 }
105
106 sub is_scalar_type($)
107 {
108     my $type = shift;
109
110         return 0 unless typelist::hasType($type);
111
112         if (my $dt = typelist::getType($type)->{DATA}->{TYPE}) {
113                 return 1 if ($dt eq "SCALAR" or $dt eq "ENUM" or $dt eq "BITMAP");
114         }
115
116     return 0;
117 }
118
119 sub pointer_type($)
120 {
121         my $e = shift;
122
123         return undef unless $e->{POINTERS};
124         
125         return "ref" if (util::has_property($e, "ref"));
126         return "ptr" if (util::has_property($e, "ptr"));
127         return "unique" if (util::has_property($e, "unique"));
128         return "relative" if (util::has_property($e, "relative"));
129         return "ignore" if (util::has_property($e, "ignore"));
130
131         return undef;
132 }
133
134 # return 1 if this is a fixed array
135 sub is_fixed_array($)
136 {
137         my $e = shift;
138         my $len = $e->{"ARRAY_LEN"};
139         return 1 if (defined $len && util::is_constant($len));
140         return 0;
141 }
142
143 # return 1 if this is a conformant array
144 sub is_conformant_array($)
145 {
146         my $e = shift;
147         return 1 if (util::has_property($e, "size_is"));
148         return 0;
149 }
150
151 # return 1 if this is a inline array
152 sub is_inline_array($)
153 {
154         my $e = shift;
155         my $len = $e->{"ARRAY_LEN"};
156         if (is_fixed_array($e) ||
157             defined $len && $len ne "*") {
158                 return 1;
159         }
160         return 0;
161 }
162
163 # return 1 if this is a varying array
164 sub is_varying_array($)
165 {
166         my $e = shift;
167         return util::has_property($e, "length_is");
168 }
169
170 # return 1 if this is a surrounding array (sometimes 
171 # referred to as an embedded array). Can only occur as 
172 # the last element in a struct and can not contain any pointers.
173 sub is_surrounding_array($)
174 {
175         my $e = shift;
176
177         return ($e->{POINTERS} == 0 
178                 and defined $e->{ARRAY_LEN} 
179                 and     $e->{ARRAY_LEN} eq "*"
180                 and $e == $e->{PARENT}->{ELEMENTS}[-1] 
181                 and $e->{PARENT}->{TYPE} ne "FUNCTION");
182 }
183
184 sub array_type($)
185 {
186         my $e = shift;
187
188         return "conformant-varying" if (is_varying_array($e) and is_conformant_array($e));
189         return "conformant" if (is_varying_array($e));
190         return "varying" if (is_varying_array($e));
191         return "inline" if (is_inline_array($e));
192         return "fixed" if (is_fixed_array($e));
193
194         return undef;
195 }
196
197 #####################################################################
198 # work out the correct alignment for a structure or union
199 sub find_largest_alignment($)
200 {
201         my $s = shift;
202
203         my $align = 1;
204         for my $e (@{$s->{ELEMENTS}}) {
205                 my $a = 1;
206
207                 if (Ndr::need_wire_pointer($e)) {
208                         $a = 4; 
209                 } else { 
210                         $a = align_type($e->{TYPE}); 
211                 }
212
213                 $align = $a if ($align < $a);
214         }
215
216         return $align;
217 }
218
219 my %scalar_alignments = 
220 (
221      "char"           => 1,
222      "int8"           => 1,
223      "uint8"          => 1,
224      "short"          => 2,
225      "wchar_t"        => 2,
226      "int16"          => 2,
227      "uint16"         => 2,
228      "long"           => 4,
229      "int32"          => 4,
230      "uint32"         => 4,
231      "dlong"          => 4,
232      "udlong"         => 4,
233      "udlongr"        => 4,
234      "NTTIME"         => 4,
235      "NTTIME_1sec"    => 4,
236      "time_t"         => 4,
237      "DATA_BLOB"      => 4,
238      "error_status_t" => 4,
239      "WERROR"         => 4,
240          "NTSTATUS"       => 4,
241      "boolean32"      => 4,
242      "unsigned32"     => 4,
243      "ipv4address"    => 4,
244      "hyper"          => 8,
245      "NTTIME_hyper"   => 8
246 );
247
248 #####################################################################
249 # align a type
250 sub align_type
251 {
252         my $e = shift;
253
254         unless (typelist::hasType($e)) {
255             # it must be an external type - all we can do is guess 
256                 # print "Warning: assuming alignment of unknown type '$e' is 4\n";
257             return 4;
258         }
259
260         my $dt = typelist::getType($e)->{DATA};
261
262         if ($dt->{TYPE} eq "ENUM") {
263                 return align_type(typelist::enum_type_fn($dt));
264         } elsif ($dt->{TYPE} eq "BITMAP") {
265                 return align_type(typelist::bitmap_type_fn($dt));
266         } elsif (($dt->{TYPE} eq "STRUCT") or ($dt->{TYPE} eq "UNION")) {
267                 return find_largest_alignment($dt);
268         } elsif ($dt->{TYPE} eq "SCALAR") {
269                 return $scalar_alignments{$dt->{NAME}};
270         } else { 
271                 die("Unknown data type type $dt->{TYPE}");
272         }
273 }
274
275 # determine if an element needs a reference pointer on the wire
276 # in its NDR representation
277 sub need_wire_pointer($)
278 {
279         my $e = shift;
280
281         my $n = $e->{POINTERS};
282         my $pt = pointer_type($e);
283
284         # Top level "ref" pointers do not have a referrent identifier
285         if (    defined($pt) 
286                 and $pt eq "ref" 
287                 and $e->{PARENT}->{TYPE} eq "FUNCTION") 
288         {
289                 $n--;
290         }
291
292         return $n;
293 }
294
295 sub ParseElement($)
296 {
297         my $e = shift;
298
299         return {
300                 NAME => $e->{NAME},
301                 PROPERTIES => $e->{PROPERTIES},
302                 LEVELS => GetElementLevelTable($e)
303         };
304 }
305
306 sub ParseStruct($)
307 {
308         my $e = shift;
309         my @elements = ();
310
311         foreach my $x (@{$e->{ELEMENTS}}) 
312         {
313                 push @elements, ParseElement($x);
314         }
315
316         return {
317                 TYPE => "STRUCT",
318                 ELEMENTS => \@elements,
319                 PROPERTIES => $e->{PROPERTIES}
320         };
321 }
322
323 sub ParseUnion($)
324 {
325         my $e = shift;
326         my @elements = ();
327         
328         foreach my $x (@{$e->{ELEMENTS}}) 
329         {
330                 my $t;
331                 if ($x->{TYPE} eq "EMPTY") {
332                         $t = { TYPE => "EMPTY" };
333                 } else {
334                         $t = ParseElement($x);
335                         if (util::has_property($t, "default")) {
336                                 $t->{DEFAULT} = "default";
337                         } else {
338                                 $t->{CASE} = $t->{PROPERTIES}->{CASE};
339                         }
340                 }
341                 push @elements, $t;
342         }
343
344         return {
345                 TYPE => "UNION",
346                 ELEMENTS => \@elements,
347                 PROPERTIES => $e->{PROPERTIES}
348         };
349 }
350
351 sub ParseEnum($)
352 {
353         my $e = shift;
354
355         return {
356                 TYPE => "ENUM",
357                 ELEMENTS => $e->{ELEMENTS},
358                 PROPERTIES => $e->{PROPERTIES}
359         };
360 }
361
362 sub ParseBitmap($)
363 {
364         my $e = shift;
365
366         return {
367                 TYPE => "BITMAP",
368                 ELEMENTS => $e->{ELEMENTS},
369                 PROPERTIES => $e->{PROPERTIES}
370         };
371 }
372
373 sub ParseTypedef($$)
374 {
375         my $ndr = shift;
376         my $d = shift;
377         my $data;
378
379         if ($d->{DATA}->{TYPE} eq "STRUCT" or $d->{DATA}->{TYPE} eq "UNION") {
380                 CheckPointerTypes($d->{DATA}, $ndr->{PROPERTIES}->{pointer_default});
381         }
382
383         if (defined($d->{PROPERTIES}) && !defined($d->{DATA}->{PROPERTIES})) {
384                 $d->{DATA}->{PROPERTIES} = $d->{PROPERTIES};
385         }
386
387         if ($d->{DATA}->{TYPE} eq "STRUCT") {
388                 $data = ParseStruct($d->{DATA});
389         } elsif ($d->{DATA}->{TYPE} eq "UNION") {
390                 $data = ParseUnion($d->{DATA});
391         } elsif ($d->{DATA}->{TYPE} eq "ENUM") {
392                 $data = ParseEnum($d->{DATA});
393         } elsif ($d->{DATA}->{TYPE} eq "BITMAP") {
394                 $data = ParseBitmap($d->{DATA});
395         } else {
396                 die("Unknown data type '$d->{DATA}->{TYPE}'");
397         }
398
399         $data->{ALIGN} = align_type($d->{NAME});
400
401         return {
402                 NAME => $d->{NAME},
403                 TYPE => "TYPEDEF",
404                 PROPERTIES => $d->{PROPERTIES},
405                 DATA => $data
406         };
407 }
408
409 sub ParseFunction($$)
410 {
411         my $ndr = shift;
412         my $d = shift;
413         my @in = ();
414         my @out = ();
415
416         CheckPointerTypes($d, 
417                 $ndr->{PROPERTIES}->{pointer_default}  # MIDL defaults to "ref"
418         );
419
420         foreach my $x (@{$d->{ELEMENTS}}) {
421                 if (util::has_property($x, "in")) {
422                         push (@in, ParseElement($x));
423                 }
424                 if (util::has_property($x, "out")) {
425                         push (@out, ParseElement($x));
426                 }
427         }
428         
429         return {
430                         NAME => $d->{NAME},
431                         TYPE => "FUNCTION",
432                         RETURN_TYPE => $d->{RETURN_TYPE},
433                         PROPERTIES => $d->{PROPERTIES},
434                         ELEMENTS => {
435                                 IN => \@in,
436                                 OUT => \@out
437                         }
438                 };
439 }
440
441 sub CheckPointerTypes($$)
442 {
443         my $s = shift;
444         my $default = shift;
445
446         foreach my $e (@{$s->{ELEMENTS}}) {
447                 if ($e->{POINTERS}) {
448                         if (not defined(Ndr::pointer_type($e))) {
449                                 $e->{PROPERTIES}->{$default} = 1;
450                         }
451
452                         if (Ndr::pointer_type($e) eq "ptr") {
453                                 print "Warning: ptr is not supported by pidl yet\n";
454                         }
455                 }
456         }
457 }
458
459 sub ParseInterface($)
460 {
461         my $idl = shift;
462         my @functions = ();
463         my @typedefs = ();
464         my $version;
465
466         if (not util::has_property($idl, "pointer_default")) {
467                 # MIDL defaults to "ptr" in DCE compatible mode (/osf)
468                 # and "unique" in Microsoft Extensions mode (default)
469                 $idl->{PROPERTIES}->{pointer_default} = "unique";
470         }
471
472         foreach my $d (@{$idl->{DATA}}) {
473                 if ($d->{TYPE} eq "DECLARE" or $d->{TYPE} eq "TYPEDEF") {
474                         push (@typedefs, ParseTypedef($idl, $d));
475                 }
476
477                 if ($d->{TYPE} eq "FUNCTION") {
478                         push (@functions, ParseFunction($idl, $d));
479                 }
480         }
481         
482         $version = "0.0";
483
484         if(defined $idl->{PROPERTIES}->{version}) { 
485                 $version = $idl->{PROPERTIES}->{version}; 
486         }
487         
488
489         return { 
490                 NAME => $idl->{NAME},
491                 UUID => util::has_property($idl, "uuid"),
492                 VERSION => $version,
493                 TYPE => "INTERFACE",
494                 PROPERTIES => $idl->{PROPERTIES},
495                 FUNCTIONS => \@functions,
496                 TYPEDEFS => \@typedefs
497         };
498 }
499
500 # Convert a IDL tree to a NDR tree
501 # Gives a result tree describing all that's necessary for easily generating
502 # NDR parsers
503 # - list of interfaces
504 #  - list with functions
505 #   - list with in elements
506 #   - list with out elements
507 #  - list of typedefs
508 #   - list with structs
509 #    - alignment of structure
510 #    - list with elements
511 #   - list with unions
512 #    - alignment of union
513 #    - list with elements
514 #   - list with enums
515 #    - base type
516 #   - list with bitmaps
517 #    - base type
518 # per element: 
519 #  - alignment
520 #  - "level" table
521 # properties are saved
522 # pointer types explicitly specified
523 sub Parse($)
524 {
525         my $idl = shift;
526         my @ndr = ();
527
528         foreach my $x (@{$idl}) {
529                 push @ndr, ParseInterface($x);
530         }
531
532         return \@ndr;
533 }
534
535 1;