1 files changed, 388 insertions, 0 deletions
diff --git a/pidl/lib/Parse/Pidl/Typelist.pm b/pidl/lib/Parse/Pidl/Typelist.pm
new file mode 100644
index 0000000..31ea19e
--- /dev/null
+++ b/pidl/lib/Parse/Pidl/Typelist.pm
@@ -0,0 +1,388 @@
+###################################################
+# Samba4 parser generator for IDL structures
+# Copyright jelmer@samba.org 2005
+# released under the GNU GPL
+
+package Parse::Pidl::Typelist;
+
+require Exporter;
+@ISA = qw(Exporter);
+@EXPORT_OK = qw(hasType getType resolveType mapTypeName mapTypeSpecifier scalar_is_reference expandAlias
+	mapScalarType addType typeIs is_signed is_scalar enum_type_fn
+	bitmap_type_fn mapType typeHasBody is_fixed_size_scalar
+	is_string_type
+);
+use vars qw($VERSION);
+$VERSION = '0.01';
+
+use Parse::Pidl::Util qw(has_property);
+use strict;
+use warnings;
+
+my %types = ();
+
+my @reference_scalars = (
+	"string", "string_array", "nbt_string", "dns_string",
+	"wrepl_nbt_name", "dnsp_name", "dnsp_string",
+	"ipv4address", "ipv6address", "u16string"
+);
+
+my @non_fixed_size_scalars = (
+	"string", "string_array", "nbt_string", "dns_string",
+	"wrepl_nbt_name", "dnsp_name", "dnsp_string",
+	"u16string"
+);
+
+# a list of known scalar types
+my %scalars = (
+	"void"		=> "void",
+	"char"		=> "char",
+	"int8"		=> "int8_t",
+	"uint8"		=> "uint8_t",
+	"int16"		=> "int16_t",
+	"uint16"	=> "uint16_t",
+	"int1632"	=> "int16_t",
+	"uint1632"	=> "uint16_t",
+	"int32"		=> "int32_t",
+	"uint32"	=> "uint32_t",
+	"int3264"	=> "int32_t",
+	"uint3264"	=> "uint32_t",
+	"hyper"		=> "uint64_t",
+	"int64"		=> "int64_t",
+	"dlong"		=> "int64_t",
+	"udlong"	=> "uint64_t",
+	"udlongr"	=> "uint64_t",
+	"double"	=> "double",
+	"pointer"	=> "void*",
+	"DATA_BLOB"	=> "DATA_BLOB",
+	"string"	=> "const char *",
+	"u16string"	=> "const unsigned char *",
+	"string_array"	=> "const char **",
+	"time_t"	=> "time_t",
+	"uid_t"	        => "uid_t",
+	"gid_t"	        => "gid_t",
+	"NTTIME"	=> "NTTIME",
+	"NTTIME_1sec"	=> "NTTIME",
+	"NTTIME_hyper"	=> "NTTIME",
+	"WERROR"	=> "WERROR",
+	"HRESULT"	=> "HRESULT",
+	"NTSTATUS"	=> "NTSTATUS",
+	"COMRESULT" => "COMRESULT",
+	"dns_string"	=> "const char *",
+	"nbt_string"	=> "const char *",
+	"wrepl_nbt_name"=> "struct nbt_name *",
+	"ipv4address"	=> "const char *",
+	"ipv6address"   => "const char *",
+	"dnsp_name"	=> "const char *",
+	"dnsp_string"	=> "const char *",
+	"libndr_flags"	=> "libndr_flags",
+	"ndr_flags_type"=> "ndr_flags_type",
+);
+
+my %aliases = (
+	"error_status_t" => "uint32",
+	"boolean8" => "uint8",
+	"boolean32" => "uint32",
+	"DWORD" => "uint32",
+	"uint" => "uint32",
+	"int" => "int32",
+	"WORD" => "uint16",
+	"char" => "uint8",
+	"long" => "int32",
+	"short" => "int16",
+	"HYPER_T" => "hyper",
+        "mode_t"        => "uint32",
+);
+
+my %format_specifiers = (
+	"char"		=> "c",
+	"int8_t",	=> "\"PRId8\"",
+	"int16_t",	=> "\"PRId16\"",
+	"int32_t",	=> "\"PRId32\"",
+	"int64_t",	=> "\"PRId64\"",
+	"uint8_t",	=> "\"PRIu8\"",
+	"uint16_t",	=> "\"PRIu16\"",
+	"uint32_t",	=> "\"PRIu32\"",
+	"uint64_t",	=> "\"PRIu64\""
+);
+
+sub expandAlias($)
+{
+	my $name = shift;
+
+	return $aliases{$name} if defined($aliases{$name});
+
+	return $name;
+}
+
+# map from a IDL type to a C header type
+sub mapScalarType($)
+{
+	my $name = shift;
+
+	# it's a bug when a type is not in the list
+	# of known scalars or has no mapping
+	return $scalars{$name} if defined($scalars{$name});
+
+	die("Unknown scalar type $name");
+}
+
+sub addType($)
+{
+	my $t = shift;
+	$types{$t->{NAME}} = $t;
+}
+
+sub resolveType($)
+{
+	my ($ctype) = @_;
+
+	if (not hasType($ctype)) {
+		# assume struct typedef
+		return { TYPE => "TYPEDEF", NAME => $ctype, DATA => { TYPE => "STRUCT" } };
+	} else {
+		return getType($ctype);
+	}
+
+	return $ctype;
+}
+
+sub getType($)
+{
+	my $t = shift;
+	return ($t) if (ref($t) eq "HASH" and not defined($t->{NAME}));
+	return undef if not hasType($t);
+	return $types{$t->{NAME}} if (ref($t) eq "HASH");
+	return $types{$t};
+}
+
+sub typeIs($$);
+sub typeIs($$)
+{
+	my ($t,$tt) = @_;
+
+	if (ref($t) eq "HASH") {
+		return 1 if ($t->{TYPE} eq "TYPEDEF" and $t->{DATA}->{TYPE} eq $tt);
+		return 1 if ($t->{TYPE} eq $tt);
+		return 0;
+	}
+	if (hasType($t) and getType($t)->{TYPE} eq "TYPEDEF") {
+		return typeIs(getType($t)->{DATA}, $tt);
+	 }
+	return 0;
+}
+
+sub hasType($)
+{
+	my $t = shift;
+	if (ref($t) eq "HASH") {
+		return 1 if (not defined($t->{NAME}));
+		return 1 if (defined($types{$t->{NAME}}) and
+			$types{$t->{NAME}}->{TYPE} eq $t->{TYPE});
+		return 0;
+	}
+	return 1 if defined($types{$t});
+	return 0;
+}
+
+sub is_signed($)
+{
+    my $t = shift;
+
+    return ($t eq "int8"
+	    or $t eq "int16"
+	    or $t eq "int32"
+	    or $t eq "dlong"
+	    or $t eq "int"
+	    or $t eq "long"
+	    or $t eq "short");
+}
+
+sub is_scalar($)
+{
+	sub is_scalar($);
+	my $type = shift;
+
+	return 1 if (ref($type) eq "HASH" and
+		($type->{TYPE} eq "SCALAR" or $type->{TYPE} eq "ENUM" or
+		 $type->{TYPE} eq "BITMAP"));
+
+	if (my $dt = getType($type)) {
+		return is_scalar($dt->{DATA}) if ($dt->{TYPE} eq "TYPEDEF");
+		return 1 if ($dt->{TYPE} eq "SCALAR" or $dt->{TYPE} eq "ENUM" or
+			         $dt->{TYPE} eq "BITMAP");
+	}
+
+	return 0;
+}
+
+sub is_fixed_size_scalar($)
+{
+	my $name = shift;
+
+	return 0 unless is_scalar($name);
+	return 0 if (grep(/^$name$/, @non_fixed_size_scalars));
+	return 1;
+}
+
+sub scalar_is_reference($)
+{
+	my $name = shift;
+
+	return 1 if (grep(/^$name$/, @reference_scalars));
+	return 0;
+}
+
+sub is_string_type
+{
+	my ($t) = @_;
+
+	return ($t eq "string" or $t eq "u16string");
+}
+
+sub RegisterScalars()
+{
+	foreach (keys %scalars) {
+		addType({
+			NAME => $_,
+			TYPE => "TYPEDEF",
+			BASEFILE => "<builtin>",
+			DATA => {
+				TYPE => "SCALAR",
+				NAME => $_
+			}
+		}
+		);
+	}
+}
+
+sub enum_type_fn($)
+{
+	my $enum = shift;
+	$enum->{TYPE} eq "ENUM" or die("not an enum");
+
+	# for typedef enum { } we need to check $enum->{PARENT}
+	if (has_property($enum, "enum8bit")) {
+		return "uint8";
+	} elsif (has_property($enum, "enum16bit")) {
+		return "uint16";
+	} elsif (has_property($enum, "v1_enum")) {
+		return "uint32";
+	} elsif (has_property($enum->{PARENT}, "enum8bit")) {
+		return "uint8";
+	} elsif (has_property($enum->{PARENT}, "enum16bit")) {
+		return "uint16";
+	} elsif (has_property($enum->{PARENT}, "v1_enum")) {
+		return "uint32";
+	}
+	return "uint1632";
+}
+
+sub bitmap_type_fn($)
+{
+	my $bitmap = shift;
+
+	$bitmap->{TYPE} eq "BITMAP" or die("not a bitmap");
+
+	if (has_property($bitmap, "bitmap8bit")) {
+		return "uint8";
+	} elsif (has_property($bitmap, "bitmap16bit")) {
+		return "uint16";
+	} elsif (has_property($bitmap, "bitmap64bit")) {
+		return "hyper";
+	}
+	return "uint32";
+}
+
+sub typeHasBody($)
+{
+	sub typeHasBody($);
+	my ($e) = @_;
+
+	if ($e->{TYPE} eq "TYPEDEF") {
+		return 0 unless(defined($e->{DATA}));
+		return typeHasBody($e->{DATA});
+	}
+
+	return defined($e->{ELEMENTS});
+}
+
+sub mapType($$)
+{
+	sub mapType($$);
+	my ($t, $n) = @_;
+
+	return mapType($t->{DATA}, $n) if ($t->{TYPE} eq "TYPEDEF");
+	return mapScalarType($n) if ($t->{TYPE} eq "SCALAR");
+	return "enum $n" if ($t->{TYPE} eq "ENUM");
+	return "struct $n" if ($t->{TYPE} eq "STRUCT" or $t->{TYPE} eq "INTERFACE");
+	return "union $n" if ($t->{TYPE} eq "UNION");
+	return mapScalarType(bitmap_type_fn($t)) if ($t->{TYPE} eq "BITMAP");
+	return "struct $n" if ($t->{TYPE} eq "PIPE");
+	die("Unknown type $t->{TYPE}");
+}
+
+sub mapTypeName($)
+{
+	my $t = shift;
+	return "void" unless defined($t);
+	my $dt;
+	$t = expandAlias($t);
+
+	if ($dt = getType($t)) {
+		return mapType($dt, $dt->{NAME});
+	} elsif (ref($t) eq "HASH" and defined($t->{NAME})) {
+		return mapType($t, $t->{NAME});
+	} else {
+		# Best guess
+		return "struct $t";
+	}
+
+}
+
+sub mapTypeSpecifier($)
+{
+	my $t = shift;
+	return undef unless defined($t);
+
+	return $format_specifiers{$t};
+}
+
+sub LoadIdl($;$)
+{
+	my $idl = shift;
+	my $basename = shift;
+
+	foreach my $x (@{$idl}) {
+		next if $x->{TYPE} ne "INTERFACE";
+
+		# DCOM interfaces can be types as well
+		addType({
+			NAME => $x->{NAME},
+			TYPE => "TYPEDEF",
+			DATA => $x,
+			BASEFILE => $basename,
+			}) if (has_property($x, "object"));
+
+		foreach my $y (@{$x->{DATA}}) {
+			if ($y->{TYPE} eq "TYPEDEF"
+			    or $y->{TYPE} eq "UNION"
+			    or $y->{TYPE} eq "STRUCT"
+			    or $y->{TYPE} eq "ENUM"
+			    or $y->{TYPE} eq "BITMAP"
+			    or $y->{TYPE} eq "PIPE") {
+				$y->{BASEFILE} = $basename;
+				addType($y);
+			}
+		}
+	}
+}
+
+sub GenerateTypeLib()
+{
+	return Parse::Pidl::Util::MyDumper(\%types);
+}
+
+RegisterScalars();
+
+1;