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
8 package Parse::Pidl::NDR;
12 @EXPORT = qw(GetPrevLevel GetNextLevel ContainsDeferred);
15 use Parse::Pidl::Typelist qw(hasType getType);
16 use Parse::Pidl::Util qw(has_property property_matches);
21 warn ("$e->{FILE}:$e->{LINE}: Warning: $s\n");
24 #####################################################################
25 # signal a fatal validation error
29 die("$pos->{FILE}:$pos->{LINE}:$s\n");
32 #####################################################################
33 # return a table describing the order in which the parts of an element
35 # Possible level types:
41 sub GetElementLevelTable($)
47 my @bracket_array = ();
51 if (has_property($e, "size_is")) {
52 @size_is = split /,/, has_property($e, "size_is");
55 if (has_property($e, "length_is")) {
56 @length_is = split /,/, has_property($e, "length_is");
59 if (defined($e->{ARRAY_LEN})) {
60 @bracket_array = @{$e->{ARRAY_LEN}};
63 # Parse the [][][][] style array stuff
64 foreach my $d (@bracket_array) {
67 my $is_surrounding = 0;
69 my $is_conformant = 0;
74 if ($size = shift @size_is) {
75 } elsif ((scalar(@size_is) == 0) and has_property($e, "string")) {
77 delete($e->{PROPERTIES}->{string});
79 print "$e->{FILE}:$e->{LINE}: Must specify size_is() for conformant array!\n";
83 if (($length = shift @length_is) or $is_string) {
89 if ($e == $e->{PARENT}->{ELEMENTS}[-1]
90 and $e->{PARENT}->{TYPE} ne "FUNCTION") {
99 IS_DEFERRED => "$is_deferred",
100 IS_SURROUNDING => "$is_surrounding",
101 IS_ZERO_TERMINATED => "$is_string",
102 IS_VARYING => "$is_varying",
103 IS_CONFORMANT => "$is_conformant",
104 IS_FIXED => (not $is_conformant and Parse::Pidl::Util::is_constant($size)),
105 IS_INLINE => (not $is_conformant and not Parse::Pidl::Util::is_constant($size))
109 # Next, all the pointers
110 foreach my $i (1..$e->{POINTERS}) {
111 my $pt = pointer_type($e);
113 my $level = "EMBEDDED";
114 # Top level "ref" pointers do not have a referrent identifier
115 $level = "TOP" if ( defined($pt)
117 and $e->{PARENT}->{TYPE} eq "FUNCTION");
121 # for now, there can only be one pointer type per element
122 POINTER_TYPE => pointer_type($e),
123 IS_DEFERRED => "$is_deferred",
127 # everything that follows will be deferred
128 $is_deferred = 1 if ($e->{PARENT}->{TYPE} ne "FUNCTION");
130 my $array_size = shift @size_is;
137 if ($array_length = shift @length_is) {
140 $array_length = $array_size;
145 if (scalar(@size_is) == 0 and has_property($e, "string")) {
147 $is_varying = $is_conformant = has_property($e, "noheader")?0:1;
148 delete($e->{PROPERTIES}->{string});
151 if ($array_size or $is_string) {
154 IS_ZERO_TERMINATED => "$is_string",
155 SIZE_IS => $array_size,
156 LENGTH_IS => $array_length,
157 IS_DEFERRED => "$is_deferred",
159 IS_VARYING => "$is_varying",
160 IS_CONFORMANT => "$is_conformant",
169 if (defined(has_property($e, "subcontext"))) {
170 my $hdr_size = has_property($e, "subcontext");
171 my $subsize = has_property($e, "subcontext_size");
172 if (not defined($subsize)) {
177 TYPE => "SUBCONTEXT",
178 HEADER_SIZE => $hdr_size,
179 SUBCONTEXT_SIZE => $subsize,
180 IS_DEFERRED => $is_deferred,
181 COMPRESSION => has_property($e, "compression"),
182 OBFUSCATION => has_property($e, "obfuscation")
186 if (my $switch = has_property($e, "switch_is")) {
189 SWITCH_IS => $switch,
190 IS_DEFERRED => $is_deferred
194 if (scalar(@size_is) > 0) {
195 nonfatal($e, "size_is() on non-array element");
198 if (scalar(@length_is) > 0) {
199 nonfatal($e, "length_is() on non-array element");
202 if (has_property($e, "string")) {
203 nonfatal($e, "string() attribute on non-array element");
208 DATA_TYPE => $e->{TYPE},
209 IS_DEFERRED => $is_deferred,
210 CONTAINS_DEFERRED => can_contain_deferred($e),
211 IS_SURROUNDING => 0 #FIXME
215 foreach (@$order) { $_->{LEVEL_INDEX} = $i; $i+=1; }
220 #####################################################################
221 # see if a type contains any deferred data
222 sub can_contain_deferred
226 return 0 if (Parse::Pidl::Typelist::is_scalar($e->{TYPE}));
227 return 1 unless (hasType($e->{TYPE})); # assume the worst
229 my $type = getType($e->{TYPE});
231 foreach my $x (@{$type->{DATA}->{ELEMENTS}}) {
232 return 1 if ($x->{POINTERS});
233 return 1 if (can_contain_deferred ($x));
243 return undef unless $e->{POINTERS};
245 return "ref" if (has_property($e, "ref"));
246 return "ptr" if (has_property($e, "ptr"));
247 return "sptr" if (has_property($e, "sptr"));
248 return "unique" if (has_property($e, "unique"));
249 return "relative" if (has_property($e, "relative"));
250 return "ignore" if (has_property($e, "ignore"));
255 #####################################################################
256 # work out the correct alignment for a structure or union
257 sub find_largest_alignment($)
262 for my $e (@{$s->{ELEMENTS}}) {
265 if ($e->{POINTERS}) {
267 } elsif (has_property($e, "subcontext")){
270 $a = align_type($e->{TYPE});
273 $align = $a if ($align < $a);
279 #####################################################################
285 unless (hasType($e)) {
286 # it must be an external type - all we can do is guess
287 # print "Warning: assuming alignment of unknown type '$e' is 4\n";
291 my $dt = getType($e)->{DATA};
293 if ($dt->{TYPE} eq "ENUM") {
294 return align_type(Parse::Pidl::Typelist::enum_type_fn($dt));
295 } elsif ($dt->{TYPE} eq "BITMAP") {
296 return align_type(Parse::Pidl::Typelist::bitmap_type_fn($dt));
297 } elsif (($dt->{TYPE} eq "STRUCT") or ($dt->{TYPE} eq "UNION")) {
298 return find_largest_alignment($dt);
299 } elsif ($dt->{TYPE} eq "SCALAR") {
300 return Parse::Pidl::Typelist::getScalarAlignment($dt->{NAME});
303 die("Unknown data type type $dt->{TYPE}");
313 PROPERTIES => $e->{PROPERTIES},
314 LEVELS => GetElementLevelTable($e),
315 ALIGN => align_type($e->{TYPE}),
324 my $surrounding = undef;
326 foreach my $x (@{$struct->{ELEMENTS}})
328 push @elements, ParseElement($x);
331 my $e = $elements[-1];
332 if (defined($e) and defined($e->{LEVELS}[0]->{IS_SURROUNDING}) and
333 $e->{LEVELS}[0]->{IS_SURROUNDING}) {
337 if (defined $e->{TYPE} && $e->{TYPE} eq "string"
338 && property_matches($e, "flag", ".*LIBNDR_FLAG_STR_CONFORMANT.*")) {
339 $surrounding = $struct->{ELEMENTS}[-1];
344 SURROUNDING_ELEMENT => $surrounding,
345 ELEMENTS => \@elements,
346 PROPERTIES => $struct->{PROPERTIES},
355 my $switch_type = has_property($e, "switch_type");
356 unless (defined($switch_type)) { $switch_type = "uint32"; }
358 if (has_property($e, "nodiscriminant")) { $switch_type = undef; }
360 foreach my $x (@{$e->{ELEMENTS}})
363 if ($x->{TYPE} eq "EMPTY") {
364 $t = { TYPE => "EMPTY" };
366 $t = ParseElement($x);
368 if (has_property($x, "default")) {
369 $t->{CASE} = "default";
370 } elsif (defined($x->{PROPERTIES}->{case})) {
371 $t->{CASE} = "case $x->{PROPERTIES}->{case}";
373 die("Union element $x->{NAME} has neither default nor case property");
380 SWITCH_TYPE => $switch_type,
381 ELEMENTS => \@elements,
382 PROPERTIES => $e->{PROPERTIES},
393 BASE_TYPE => Parse::Pidl::Typelist::enum_type_fn($e),
394 ELEMENTS => $e->{ELEMENTS},
395 PROPERTIES => $e->{PROPERTIES},
406 BASE_TYPE => Parse::Pidl::Typelist::bitmap_type_fn($e),
407 ELEMENTS => $e->{ELEMENTS},
408 PROPERTIES => $e->{PROPERTIES},
418 if ($d->{DATA}->{TYPE} eq "STRUCT" or $d->{DATA}->{TYPE} eq "UNION") {
419 CheckPointerTypes($d->{DATA}, $ndr->{PROPERTIES}->{pointer_default});
422 if (defined($d->{PROPERTIES}) && !defined($d->{DATA}->{PROPERTIES})) {
423 $d->{DATA}->{PROPERTIES} = $d->{PROPERTIES};
427 STRUCT => \&ParseStruct,
428 UNION => \&ParseUnion,
430 BITMAP => \&ParseBitmap
431 }->{$d->{DATA}->{TYPE}}->($d->{DATA});
433 $data->{ALIGN} = align_type($d->{NAME});
438 PROPERTIES => $d->{PROPERTIES},
451 sub ParseFunction($$$)
453 my ($ndr,$d,$opnum) = @_;
456 my $thisopnum = undef;
458 CheckPointerTypes($d, $ndr->{PROPERTIES}->{pointer_default_top});
460 if (not defined($d->{PROPERTIES}{noopnum})) {
461 $thisopnum = ${$opnum};
465 foreach my $x (@{$d->{ELEMENTS}}) {
466 my $e = ParseElement($x);
467 push (@{$e->{DIRECTION}}, "in") if (has_property($x, "in"));
468 push (@{$e->{DIRECTION}}, "out") if (has_property($x, "out"));
469 push (@elements, $e);
472 if ($d->{RETURN_TYPE} ne "void") {
473 $rettype = $d->{RETURN_TYPE};
480 RETURN_TYPE => $rettype,
481 PROPERTIES => $d->{PROPERTIES},
482 ELEMENTS => \@elements,
487 sub CheckPointerTypes($$)
492 foreach my $e (@{$s->{ELEMENTS}}) {
493 if ($e->{POINTERS} and not defined(pointer_type($e))) {
494 $e->{PROPERTIES}->{$default} = 1;
499 sub ParseInterface($)
510 if (not has_property($idl, "pointer_default")) {
511 # MIDL defaults to "ptr" in DCE compatible mode (/osf)
512 # and "unique" in Microsoft Extensions mode (default)
513 $idl->{PROPERTIES}->{pointer_default} = "unique";
516 if (not has_property($idl, "pointer_default_top")) {
517 $idl->{PROPERTIES}->{pointer_default_top} = "ref";
520 foreach my $d (@{$idl->{DATA}}) {
521 if ($d->{TYPE} eq "TYPEDEF") {
522 push (@typedefs, ParseTypedef($idl, $d));
525 if ($d->{TYPE} eq "DECLARE") {
526 push (@declares, $d);
529 if ($d->{TYPE} eq "FUNCTION") {
530 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 => 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
567 # NDR parsers / generators
573 push(@ndr, ParseInterface($_)) foreach (@{$idl});
585 foreach my $l (@{$e->{LEVELS}}) {
586 return $l if ($seen);
587 ($seen = 1) if ($l == $fl);
598 foreach my $l (@{$e->{LEVELS}}) {
599 (return $prev) if ($l == $fl);
606 sub ContainsDeferred($$)
610 return 1 if ($l->{CONTAINS_DEFERRED});
612 while ($l = GetNextLevel($e,$l))
614 return 1 if ($l->{IS_DEFERRED});
615 return 1 if ($l->{CONTAINS_DEFERRED});
625 if ($e->{PARENT} && $e->{PARENT}->{NAME}) {
626 return "$e->{PARENT}->{NAME}.$e->{NAME}";
629 if ($e->{PARENT} && $e->{PARENT}->{PARENT}->{NAME}) {
630 return "$e->{PARENT}->{PARENT}->{NAME}.$e->{NAME}";
634 return "$e->{PARENT}->{NAME}.$e->{NAME}";
640 ###################################
641 # find a sibling var in a structure
645 my($fn) = $e->{PARENT};
647 if ($name =~ /\*(.*)/) {
651 for my $e2 (@{$fn->{ELEMENTS}}) {
652 return $e2 if ($e2->{NAME} eq $name);
658 my %property_list = (
660 "helpstring" => ["INTERFACE", "FUNCTION"],
661 "version" => ["INTERFACE"],
662 "uuid" => ["INTERFACE"],
663 "endpoint" => ["INTERFACE"],
664 "pointer_default" => ["INTERFACE"],
665 "pointer_default_top" => ["INTERFACE"],
666 "depends" => ["INTERFACE"],
667 "authservice" => ["INTERFACE"],
670 "object" => ["INTERFACE"],
671 "local" => ["INTERFACE", "FUNCTION"],
672 "iid_is" => ["ELEMENT"],
673 "call_as" => ["FUNCTION"],
674 "idempotent" => ["FUNCTION"],
677 "noopnum" => ["FUNCTION"],
679 "out" => ["ELEMENT"],
682 "ref" => ["ELEMENT"],
683 "ptr" => ["ELEMENT"],
684 "sptr" => ["ELEMENT"],
685 "unique" => ["ELEMENT"],
686 "ignore" => ["ELEMENT"],
687 "relative" => ["ELEMENT"],
688 "relative_base" => ["TYPEDEF"],
690 "gensize" => ["TYPEDEF"],
691 "value" => ["ELEMENT"],
692 "flag" => ["ELEMENT", "TYPEDEF"],
695 "public" => ["FUNCTION", "TYPEDEF"],
696 "nopush" => ["FUNCTION", "TYPEDEF"],
697 "nopull" => ["FUNCTION", "TYPEDEF"],
698 "noprint" => ["FUNCTION", "TYPEDEF"],
699 "noejs" => ["FUNCTION", "TYPEDEF"],
702 "switch_is" => ["ELEMENT"],
703 "switch_type" => ["ELEMENT", "TYPEDEF"],
704 "nodiscriminant" => ["TYPEDEF"],
705 "case" => ["ELEMENT"],
706 "default" => ["ELEMENT"],
709 "subcontext" => ["ELEMENT"],
710 "subcontext_size" => ["ELEMENT"],
711 "compression" => ["ELEMENT"],
712 "obfuscation" => ["ELEMENT"],
715 "enum8bit" => ["TYPEDEF"],
716 "enum16bit" => ["TYPEDEF"],
717 "v1_enum" => ["TYPEDEF"],
720 "bitmap8bit" => ["TYPEDEF"],
721 "bitmap16bit" => ["TYPEDEF"],
722 "bitmap32bit" => ["TYPEDEF"],
723 "bitmap64bit" => ["TYPEDEF"],
726 "range" => ["ELEMENT"],
727 "size_is" => ["ELEMENT"],
728 "string" => ["ELEMENT"],
729 "noheader" => ["ELEMENT"],
730 "charset" => ["ELEMENT"],
731 "length_is" => ["ELEMENT"],
734 #####################################################################
735 # check for unknown properties
736 sub ValidProperties($$)
740 return unless defined $e->{PROPERTIES};
742 foreach my $key (keys %{$e->{PROPERTIES}}) {
743 fatal($e, el_name($e) . ": unknown property '$key'\n")
744 unless defined($property_list{$key});
746 fatal($e, el_name($e) . ": property '$key' not allowed on '$t'\n")
747 unless grep($t, @{$property_list{$key}});
754 my $ti = getType($t);
756 if (not defined ($ti)) {
758 } elsif ($ti->{DATA}->{TYPE} eq "ENUM") {
759 return Parse::Pidl::Typelist::enum_type_fn($ti->{DATA});
760 } elsif ($ti->{DATA}->{TYPE} eq "BITMAP") {
761 return Parse::Pidl::Typelist::enum_type_fn($ti->{DATA});
762 } elsif ($ti->{DATA}->{TYPE} eq "SCALAR") {
769 #####################################################################
775 ValidProperties($e,"ELEMENT");
777 if (has_property($e, "ptr")) {
778 fatal($e, el_name($e) . " : pidl does not support full NDR pointers yet\n");
781 # Check whether switches are used correctly.
782 if (my $switch = has_property($e, "switch_is")) {
783 my $e2 = find_sibling($e, $switch);
784 my $type = getType($e->{TYPE});
786 if (defined($type) and $type->{DATA}->{TYPE} ne "UNION") {
787 fatal($e, el_name($e) . ": switch_is() used on non-union type $e->{TYPE} which is a $type->{DATA}->{TYPE}");
790 if (!has_property($type, "nodiscriminant") and defined($e2)) {
791 my $discriminator_type = has_property($type, "switch_type");
792 $discriminator_type = "uint32" unless defined ($discriminator_type);
794 my $t1 = mapToScalar($discriminator_type);
796 if (not defined($t1)) {
797 fatal($e, el_name($e) . ": unable to map discriminator type '$discriminator_type' to scalar");
800 my $t2 = mapToScalar($e2->{TYPE});
801 if (not defined($t2)) {
802 fatal($e, el_name($e) . ": unable to map variable used for switch_is() to scalar");
806 nonfatal($e, el_name($e) . ": switch_is() is of type $e2->{TYPE} ($t2), while discriminator type for union $type->{NAME} is $discriminator_type ($t1)");
811 if (defined (has_property($e, "subcontext_size")) and not defined(has_property($e, "subcontext"))) {
812 fatal($e, el_name($e) . " : subcontext_size() on non-subcontext element");
815 if (defined (has_property($e, "compression")) and not defined(has_property($e, "subcontext"))) {
816 fatal($e, el_name($e) . " : compression() on non-subcontext element");
819 if (defined (has_property($e, "obfuscation")) and not defined(has_property($e, "subcontext"))) {
820 fatal($e, el_name($e) . " : obfuscation() on non-subcontext element");
823 if (!$e->{POINTERS} && (
824 has_property($e, "ptr") or
825 has_property($e, "sptr") or
826 has_property($e, "unique") or
827 has_property($e, "relative") or
828 has_property($e, "ref"))) {
829 fatal($e, el_name($e) . " : pointer properties on non-pointer element\n");
833 #####################################################################
839 ValidProperties($struct,"STRUCT");
841 foreach my $e (@{$struct->{ELEMENTS}}) {
842 $e->{PARENT} = $struct;
847 #####################################################################
853 ValidProperties($union,"UNION");
855 if (has_property($union->{PARENT}, "nodiscriminant") and has_property($union->{PARENT}, "switch_type")) {
856 fatal($union->{PARENT}, $union->{PARENT}->{NAME} . ": switch_type() on union without discriminant");
859 foreach my $e (@{$union->{ELEMENTS}}) {
860 $e->{PARENT} = $union;
862 if (defined($e->{PROPERTIES}->{default}) and
863 defined($e->{PROPERTIES}->{case})) {
864 fatal $e, "Union member $e->{NAME} can not have both default and case properties!\n";
867 unless (defined ($e->{PROPERTIES}->{default}) or
868 defined ($e->{PROPERTIES}->{case})) {
869 fatal $e, "Union member $e->{NAME} must have default or case property\n";
872 if (has_property($e, "ref")) {
873 fatal($e, el_name($e) . " : embedded ref pointers are not supported yet\n");
881 #####################################################################
885 my($typedef) = shift;
886 my $data = $typedef->{DATA};
888 ValidProperties($typedef,"TYPEDEF");
890 $data->{PARENT} = $typedef;
892 if (ref($data) eq "HASH") {
893 if ($data->{TYPE} eq "STRUCT") {
897 if ($data->{TYPE} eq "UNION") {
903 #####################################################################
909 ValidProperties($fn,"FUNCTION");
911 foreach my $e (@{$fn->{ELEMENTS}}) {
913 if (has_property($e, "ref") && !$e->{POINTERS}) {
914 fatal $e, "[ref] variables must be pointers ($fn->{NAME}/$e->{NAME})\n";
920 #####################################################################
921 # parse the interface definitions
922 sub ValidInterface($)
924 my($interface) = shift;
925 my($data) = $interface->{DATA};
927 ValidProperties($interface,"INTERFACE");
929 if (has_property($interface, "pointer_default") &&
930 $interface->{PROPERTIES}->{pointer_default} eq "ptr") {
931 fatal $interface, "Full pointers are not supported yet\n";
934 if (has_property($interface, "object")) {
935 if (has_property($interface, "version") &&
936 $interface->{PROPERTIES}->{version} != 0) {
937 fatal $interface, "Object interfaces must have version 0.0 ($interface->{NAME})\n";
940 if (!defined($interface->{BASE}) &&
941 not ($interface->{NAME} eq "IUnknown")) {
942 fatal $interface, "Object interfaces must all derive from IUnknown ($interface->{NAME})\n";
946 foreach my $d (@{$data}) {
947 ($d->{TYPE} eq "TYPEDEF") &&
949 ($d->{TYPE} eq "FUNCTION") &&
955 #####################################################################
956 # Validate an IDL structure
961 foreach my $x (@{$idl}) {
962 ($x->{TYPE} eq "INTERFACE") &&