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
13 #####################################################################
14 # return a table describing the order in which the parts of an element
16 # Possible level types:
22 sub GetElementLevelTable($)
28 my @bracket_array = ();
32 if (util::has_property($e, "size_is")) {
33 @size_is = split /,/, util::has_property($e, "size_is");
36 if (util::has_property($e, "length_is")) {
37 @length_is = split /,/, util::has_property($e, "length_is");
40 if (defined($e->{ARRAY_LEN})) {
41 @bracket_array = @{$e->{ARRAY_LEN}};
44 # Parse the [][][][] style array stuff
45 foreach my $d (@bracket_array) {
48 my $is_surrounding = 0;
50 my $is_conformant = 0;
54 unless ($size = shift @size_is) {
55 print "$e->{FILE}:$e->{LINE}: Must specify size_is() for conformant array!\n";
59 if ($length = shift @length_is) {
65 if ($e == $e->{PARENT}->{ELEMENTS}[-1]
66 and $e->{PARENT}->{TYPE} ne "FUNCTION") {
75 IS_DEFERRED => "$is_deferred",
76 # Inline arrays (which are a pidl extension) are never encoded
77 # as surrounding the struct they're part of
78 IS_SURROUNDING => "$is_surrounding",
79 IS_VARYING => "$is_varying",
80 IS_CONFORMANT => "$is_conformant",
81 IS_FIXED => (not $is_conformant and util::is_constant($size)),
82 NO_METADATA => (not $is_conformant),
83 IS_INLINE => (not $is_conformant and not util::is_constant($size))
87 # Next, all the pointers
88 foreach my $i (1..$e->{POINTERS}) {
89 my $pt = pointer_type($e);
91 my $level = "EMBEDDED";
92 # Top level "ref" pointers do not have a referrent identifier
93 $level = "TOP" if ( defined($pt)
95 and $e->{PARENT}->{TYPE} eq "FUNCTION");
99 # for now, there can only be one pointer type per element
100 POINTER_TYPE => pointer_type($e),
101 IS_DEFERRED => "$is_deferred",
105 # everything that follows will be deferred
106 $is_deferred = 1 if ($e->{PARENT}->{TYPE} ne "FUNCTION");
110 if ($array_size = shift @size_is) {
112 if ($array_length = shift @length_is) {
115 $array_length = $array_size;
120 SIZE_IS => $array_size,
121 LENGTH_IS => $array_length,
122 IS_DEFERRED => "$is_deferred",
124 IS_VARYING => "$is_varying",
135 if (my $hdr_size = util::has_property($e, "subcontext")) {
136 my $subsize = util::has_property($e, "subcontext_size");
137 if (not defined($subsize)) {
142 TYPE => "SUBCONTEXT",
143 HEADER_SIZE => $hdr_size,
144 SUBCONTEXT_SIZE => $subsize,
145 IS_DEFERRED => $is_deferred,
146 COMPRESSION => util::has_property($e, "compression"),
147 OBFUSCATION => util::has_property($e, "obfuscation")
151 if (my $switch = util::has_property($e, "switch_is")) {
154 SWITCH_IS => $switch,
155 IS_DEFERRED => $is_deferred
161 DATA_TYPE => $e->{TYPE},
162 IS_DEFERRED => $is_deferred,
163 CONTAINS_DEFERRED => can_contain_deferred($e),
164 IS_SURROUNDING => is_surrounding_string($e)
168 foreach (@$order) { $_->{LEVEL_INDEX} = $i; $i+=1; }
173 #####################################################################
174 # see if a type contains any deferred data
175 sub can_contain_deferred
179 return 1 if ($e->{POINTERS});
180 return 0 if (typelist::is_scalar($e->{TYPE}));
181 return 0 if (util::has_property($e, "subcontext"));
182 return 1 unless (typelist::hasType($e->{TYPE})); # assume the worst
184 my $type = typelist::getType($e->{TYPE});
186 foreach my $x (@{$type->{DATA}->{ELEMENTS}}) {
187 return 1 if (can_contain_deferred ($x));
197 return undef unless $e->{POINTERS};
199 return "ref" if (util::has_property($e, "ref"));
200 return "ptr" if (util::has_property($e, "ptr"));
201 return "unique" if (util::has_property($e, "unique"));
202 return "relative" if (util::has_property($e, "relative"));
203 return "ignore" if (util::has_property($e, "ignore"));
208 sub is_surrounding_string($)
214 return ($e->{TYPE} eq "string") and ($e->{POINTERS} == 0)
215 and util::property_matches($e, "flag", ".*LIBNDR_FLAG_STR_CONFORMANT.*")
216 and $e->{PARENT}->{TYPE} ne "FUNCTION";
220 #####################################################################
221 # work out the correct alignment for a structure or union
222 sub find_largest_alignment($)
227 for my $e (@{$s->{ELEMENTS}}) {
230 if (Ndr::need_wire_pointer($e)) {
233 $a = align_type($e->{TYPE});
236 $align = $a if ($align < $a);
242 #####################################################################
248 unless (typelist::hasType($e)) {
249 # it must be an external type - all we can do is guess
250 # print "Warning: assuming alignment of unknown type '$e' is 4\n";
254 my $dt = typelist::getType($e)->{DATA};
256 if ($dt->{TYPE} eq "ENUM") {
257 return align_type(typelist::enum_type_fn($dt));
258 } elsif ($dt->{TYPE} eq "BITMAP") {
259 return align_type(typelist::bitmap_type_fn($dt));
260 } elsif (($dt->{TYPE} eq "STRUCT") or ($dt->{TYPE} eq "UNION")) {
261 return find_largest_alignment($dt);
262 } elsif ($dt->{TYPE} eq "SCALAR") {
263 return typelist::getScalarAlignment($dt->{NAME});
266 die("Unknown data type type $dt->{TYPE}");
269 # determine if an element needs a reference pointer on the wire
270 # in its NDR representation
271 sub need_wire_pointer($)
275 my $n = $e->{POINTERS};
276 my $pt = pointer_type($e);
278 # Top level "ref" pointers do not have a referrent identifier
281 and $e->{PARENT}->{TYPE} eq "FUNCTION")
296 PROPERTIES => $e->{PROPERTIES},
297 LEVELS => GetElementLevelTable($e)
305 my $surrounding = undef;
307 foreach my $x (@{$struct->{ELEMENTS}})
309 push @elements, ParseElement($x);
312 my $e = $elements[-1];
313 if (defined($e) and defined($e->{LEVELS}[0]->{IS_SURROUNDING}) and
314 $e->{LEVELS}[0]->{IS_SURROUNDING}) {
318 if (defined $e->{TYPE} && $e->{TYPE} eq "string"
319 && util::property_matches($e, "flag", ".*LIBNDR_FLAG_STR_CONFORMANT.*")) {
320 $surrounding = $struct->{ELEMENTS}[-1];
325 SURROUNDING_ELEMENT => $surrounding,
326 ELEMENTS => \@elements,
327 PROPERTIES => $struct->{PROPERTIES}
335 my $switch_type = util::has_property($e, "switch_type");
336 unless (defined($switch_type)) { $switch_type = "uint32"; }
338 if (util::has_property($e, "nodiscriminant")) { $switch_type = undef; }
340 foreach my $x (@{$e->{ELEMENTS}})
343 if ($x->{TYPE} eq "EMPTY") {
344 $t = { TYPE => "EMPTY" };
346 $t = ParseElement($x);
348 if (util::has_property($x, "default")) {
349 $t->{CASE} = "default";
350 } elsif (defined($x->{PROPERTIES}->{case})) {
351 $t->{CASE} = "case $x->{PROPERTIES}->{case}";
353 die("Union element $x->{NAME} has neither default nor case property");
360 SWITCH_TYPE => $switch_type,
361 ELEMENTS => \@elements,
362 PROPERTIES => $e->{PROPERTIES}
372 BASE_TYPE => typelist::enum_type_fn($e),
373 ELEMENTS => $e->{ELEMENTS},
374 PROPERTIES => $e->{PROPERTIES}
384 BASE_TYPE => typelist::bitmap_type_fn($e),
385 ELEMENTS => $e->{ELEMENTS},
386 PROPERTIES => $e->{PROPERTIES}
403 if ($d->{DATA}->{TYPE} eq "STRUCT" or $d->{DATA}->{TYPE} eq "UNION") {
404 CheckPointerTypes($d->{DATA}, $ndr->{PROPERTIES}->{pointer_default});
407 if (defined($d->{PROPERTIES}) && !defined($d->{DATA}->{PROPERTIES})) {
408 $d->{DATA}->{PROPERTIES} = $d->{PROPERTIES};
411 if ($d->{DATA}->{TYPE} eq "STRUCT") {
412 $data = ParseStruct($d->{DATA});
413 } elsif ($d->{DATA}->{TYPE} eq "UNION") {
414 $data = ParseUnion($d->{DATA});
415 } elsif ($d->{DATA}->{TYPE} eq "ENUM") {
416 $data = ParseEnum($d->{DATA});
417 } elsif ($d->{DATA}->{TYPE} eq "BITMAP") {
418 $data = ParseBitmap($d->{DATA});
420 die("Unknown data type '$d->{DATA}->{TYPE}'");
423 $data->{ALIGN} = align_type($d->{NAME});
428 PROPERTIES => $d->{PROPERTIES},
441 sub ParseFunction($$$)
449 CheckPointerTypes($d,
450 $ndr->{PROPERTIES}->{pointer_default_top}
453 foreach my $x (@{$d->{ELEMENTS}}) {
454 my $e = ParseElement($x);
455 if (util::has_property($x, "in")) {
456 push (@{$e->{DIRECTION}}, "in");
459 if (util::has_property($x, "out")) {
460 push (@{$e->{DIRECTION}}, "out");
463 push (@elements, $e);
466 if ($d->{RETURN_TYPE} ne "void") {
467 $rettype = $d->{RETURN_TYPE};
474 RETURN_TYPE => $rettype,
475 PROPERTIES => $d->{PROPERTIES},
476 ELEMENTS => \@elements
480 sub CheckPointerTypes($$)
485 foreach my $e (@{$s->{ELEMENTS}}) {
486 if ($e->{POINTERS}) {
487 if (not defined(Ndr::pointer_type($e))) {
488 $e->{PROPERTIES}->{$default} = 1;
491 if (Ndr::pointer_type($e) eq "ptr") {
492 print "Warning: ptr is not supported by pidl yet\n";
498 sub ParseInterface($)
509 if (not util::has_property($idl, "pointer_default")) {
510 # MIDL defaults to "ptr" in DCE compatible mode (/osf)
511 # and "unique" in Microsoft Extensions mode (default)
512 $idl->{PROPERTIES}->{pointer_default} = "unique";
515 if (not util::has_property($idl, "pointer_default_top")) {
516 $idl->{PROPERTIES}->{pointer_default_top} = "ref";
519 foreach my $d (@{$idl->{DATA}}) {
520 if ($d->{TYPE} eq "TYPEDEF") {
521 push (@typedefs, ParseTypedef($idl, $d));
524 if ($d->{TYPE} eq "DECLARE") {
525 push (@declares, ParseDeclare($idl, $d));
528 if ($d->{TYPE} eq "FUNCTION") {
529 push (@functions, ParseFunction($idl, $d, $opnum));
533 if ($d->{TYPE} eq "CONST") {
534 push (@consts, ParseConst($idl, $d));
540 if(defined $idl->{PROPERTIES}->{version}) {
541 $version = $idl->{PROPERTIES}->{version};
544 # If no endpoint is set, default to the interface name as a named pipe
545 if (!defined $idl->{PROPERTIES}->{endpoint}) {
546 push @endpoints, "\"ncacn_np:[\\\\pipe\\\\" . $idl->{NAME} . "]\"";
548 @endpoints = split / /, $idl->{PROPERTIES}->{endpoint};
552 NAME => $idl->{NAME},
553 UUID => util::has_property($idl, "uuid"),
556 PROPERTIES => $idl->{PROPERTIES},
557 FUNCTIONS => \@functions,
559 TYPEDEFS => \@typedefs,
560 DECLARES => \@declares,
561 ENDPOINTS => \@endpoints
565 # Convert a IDL tree to a NDR tree
566 # Gives a result tree describing all that's necessary for easily generating
568 # - list of interfaces
569 # - list with functions
570 # - list with in elements
571 # - list with out elements
573 # - list with structs
574 # - alignment of structure
575 # - list with elements
577 # - alignment of union
578 # - list with elements
581 # - list with bitmaps
586 # properties are saved
587 # pointer types explicitly specified
593 foreach my $x (@{$idl}) {
594 push @ndr, ParseInterface($x);
607 foreach my $l (@{$e->{LEVELS}}) {
608 return $l if ($seen);
609 ($seen = 1) if ($l == $fl);
621 foreach my $l (@{$e->{LEVELS}}) {
622 (return $prev) if ($l == $fl);
629 sub ContainsDeferred($$)
635 return 1 if ($l->{IS_DEFERRED});
636 return 1 if ($l->{CONTAINS_DEFERRED});
637 } while ($l = Ndr::GetNextLevel($e,$l));