r9460: - Move pidl to lib/. This fixes standalone installation of pidl.

- Update the README
- Allow building the docs stand-alone
(This used to be commit b56084ce251ab7a35dd1422f38de258e8e1e1477)

1 files changed, 967 insertions, 0 deletions

diff --git a/source4/pidl/lib/Parse/Pidl/NDR.pm b/source4/pidl/lib/Parse/Pidl/NDR.pm
new file mode 100644
index 0000000000..e00a0c9828
--- /dev/null
+++ b/source4/pidl/lib/Parse/Pidl/NDR.pm
@@ -0,0 +1,967 @@
+###################################################
+# Samba4 NDR info tree generator
+# Copyright tridge@samba.org 2000-2003
+# Copyright tpot@samba.org 2001
+# Copyright jelmer@samba.org 2004-2005
+# released under the GNU GPL
+
+package Parse::Pidl::NDR;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT = qw(GetPrevLevel GetNextLevel ContainsDeferred);
+
+use strict;
+use Parse::Pidl::Typelist qw(hasType getType);
+use Parse::Pidl::Util qw(has_property property_matches);
+
+sub nonfatal($$)
+{
+	my ($e,$s) = @_;
+	warn ("$e->{FILE}:$e->{LINE}: Warning: $s\n");
+}
+
+#####################################################################
+# signal a fatal validation error
+sub fatal($$)
+{
+	my ($pos,$s) = @_;
+	die("$pos->{FILE}:$pos->{LINE}:$s\n");
+}
+
+#####################################################################
+# return a table describing the order in which the parts of an element
+# should be parsed
+# Possible level types:
+#  - POINTER
+#  - ARRAY
+#  - SUBCONTEXT
+#  - SWITCH
+#  - DATA
+sub GetElementLevelTable($)
+{
+	my $e = shift;
+
+	my $order = [];
+	my $is_deferred = 0;
+	my @bracket_array = ();
+	my @length_is = ();
+	my @size_is = ();
+
+	if (has_property($e, "size_is")) {
+		@size_is = split /,/, has_property($e, "size_is");
+	}
+
+	if (has_property($e, "length_is")) {
+		@length_is = split /,/, has_property($e, "length_is");
+	}
+
+	if (defined($e->{ARRAY_LEN})) {
+		@bracket_array = @{$e->{ARRAY_LEN}};
+	}
+	
+	# Parse the [][][][] style array stuff
+	foreach my $d (@bracket_array) {
+		my $size = $d;
+		my $length = $d;
+		my $is_surrounding = 0;
+		my $is_varying = 0;
+		my $is_conformant = 0;
+		my $is_string = 0;
+
+		if ($d eq "*") {
+			$is_conformant = 1;
+			if ($size = shift @size_is) {
+			} elsif ((scalar(@size_is) == 0) and has_property($e, "string")) {
+				$is_string = 1;
+				delete($e->{PROPERTIES}->{string});
+			} else {
+				print "$e->{FILE}:$e->{LINE}: Must specify size_is() for conformant array!\n";
+				exit 1;
+			}
+
+			if (($length = shift @length_is) or $is_string) {
+				$is_varying = 1;
+			} else {
+				$length = $size;
+			}
+
+			if ($e == $e->{PARENT}->{ELEMENTS}[-1] 
+				and $e->{PARENT}->{TYPE} ne "FUNCTION") {
+				$is_surrounding = 1;
+			}
+		}
+
+		push (@$order, {
+			TYPE => "ARRAY",
+			SIZE_IS => $size,
+			LENGTH_IS => $length,
+			IS_DEFERRED => "$is_deferred",
+			IS_SURROUNDING => "$is_surrounding",
+			IS_ZERO_TERMINATED => "$is_string",
+			IS_VARYING => "$is_varying",
+			IS_CONFORMANT => "$is_conformant",
+			IS_FIXED => (not $is_conformant and Parse::Pidl::Util::is_constant($size)),
+			IS_INLINE => (not $is_conformant and not Parse::Pidl::Util::is_constant($size))
+		});
+	}
+
+	# Next, all the pointers
+	foreach my $i (1..$e->{POINTERS}) {
+		my $pt = pointer_type($e);
+
+		my $level = "EMBEDDED";
+		# Top level "ref" pointers do not have a referrent identifier
+		$level = "TOP" if ( defined($pt) 
+				and $i == 1
+				and $e->{PARENT}->{TYPE} eq "FUNCTION");
+
+		push (@$order, { 
+			TYPE => "POINTER",
+			# for now, there can only be one pointer type per element
+			POINTER_TYPE => pointer_type($e),
+			IS_DEFERRED => "$is_deferred",
+			LEVEL => $level
+		});
+		
+		# everything that follows will be deferred
+		$is_deferred = 1 if ($e->{PARENT}->{TYPE} ne "FUNCTION");
+
+		my $array_size = shift @size_is;
+		my $array_length;
+		my $is_varying;
+		my $is_conformant;
+		my $is_string = 0;
+		if ($array_size) {
+			$is_conformant = 1;
+			if ($array_length = shift @length_is) {
+				$is_varying = 1;
+			} else {
+				$array_length = $array_size;
+				$is_varying =0;
+			}
+		} 
+		
+		if (scalar(@size_is) == 0 and has_property($e, "string")) {
+			$is_string = 1;
+			$is_varying = $is_conformant = has_property($e, "noheader")?0:1;
+			delete($e->{PROPERTIES}->{string});
+		}
+
+		if ($array_size or $is_string) {
+			push (@$order, {
+				TYPE => "ARRAY",
+				IS_ZERO_TERMINATED => "$is_string",
+				SIZE_IS => $array_size,
+				LENGTH_IS => $array_length,
+				IS_DEFERRED => "$is_deferred",
+				IS_SURROUNDING => 0,
+				IS_VARYING => "$is_varying",
+				IS_CONFORMANT => "$is_conformant",
+				IS_FIXED => 0,
+				IS_INLINE => 0,
+			});
+
+			$is_deferred = 0;
+		} 
+	}
+
+	if (defined(has_property($e, "subcontext"))) {
+		my $hdr_size = has_property($e, "subcontext");
+		my $subsize = has_property($e, "subcontext_size");
+		if (not defined($subsize)) { 
+			$subsize = -1; 
+		}
+		
+		push (@$order, {
+			TYPE => "SUBCONTEXT",
+			HEADER_SIZE => $hdr_size,
+			SUBCONTEXT_SIZE => $subsize,
+			IS_DEFERRED => $is_deferred,
+			COMPRESSION => has_property($e, "compression"),
+			OBFUSCATION => has_property($e, "obfuscation")
+		});
+	}
+
+	if (my $switch = has_property($e, "switch_is")) {
+		push (@$order, {
+			TYPE => "SWITCH", 
+			SWITCH_IS => $switch,
+			IS_DEFERRED => $is_deferred
+		});
+	}
+
+	if (scalar(@size_is) > 0) {
+		nonfatal($e, "size_is() on non-array element");
+	}
+
+	if (scalar(@length_is) > 0) {
+		nonfatal($e, "length_is() on non-array element");
+	}
+
+	if (has_property($e, "string")) {
+		nonfatal($e, "string() attribute on non-array element");
+	}
+
+	push (@$order, {
+		TYPE => "DATA",
+		DATA_TYPE => $e->{TYPE},
+		IS_DEFERRED => $is_deferred,
+		CONTAINS_DEFERRED => can_contain_deferred($e),
+		IS_SURROUNDING => 0 #FIXME
+	});
+
+	my $i = 0;
+	foreach (@$order) { $_->{LEVEL_INDEX} = $i; $i+=1; }
+
+	return $order;
+}
+
+#####################################################################
+# see if a type contains any deferred data 
+sub can_contain_deferred
+{
+	my $e = shift;
+
+	return 0 if (Parse::Pidl::Typelist::is_scalar($e->{TYPE}));
+	return 1 unless (hasType($e->{TYPE})); # assume the worst
+
+	my $type = getType($e->{TYPE});
+
+	foreach my $x (@{$type->{DATA}->{ELEMENTS}}) {
+		return 1 if ($x->{POINTERS});
+		return 1 if (can_contain_deferred ($x));
+	}
+	
+	return 0;
+}
+
+sub pointer_type($)
+{
+	my $e = shift;
+
+	return undef unless $e->{POINTERS};
+	
+	return "ref" if (has_property($e, "ref"));
+	return "ptr" if (has_property($e, "ptr"));
+	return "sptr" if (has_property($e, "sptr"));
+	return "unique" if (has_property($e, "unique"));
+	return "relative" if (has_property($e, "relative"));
+	return "ignore" if (has_property($e, "ignore"));
+
+	return undef;
+}
+
+#####################################################################
+# work out the correct alignment for a structure or union
+sub find_largest_alignment($)
+{
+	my $s = shift;
+
+	my $align = 1;
+	for my $e (@{$s->{ELEMENTS}}) {
+		my $a = 1;
+
+		if ($e->{POINTERS}) {
+			$a = 4; 
+		} elsif (has_property($e, "subcontext")){ 
+			$a = 1;
+		} else {
+			$a = align_type($e->{TYPE}); 
+		}
+
+		$align = $a if ($align < $a);
+	}
+
+	return $align;
+}
+
+#####################################################################
+# align a type
+sub align_type
+{
+	my $e = shift;
+
+	unless (hasType($e)) {
+	    # it must be an external type - all we can do is guess 
+		# print "Warning: assuming alignment of unknown type '$e' is 4\n";
+	    return 4;
+	}
+
+	my $dt = getType($e)->{DATA};
+
+	if ($dt->{TYPE} eq "ENUM") {
+		return align_type(Parse::Pidl::Typelist::enum_type_fn($dt));
+	} elsif ($dt->{TYPE} eq "BITMAP") {
+		return align_type(Parse::Pidl::Typelist::bitmap_type_fn($dt));
+	} elsif (($dt->{TYPE} eq "STRUCT") or ($dt->{TYPE} eq "UNION")) {
+		return find_largest_alignment($dt);
+	} elsif ($dt->{TYPE} eq "SCALAR") {
+		return Parse::Pidl::Typelist::getScalarAlignment($dt->{NAME});
+	}
+
+	die("Unknown data type type $dt->{TYPE}");
+}
+
+sub ParseElement($)
+{
+	my $e = shift;
+
+	return {
+		NAME => $e->{NAME},
+		TYPE => $e->{TYPE},
+		PROPERTIES => $e->{PROPERTIES},
+		LEVELS => GetElementLevelTable($e),
+		ALIGN => align_type($e->{TYPE}),
+		ORIGINAL => $e
+	};
+}
+
+sub ParseStruct($)
+{
+	my $struct = shift;
+	my @elements = ();
+	my $surrounding = undef;
+
+	foreach my $x (@{$struct->{ELEMENTS}}) 
+	{
+		push @elements, ParseElement($x);
+	}
+
+	my $e = $elements[-1];
+	if (defined($e) and defined($e->{LEVELS}[0]->{IS_SURROUNDING}) and
+		$e->{LEVELS}[0]->{IS_SURROUNDING}) {
+		$surrounding = $e;
+	}
+
+	if (defined $e->{TYPE} && $e->{TYPE} eq "string"
+	    &&  property_matches($e, "flag", ".*LIBNDR_FLAG_STR_CONFORMANT.*")) {
+		$surrounding = $struct->{ELEMENTS}[-1];
+	}
+		
+	return {
+		TYPE => "STRUCT",
+		SURROUNDING_ELEMENT => $surrounding,
+		ELEMENTS => \@elements,
+		PROPERTIES => $struct->{PROPERTIES},
+		ORIGINAL => $struct
+	};
+}
+
+sub ParseUnion($)
+{
+	my $e = shift;
+	my @elements = ();
+	my $switch_type = has_property($e, "switch_type");
+	unless (defined($switch_type)) { $switch_type = "uint32"; }
+
+	if (has_property($e, "nodiscriminant")) { $switch_type = undef; }
+	
+	foreach my $x (@{$e->{ELEMENTS}}) 
+	{
+		my $t;
+		if ($x->{TYPE} eq "EMPTY") {
+			$t = { TYPE => "EMPTY" };
+		} else {
+			$t = ParseElement($x);
+		}
+		if (has_property($x, "default")) {
+			$t->{CASE} = "default";
+		} elsif (defined($x->{PROPERTIES}->{case})) {
+			$t->{CASE} = "case $x->{PROPERTIES}->{case}";
+		} else {
+			die("Union element $x->{NAME} has neither default nor case property");
+		}
+		push @elements, $t;
+	}
+
+	return {
+		TYPE => "UNION",
+		SWITCH_TYPE => $switch_type,
+		ELEMENTS => \@elements,
+		PROPERTIES => $e->{PROPERTIES},
+		ORIGINAL => $e
+	};
+}
+
+sub ParseEnum($)
+{
+	my $e = shift;
+
+	return {
+		TYPE => "ENUM",
+		BASE_TYPE => Parse::Pidl::Typelist::enum_type_fn($e),
+		ELEMENTS => $e->{ELEMENTS},
+		PROPERTIES => $e->{PROPERTIES},
+		ORIGINAL => $e
+	};
+}
+
+sub ParseBitmap($)
+{
+	my $e = shift;
+
+	return {
+		TYPE => "BITMAP",
+		BASE_TYPE => Parse::Pidl::Typelist::bitmap_type_fn($e),
+		ELEMENTS => $e->{ELEMENTS},
+		PROPERTIES => $e->{PROPERTIES},
+		ORIGINAL => $e
+	};
+}
+
+sub ParseTypedef($$)
+{
+	my ($ndr,$d) = @_;
+	my $data;
+
+	if ($d->{DATA}->{TYPE} eq "STRUCT" or $d->{DATA}->{TYPE} eq "UNION") {
+		CheckPointerTypes($d->{DATA}, $ndr->{PROPERTIES}->{pointer_default});
+	}
+
+	if (defined($d->{PROPERTIES}) && !defined($d->{DATA}->{PROPERTIES})) {
+		$d->{DATA}->{PROPERTIES} = $d->{PROPERTIES};
+	}
+
+	$data = {
+		STRUCT => \&ParseStruct,
+		UNION => \&ParseUnion,
+		ENUM => \&ParseEnum,
+		BITMAP => \&ParseBitmap
+	}->{$d->{DATA}->{TYPE}}->($d->{DATA});
+
+	$data->{ALIGN} = align_type($d->{NAME});
+
+	return {
+		NAME => $d->{NAME},
+		TYPE => $d->{TYPE},
+		PROPERTIES => $d->{PROPERTIES},
+		DATA => $data,
+		ORIGINAL => $d
+	};
+}
+
+sub ParseConst($$)
+{
+	my ($ndr,$d) = @_;
+
+	return $d;
+}
+
+sub ParseFunction($$$)
+{
+	my ($ndr,$d,$opnum) = @_;
+	my @elements = ();
+	my $rettype = undef;
+	my $thisopnum = undef;
+
+	CheckPointerTypes($d, $ndr->{PROPERTIES}->{pointer_default_top});
+
+	if (not defined($d->{PROPERTIES}{noopnum})) {
+		$thisopnum = ${$opnum};
+		${$opnum}++;
+	}
+
+	foreach my $x (@{$d->{ELEMENTS}}) {
+		my $e = ParseElement($x);
+		push (@{$e->{DIRECTION}}, "in") if (has_property($x, "in"));
+		push (@{$e->{DIRECTION}}, "out") if (has_property($x, "out"));
+		push (@elements, $e);
+	}
+
+	if ($d->{RETURN_TYPE} ne "void") {
+		$rettype = $d->{RETURN_TYPE};
+	}
+	
+	return {
+			NAME => $d->{NAME},
+			TYPE => "FUNCTION",
+			OPNUM => $thisopnum,
+			RETURN_TYPE => $rettype,
+			PROPERTIES => $d->{PROPERTIES},
+			ELEMENTS => \@elements,
+			ORIGINAL => $d
+		};
+}
+
+sub CheckPointerTypes($$)
+{
+	my $s = shift;
+	my $default = shift;
+
+	foreach my $e (@{$s->{ELEMENTS}}) {
+		if ($e->{POINTERS} and not defined(pointer_type($e))) {
+			$e->{PROPERTIES}->{$default} = 1;
+		}
+	}
+}
+
+sub ParseInterface($)
+{
+	my $idl = shift;
+	my @typedefs = ();
+	my @consts = ();
+	my @functions = ();
+	my @endpoints;
+	my @declares = ();
+	my $opnum = 0;
+	my $version;
+
+	if (not has_property($idl, "pointer_default")) {
+		# MIDL defaults to "ptr" in DCE compatible mode (/osf)
+		# and "unique" in Microsoft Extensions mode (default)
+		$idl->{PROPERTIES}->{pointer_default} = "unique";
+	}
+
+	if (not has_property($idl, "pointer_default_top")) {
+		$idl->{PROPERTIES}->{pointer_default_top} = "ref";
+	}
+
+	foreach my $d (@{$idl->{DATA}}) {
+		if ($d->{TYPE} eq "TYPEDEF") {
+			push (@typedefs, ParseTypedef($idl, $d));
+		}
+
+		if ($d->{TYPE} eq "DECLARE") {
+			push (@declares, $d);
+		}
+
+		if ($d->{TYPE} eq "FUNCTION") {
+			push (@functions, ParseFunction($idl, $d, \$opnum));
+		}
+
+		if ($d->{TYPE} eq "CONST") {
+			push (@consts, ParseConst($idl, $d));
+		}
+	}
+
+	$version = "0.0";
+
+	if(defined $idl->{PROPERTIES}->{version}) { 
+		$version = $idl->{PROPERTIES}->{version}; 
+	}
+
+	# If no endpoint is set, default to the interface name as a named pipe
+	if (!defined $idl->{PROPERTIES}->{endpoint}) {
+		push @endpoints, "\"ncacn_np:[\\\\pipe\\\\" . $idl->{NAME} . "]\"";
+	} else {
+		@endpoints = split / /, $idl->{PROPERTIES}->{endpoint};
+	}
+
+	return { 
+		NAME => $idl->{NAME},
+		UUID => has_property($idl, "uuid"),
+		VERSION => $version,
+		TYPE => "INTERFACE",
+		PROPERTIES => $idl->{PROPERTIES},
+		FUNCTIONS => \@functions,
+		CONSTS => \@consts,
+		TYPEDEFS => \@typedefs,
+		DECLARES => \@declares,
+		ENDPOINTS => \@endpoints
+	};
+}
+
+# Convert a IDL tree to a NDR tree
+# Gives a result tree describing all that's necessary for easily generating
+# NDR parsers / generators
+sub Parse($)
+{
+	my $idl = shift;
+	my @ndr = ();
+
+	push(@ndr, ParseInterface($_)) foreach (@{$idl});
+
+	return \@ndr;
+}
+
+sub GetNextLevel($$)
+{
+	my $e = shift;
+	my $fl = shift;
+
+	my $seen = 0;
+
+	foreach my $l (@{$e->{LEVELS}}) {
+		return $l if ($seen);
+		($seen = 1) if ($l == $fl);
+	}
+
+	return undef;
+}
+
+sub GetPrevLevel($$)
+{
+	my ($e,$fl) = @_;
+	my $prev = undef;
+
+	foreach my $l (@{$e->{LEVELS}}) {
+		(return $prev) if ($l == $fl);
+		$prev = $l;
+	}
+
+	return undef;
+}
+
+sub ContainsDeferred($$)
+{
+	my ($e,$l) = @_;
+
+	return 1 if ($l->{CONTAINS_DEFERRED});
+
+	while ($l = GetNextLevel($e,$l))
+	{
+		return 1 if ($l->{IS_DEFERRED}); 
+		return 1 if ($l->{CONTAINS_DEFERRED});
+	} 
+	
+	return 0;
+}
+
+sub el_name($)
+{
+	my $e = shift;
+
+	if ($e->{PARENT} && $e->{PARENT}->{NAME}) {
+		return "$e->{PARENT}->{NAME}.$e->{NAME}";
+	}
+
+	if ($e->{PARENT} && $e->{PARENT}->{PARENT}->{NAME}) {
+		return "$e->{PARENT}->{PARENT}->{NAME}.$e->{NAME}";
+	}
+
+	if ($e->{PARENT}) {
+		return "$e->{PARENT}->{NAME}.$e->{NAME}";
+	}
+
+	return $e->{NAME};
+}
+
+###################################
+# find a sibling var in a structure
+sub find_sibling($$)
+{
+	my($e,$name) = @_;
+	my($fn) = $e->{PARENT};
+
+	if ($name =~ /\*(.*)/) {
+		$name = $1;
+	}
+
+	for my $e2 (@{$fn->{ELEMENTS}}) {
+		return $e2 if ($e2->{NAME} eq $name);
+	}
+
+	return undef;
+}
+
+my %property_list = (
+	# interface
+	"helpstring"		=> ["INTERFACE", "FUNCTION"],
+	"version"		=> ["INTERFACE"],
+	"uuid"			=> ["INTERFACE"],
+	"endpoint"		=> ["INTERFACE"],
+	"pointer_default"	=> ["INTERFACE"],
+	"pointer_default_top"	=> ["INTERFACE"],
+	"depends"		=> ["INTERFACE"],
+	"authservice"		=> ["INTERFACE"],
+
+	# dcom
+	"object"		=> ["INTERFACE"],
+	"local"			=> ["INTERFACE", "FUNCTION"],
+	"iid_is"		=> ["ELEMENT"],
+	"call_as"		=> ["FUNCTION"],
+	"idempotent"		=> ["FUNCTION"],
+
+	# function
+	"noopnum"		=> ["FUNCTION"],
+	"in"			=> ["ELEMENT"],
+	"out"			=> ["ELEMENT"],
+
+	# pointer
+	"ref"			=> ["ELEMENT"],
+	"ptr"			=> ["ELEMENT"],
+	"sptr"			=> ["ELEMENT"],
+	"unique"		=> ["ELEMENT"],
+	"ignore"		=> ["ELEMENT"],
+	"relative"		=> ["ELEMENT"],
+	"relative_base"		=> ["TYPEDEF"],
+
+	"gensize"		=> ["TYPEDEF"],
+	"value"			=> ["ELEMENT"],
+	"flag"			=> ["ELEMENT", "TYPEDEF"],
+
+	# generic
+	"public"		=> ["FUNCTION", "TYPEDEF"],
+	"nopush"		=> ["FUNCTION", "TYPEDEF"],
+	"nopull"		=> ["FUNCTION", "TYPEDEF"],
+	"noprint"		=> ["FUNCTION", "TYPEDEF"],
+	"noejs"			=> ["FUNCTION", "TYPEDEF"],
+
+	# union
+	"switch_is"		=> ["ELEMENT"],
+	"switch_type"		=> ["ELEMENT", "TYPEDEF"],
+	"nodiscriminant"	=> ["TYPEDEF"],
+	"case"			=> ["ELEMENT"],
+	"default"		=> ["ELEMENT"],
+
+	# subcontext
+	"subcontext"		=> ["ELEMENT"],
+	"subcontext_size"	=> ["ELEMENT"],
+	"compression"		=> ["ELEMENT"],
+	"obfuscation"		=> ["ELEMENT"],
+
+	# enum
+	"enum8bit"		=> ["TYPEDEF"],
+	"enum16bit"		=> ["TYPEDEF"],
+	"v1_enum"		=> ["TYPEDEF"],
+
+	# bitmap
+	"bitmap8bit"		=> ["TYPEDEF"],
+	"bitmap16bit"		=> ["TYPEDEF"],
+	"bitmap32bit"		=> ["TYPEDEF"],
+	"bitmap64bit"		=> ["TYPEDEF"],
+
+	# array
+	"range"			=> ["ELEMENT"],
+	"size_is"		=> ["ELEMENT"],
+	"string"		=> ["ELEMENT"],
+	"noheader"		=> ["ELEMENT"],
+	"charset"		=> ["ELEMENT"],
+	"length_is"		=> ["ELEMENT"],
+);
+
+#####################################################################
+# check for unknown properties
+sub ValidProperties($$)
+{
+	my ($e,$t) = @_;
+
+	return unless defined $e->{PROPERTIES};
+
+	foreach my $key (keys %{$e->{PROPERTIES}}) {
+		fatal($e, el_name($e) . ": unknown property '$key'\n")
+			unless defined($property_list{$key});
+
+   		fatal($e, el_name($e) . ": property '$key' not allowed on '$t'\n")
+			unless grep($t, @{$property_list{$key}});
+	}
+}
+
+sub mapToScalar($)
+{
+	my $t = shift;
+	my $ti = getType($t);
+
+	if (not defined ($ti)) {
+		return undef;
+	} elsif ($ti->{DATA}->{TYPE} eq "ENUM") {
+		return Parse::Pidl::Typelist::enum_type_fn($ti->{DATA});
+	} elsif ($ti->{DATA}->{TYPE} eq "BITMAP") {
+		return Parse::Pidl::Typelist::enum_type_fn($ti->{DATA});
+	} elsif ($ti->{DATA}->{TYPE} eq "SCALAR") {
+		return $t;
+	}
+
+	return undef;
+}
+
+#####################################################################
+# parse a struct
+sub ValidElement($)
+{
+	my $e = shift;
+
+	ValidProperties($e,"ELEMENT");
+
+	if (has_property($e, "ptr")) {
+		fatal($e, el_name($e) . " : pidl does not support full NDR pointers yet\n");
+	}
+
+	# Check whether switches are used correctly.
+	if (my $switch = has_property($e, "switch_is")) {
+		my $e2 = find_sibling($e, $switch);
+		my $type = getType($e->{TYPE});
+
+		if (defined($type) and $type->{DATA}->{TYPE} ne "UNION") {
+			fatal($e, el_name($e) . ": switch_is() used on non-union type $e->{TYPE} which is a $type->{DATA}->{TYPE}");
+		}
+
+		if (!has_property($type, "nodiscriminant") and defined($e2)) {
+			my $discriminator_type = has_property($type, "switch_type");
+			$discriminator_type = "uint32" unless defined ($discriminator_type);
+
+			my $t1 = mapToScalar($discriminator_type);
+
+			if (not defined($t1)) {
+				fatal($e, el_name($e) . ": unable to map discriminator type '$discriminator_type' to scalar");
+			}
+
+			my $t2 = mapToScalar($e2->{TYPE});
+			if (not defined($t2)) {
+				fatal($e, el_name($e) . ": unable to map variable used for switch_is() to scalar");
+			}
+
+			if ($t1 ne $t2) {
+				nonfatal($e, el_name($e) . ": switch_is() is of type $e2->{TYPE} ($t2), while discriminator type for union $type->{NAME} is $discriminator_type ($t1)");
+			}
+		}
+	}
+
+	if (defined (has_property($e, "subcontext_size")) and not defined(has_property($e, "subcontext"))) {
+		fatal($e, el_name($e) . " : subcontext_size() on non-subcontext element");
+	}
+
+	if (defined (has_property($e, "compression")) and not defined(has_property($e, "subcontext"))) {
+		fatal($e, el_name($e) . " : compression() on non-subcontext element");
+	}
+
+	if (defined (has_property($e, "obfuscation")) and not defined(has_property($e, "subcontext"))) {
+		fatal($e, el_name($e) . " : obfuscation() on non-subcontext element");
+	}
+
+	if (!$e->{POINTERS} && (
+		has_property($e, "ptr") or
+		has_property($e, "sptr") or
+		has_property($e, "unique") or
+		has_property($e, "relative") or
+		has_property($e, "ref"))) {
+		fatal($e, el_name($e) . " : pointer properties on non-pointer element\n");	
+	}
+}
+
+#####################################################################
+# parse a struct
+sub ValidStruct($)
+{
+	my($struct) = shift;
+
+	ValidProperties($struct,"STRUCT");
+
+	foreach my $e (@{$struct->{ELEMENTS}}) {
+		$e->{PARENT} = $struct;
+		ValidElement($e);
+	}
+}
+
+#####################################################################
+# parse a union
+sub ValidUnion($)
+{
+	my($union) = shift;
+
+	ValidProperties($union,"UNION");
+
+	if (has_property($union->{PARENT}, "nodiscriminant") and has_property($union->{PARENT}, "switch_type")) {
+		fatal($union->{PARENT}, $union->{PARENT}->{NAME} . ": switch_type() on union without discriminant");
+	}
+	
+	foreach my $e (@{$union->{ELEMENTS}}) {
+		$e->{PARENT} = $union;
+
+		if (defined($e->{PROPERTIES}->{default}) and 
+			defined($e->{PROPERTIES}->{case})) {
+			fatal $e, "Union member $e->{NAME} can not have both default and case properties!\n";
+		}
+		
+		unless (defined ($e->{PROPERTIES}->{default}) or 
+				defined ($e->{PROPERTIES}->{case})) {
+			fatal $e, "Union member $e->{NAME} must have default or case property\n";
+		}
+
+		if (has_property($e, "ref")) {
+			fatal($e, el_name($e) . " : embedded ref pointers are not supported yet\n");
+		}
+
+
+		ValidElement($e);
+	}
+}
+
+#####################################################################
+# parse a typedef
+sub ValidTypedef($)
+{
+	my($typedef) = shift;
+	my $data = $typedef->{DATA};
+
+	ValidProperties($typedef,"TYPEDEF");
+
+	$data->{PARENT} = $typedef;
+
+	if (ref($data) eq "HASH") {
+		if ($data->{TYPE} eq "STRUCT") {
+			ValidStruct($data);
+		}
+
+		if ($data->{TYPE} eq "UNION") {
+			ValidUnion($data);
+		}
+	}
+}
+
+#####################################################################
+# parse a function
+sub ValidFunction($)
+{
+	my($fn) = shift;
+
+	ValidProperties($fn,"FUNCTION");
+
+	foreach my $e (@{$fn->{ELEMENTS}}) {
+		$e->{PARENT} = $fn;
+		if (has_property($e, "ref") && !$e->{POINTERS}) {
+			fatal $e, "[ref] variables must be pointers ($fn->{NAME}/$e->{NAME})\n";
+		}
+		ValidElement($e);
+	}
+}
+
+#####################################################################
+# parse the interface definitions
+sub ValidInterface($)
+{
+	my($interface) = shift;
+	my($data) = $interface->{DATA};
+
+	ValidProperties($interface,"INTERFACE");
+
+	if (has_property($interface, "pointer_default") && 
+		$interface->{PROPERTIES}->{pointer_default} eq "ptr") {
+		fatal $interface, "Full pointers are not supported yet\n";
+	}
+
+	if (has_property($interface, "object")) {
+     		if (has_property($interface, "version") && 
+			$interface->{PROPERTIES}->{version} != 0) {
+			fatal $interface, "Object interfaces must have version 0.0 ($interface->{NAME})\n";
+		}
+
+		if (!defined($interface->{BASE}) && 
+			not ($interface->{NAME} eq "IUnknown")) {
+			fatal $interface, "Object interfaces must all derive from IUnknown ($interface->{NAME})\n";
+		}
+	}
+		
+	foreach my $d (@{$data}) {
+		($d->{TYPE} eq "TYPEDEF") &&
+		    ValidTypedef($d);
+		($d->{TYPE} eq "FUNCTION") && 
+		    ValidFunction($d);
+	}
+
+}
+
+#####################################################################
+# Validate an IDL structure
+sub Validate($)
+{
+	my($idl) = shift;
+
+	foreach my $x (@{$idl}) {
+		($x->{TYPE} eq "INTERFACE") && 
+		    ValidInterface($x);
+	}
+}
+
+1;