summaryrefslogtreecommitdiff
path: root/source4/pidl/lib/Parse/Pidl/NDR.pm
diff options
context:
space:
mode:
Diffstat (limited to 'source4/pidl/lib/Parse/Pidl/NDR.pm')
-rw-r--r--source4/pidl/lib/Parse/Pidl/NDR.pm1235
1 files changed, 0 insertions, 1235 deletions
diff --git a/source4/pidl/lib/Parse/Pidl/NDR.pm b/source4/pidl/lib/Parse/Pidl/NDR.pm
deleted file mode 100644
index 9b61a370e2..0000000000
--- a/source4/pidl/lib/Parse/Pidl/NDR.pm
+++ /dev/null
@@ -1,1235 +0,0 @@
-###################################################
-# Samba4 NDR info tree generator
-# Copyright tridge@samba.org 2000-2003
-# Copyright tpot@samba.org 2001
-# Copyright jelmer@samba.org 2004-2006
-# released under the GNU GPL
-
-=pod
-
-=head1 NAME
-
-Parse::Pidl::NDR - NDR parsing information generator
-
-=head1 DESCRIPTION
-
-Return a table describing the order in which the parts of an element
-should be parsed
-Possible level types:
- - POINTER
- - ARRAY
- - SUBCONTEXT
- - SWITCH
- - DATA
-
-=head1 AUTHOR
-
-Jelmer Vernooij <jelmer@samba.org>
-
-=cut
-
-package Parse::Pidl::NDR;
-
-require Exporter;
-use vars qw($VERSION);
-$VERSION = '0.01';
-@ISA = qw(Exporter);
-@EXPORT = qw(GetPrevLevel GetNextLevel ContainsDeferred ContainsString);
-@EXPORT_OK = qw(GetElementLevelTable ParseElement ValidElement align_type mapToScalar ParseType can_contain_deferred is_charset_array);
-
-use strict;
-use Parse::Pidl qw(warning fatal);
-use Parse::Pidl::Typelist qw(hasType getType expandAlias);
-use Parse::Pidl::Util qw(has_property property_matches);
-
-# Alignment of the built-in scalar types
-my $scalar_alignment = {
- 'void' => 0,
- 'char' => 1,
- 'int8' => 1,
- 'uint8' => 1,
- 'int16' => 2,
- 'uint16' => 2,
- 'int32' => 4,
- 'uint32' => 4,
- 'hyper' => 8,
- 'pointer' => 8,
- 'dlong' => 4,
- 'udlong' => 4,
- 'udlongr' => 4,
- 'DATA_BLOB' => 4,
- 'string' => 4,
- 'string_array' => 4, #???
- 'time_t' => 4,
- 'NTTIME' => 4,
- 'NTTIME_1sec' => 4,
- 'NTTIME_hyper' => 8,
- 'WERROR' => 4,
- 'NTSTATUS' => 4,
- 'COMRESULT' => 4,
- 'nbt_string' => 4,
- 'wrepl_nbt_name' => 4,
- 'ipv4address' => 4
-};
-
-sub GetElementLevelTable($$)
-{
- my ($e, $pointer_default) = @_;
-
- my $order = [];
- my $is_deferred = 0;
- my @bracket_array = ();
- my @length_is = ();
- my @size_is = ();
- my $pointer_idx = 0;
-
- 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}};
- }
-
- if (has_property($e, "out")) {
- my $needptrs = 1;
-
- if (has_property($e, "string")) { $needptrs++; }
- if ($#bracket_array >= 0) { $needptrs = 0; }
-
- warning($e, "[out] argument `$e->{NAME}' not a pointer") if ($needptrs > $e->{POINTERS});
- }
-
- # Parse the [][][][] style array stuff
- for my $i (0 .. $#bracket_array) {
- my $d = $bracket_array[$#bracket_array - $i];
- my $size = $d;
- my $length = $d;
- my $is_surrounding = 0;
- my $is_varying = 0;
- my $is_conformant = 0;
- my $is_string = 0;
- my $is_fixed = 0;
- my $is_inline = 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 {
- fatal($e, "Must specify size_is() for conformant array!")
- }
-
- 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;
- }
- }
-
- $is_fixed = 1 if (not $is_conformant and Parse::Pidl::Util::is_constant($size));
- $is_inline = 1 if (not $is_conformant and not Parse::Pidl::Util::is_constant($size));
-
- 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 => $is_fixed,
- IS_INLINE => $is_inline
- });
- }
-
- # Next, all the pointers
- foreach my $i (1..$e->{POINTERS}) {
- my $level = "EMBEDDED";
- # Top level "ref" pointers do not have a referrent identifier
- $level = "TOP" if ($i == 1 and $e->{PARENT}->{TYPE} eq "FUNCTION");
-
- my $pt;
- #
- # Only the first level gets the pointer type from the
- # pointer property, the others get them from
- # the pointer_default() interface property
- #
- # see http://msdn2.microsoft.com/en-us/library/aa378984(VS.85).aspx
- # (Here they talk about the rightmost pointer, but testing shows
- # they mean the leftmost pointer.)
- #
- # --metze
- #
- $pt = pointer_type($e);
- if ($i > 1) {
- $is_deferred = 1 if ($pt ne "ref" and $e->{PARENT}->{TYPE} eq "FUNCTION");
- $pt = $pointer_default;
- }
-
- push (@$order, {
- TYPE => "POINTER",
- POINTER_TYPE => $pt,
- POINTER_INDEX => $pointer_idx,
- IS_DEFERRED => "$is_deferred",
- LEVEL => $level
- });
-
- warning($e, "top-level \[out\] pointer `$e->{NAME}' is not a \[ref\] pointer")
- if ($i == 1 and $pt ne "ref" and
- $e->{PARENT}->{TYPE} eq "FUNCTION" and
- not has_property($e, "in"));
-
- $pointer_idx++;
-
- # everything that follows will be deferred
- $is_deferred = 1 if ($level ne "TOP");
-
- 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") and
- $i == $e->{POINTERS}) {
- $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",
- SIZE_IS => $array_size,
- LENGTH_IS => $array_length,
- IS_DEFERRED => $is_deferred,
- IS_SURROUNDING => 0,
- IS_ZERO_TERMINATED => $is_string,
- 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"),
- });
- }
-
- if (my $switch = has_property($e, "switch_is")) {
- push (@$order, {
- TYPE => "SWITCH",
- SWITCH_IS => $switch,
- IS_DEFERRED => $is_deferred
- });
- }
-
- if (scalar(@size_is) > 0) {
- fatal($e, "size_is() on non-array element");
- }
-
- if (scalar(@length_is) > 0) {
- fatal($e, "length_is() on non-array element");
- }
-
- if (has_property($e, "string")) {
- fatal($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->{TYPE}),
- IS_SURROUNDING => 0 #FIXME
- });
-
- my $i = 0;
- foreach (@$order) { $_->{LEVEL_INDEX} = $i; $i+=1; }
-
- return $order;
-}
-
-sub GetTypedefLevelTable($$$)
-{
- my ($e, $data, $pointer_default) = @_;
-
- my $order = [];
-
- push (@$order, {
- TYPE => "TYPEDEF"
- });
-
- my $i = 0;
- foreach (@$order) { $_->{LEVEL_INDEX} = $i; $i+=1; }
-
- return $order;
-}
-
-#####################################################################
-# see if a type contains any deferred data
-sub can_contain_deferred($)
-{
- sub can_contain_deferred($);
- my ($type) = @_;
-
- return 1 unless (hasType($type)); # assume the worst
-
- $type = getType($type);
-
- return 0 if (Parse::Pidl::Typelist::is_scalar($type));
-
- return can_contain_deferred($type->{DATA}) if ($type->{TYPE} eq "TYPEDEF");
-
- return 0 unless defined($type->{ELEMENTS});
-
- foreach (@{$type->{ELEMENTS}}) {
- return 1 if ($_->{POINTERS});
- return 1 if (can_contain_deferred ($_->{TYPE}));
- }
-
- return 0;
-}
-
-sub pointer_type($)
-{
- my $e = shift;
-
- return undef unless $e->{POINTERS};
-
- return "ref" if (has_property($e, "ref"));
- return "full" 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;
- } elsif (has_property($e, "transmit_as")) {
- $a = align_type($e->{PROPERTIES}->{transmit_as});
- } else {
- $a = align_type($e->{TYPE});
- }
-
- $align = $a if ($align < $a);
- }
-
- return $align;
-}
-
-#####################################################################
-# align a type
-sub align_type($)
-{
- sub align_type($);
- my ($e) = @_;
-
- if (ref($e) eq "HASH" and $e->{TYPE} eq "SCALAR") {
- return $scalar_alignment->{$e->{NAME}};
- }
-
- return 0 if ($e eq "EMPTY");
-
- unless (hasType($e)) {
- # it must be an external type - all we can do is guess
- # warning($e, "assuming alignment of unknown type '$e' is 4");
- return 4;
- }
-
- my $dt = getType($e);
-
- if ($dt->{TYPE} eq "TYPEDEF") {
- return align_type($dt->{DATA});
- } elsif ($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")) {
- # Struct/union without body: assume 4
- return 4 unless (defined($dt->{ELEMENTS}));
- return find_largest_alignment($dt);
- }
-
- die("Unknown data type type $dt->{TYPE}");
-}
-
-sub ParseElement($$)
-{
- my ($e, $pointer_default) = @_;
-
- $e->{TYPE} = expandAlias($e->{TYPE});
-
- if (ref($e->{TYPE}) eq "HASH") {
- $e->{TYPE} = ParseType($e->{TYPE}, $pointer_default);
- }
-
- return {
- NAME => $e->{NAME},
- TYPE => $e->{TYPE},
- PROPERTIES => $e->{PROPERTIES},
- LEVELS => GetElementLevelTable($e, $pointer_default),
- REPRESENTATION_TYPE => ($e->{PROPERTIES}->{represent_as} or $e->{TYPE}),
- ALIGN => align_type($e->{TYPE}),
- ORIGINAL => $e
- };
-}
-
-sub ParseStruct($$)
-{
- my ($struct, $pointer_default) = @_;
- my @elements = ();
- my $surrounding = undef;
-
- return {
- TYPE => "STRUCT",
- NAME => $struct->{NAME},
- SURROUNDING_ELEMENT => undef,
- ELEMENTS => undef,
- PROPERTIES => $struct->{PROPERTIES},
- ORIGINAL => $struct,
- ALIGN => undef
- } unless defined($struct->{ELEMENTS});
-
- CheckPointerTypes($struct, $pointer_default);
-
- foreach my $x (@{$struct->{ELEMENTS}})
- {
- my $e = ParseElement($x, $pointer_default);
- if ($x != $struct->{ELEMENTS}[-1] and
- $e->{LEVELS}[0]->{IS_SURROUNDING}) {
- fatal($x, "conformant member not at end of struct");
- }
- push @elements, $e;
- }
-
- 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];
- }
-
- my $align = undef;
- if ($struct->{NAME}) {
- $align = align_type($struct->{NAME});
- }
-
- return {
- TYPE => "STRUCT",
- NAME => $struct->{NAME},
- SURROUNDING_ELEMENT => $surrounding,
- ELEMENTS => \@elements,
- PROPERTIES => $struct->{PROPERTIES},
- ORIGINAL => $struct,
- ALIGN => $align
- };
-}
-
-sub ParseUnion($$)
-{
- my ($e, $pointer_default) = @_;
- my @elements = ();
- my $hasdefault = 0;
- my $switch_type = has_property($e, "switch_type");
- unless (defined($switch_type)) { $switch_type = "uint32"; }
- if (has_property($e, "nodiscriminant")) { $switch_type = undef; }
-
- return {
- TYPE => "UNION",
- NAME => $e->{NAME},
- SWITCH_TYPE => $switch_type,
- ELEMENTS => undef,
- PROPERTIES => $e->{PROPERTIES},
- HAS_DEFAULT => $hasdefault,
- ORIGINAL => $e
- } unless defined($e->{ELEMENTS});
-
- CheckPointerTypes($e, $pointer_default);
-
- foreach my $x (@{$e->{ELEMENTS}})
- {
- my $t;
- if ($x->{TYPE} eq "EMPTY") {
- $t = { TYPE => "EMPTY" };
- } else {
- $t = ParseElement($x, $pointer_default);
- }
- if (has_property($x, "default")) {
- $t->{CASE} = "default";
- $hasdefault = 1;
- } 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",
- NAME => $e->{NAME},
- SWITCH_TYPE => $switch_type,
- ELEMENTS => \@elements,
- PROPERTIES => $e->{PROPERTIES},
- HAS_DEFAULT => $hasdefault,
- ORIGINAL => $e
- };
-}
-
-sub ParseEnum($$)
-{
- my ($e, $pointer_default) = @_;
-
- return {
- TYPE => "ENUM",
- NAME => $e->{NAME},
- BASE_TYPE => Parse::Pidl::Typelist::enum_type_fn($e),
- ELEMENTS => $e->{ELEMENTS},
- PROPERTIES => $e->{PROPERTIES},
- ORIGINAL => $e
- };
-}
-
-sub ParseBitmap($$)
-{
- my ($e, $pointer_default) = @_;
-
- return {
- TYPE => "BITMAP",
- NAME => $e->{NAME},
- BASE_TYPE => Parse::Pidl::Typelist::bitmap_type_fn($e),
- ELEMENTS => $e->{ELEMENTS},
- PROPERTIES => $e->{PROPERTIES},
- ORIGINAL => $e
- };
-}
-
-sub ParseType($$)
-{
- my ($d, $pointer_default) = @_;
-
- my $data = {
- STRUCT => \&ParseStruct,
- UNION => \&ParseUnion,
- ENUM => \&ParseEnum,
- BITMAP => \&ParseBitmap,
- TYPEDEF => \&ParseTypedef,
- }->{$d->{TYPE}}->($d, $pointer_default);
-
- return $data;
-}
-
-sub ParseTypedef($$)
-{
- my ($d, $pointer_default) = @_;
-
- if (defined($d->{DATA}->{PROPERTIES}) && !defined($d->{PROPERTIES})) {
- $d->{PROPERTIES} = $d->{DATA}->{PROPERTIES};
- }
-
- my $data = ParseType($d->{DATA}, $pointer_default);
- $data->{ALIGN} = align_type($d->{NAME});
-
- return {
- NAME => $d->{NAME},
- TYPE => $d->{TYPE},
- PROPERTIES => $d->{PROPERTIES},
- LEVELS => GetTypedefLevelTable($d, $data, $pointer_default),
- 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, "ref");
-
- if (not defined($d->{PROPERTIES}{noopnum})) {
- $thisopnum = ${$opnum};
- ${$opnum}++;
- }
-
- foreach my $x (@{$d->{ELEMENTS}}) {
- my $e = ParseElement($x, $ndr->{PROPERTIES}->{pointer_default});
- 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 = expandAlias($d->{RETURN_TYPE});
- }
-
- my $async = 0;
- if (has_property($d, "async")) { $async = 1; }
-
- return {
- NAME => $d->{NAME},
- TYPE => "FUNCTION",
- OPNUM => $thisopnum,
- ASYNC => $async,
- RETURN_TYPE => $rettype,
- PROPERTIES => $d->{PROPERTIES},
- ELEMENTS => \@elements,
- ORIGINAL => $d
- };
-}
-
-sub CheckPointerTypes($$)
-{
- my ($s,$default) = @_;
-
- return unless defined($s->{ELEMENTS});
-
- foreach my $e (@{$s->{ELEMENTS}}) {
- if ($e->{POINTERS} and not defined(pointer_type($e))) {
- $e->{PROPERTIES}->{$default} = '1';
- }
- }
-}
-
-sub FindNestedTypes($$)
-{
- sub FindNestedTypes($$);
- my ($l, $t) = @_;
-
- return unless defined($t->{ELEMENTS});
- return if ($t->{TYPE} eq "ENUM");
- return if ($t->{TYPE} eq "BITMAP");
-
- foreach (@{$t->{ELEMENTS}}) {
- if (ref($_->{TYPE}) eq "HASH") {
- push (@$l, $_->{TYPE}) if (defined($_->{TYPE}->{NAME}));
- FindNestedTypes($l, $_->{TYPE});
- }
- }
-}
-
-sub ParseInterface($)
-{
- my $idl = shift;
- my @types = ();
- my @consts = ();
- my @functions = ();
- my @endpoints;
- 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";
- }
-
- foreach my $d (@{$idl->{DATA}}) {
- if ($d->{TYPE} eq "FUNCTION") {
- push (@functions, ParseFunction($idl, $d, \$opnum));
- } elsif ($d->{TYPE} eq "CONST") {
- push (@consts, ParseConst($idl, $d));
- } else {
- push (@types, ParseType($d, $idl->{PROPERTIES}->{pointer_default}));
- FindNestedTypes(\@types, $d);
- }
- }
-
- $version = "0.0";
-
- if(defined $idl->{PROPERTIES}->{version}) {
- my @if_version = split(/\./, $idl->{PROPERTIES}->{version});
- if ($if_version[0] == $idl->{PROPERTIES}->{version}) {
- $version = $idl->{PROPERTIES}->{version};
- } else {
- $version = $if_version[1] << 16 | $if_version[0];
- }
- }
-
- # 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 => lc(has_property($idl, "uuid")),
- VERSION => $version,
- TYPE => "INTERFACE",
- PROPERTIES => $idl->{PROPERTIES},
- FUNCTIONS => \@functions,
- CONSTS => \@consts,
- TYPES => \@types,
- 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;
-
- return undef unless (defined($idl));
-
- Parse::Pidl::NDR::Validate($idl);
-
- my @ndr = ();
-
- foreach (@{$idl}) {
- ($_->{TYPE} eq "CPP_QUOTE") && push(@ndr, $_);
- ($_->{TYPE} eq "INTERFACE") && push(@ndr, ParseInterface($_));
- ($_->{TYPE} eq "IMPORT") && push(@ndr, $_);
- }
-
- 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 ContainsString($)
-{
- my ($e) = @_;
-
- foreach my $l (@{$e->{LEVELS}}) {
- return 1 if ($l->{TYPE} eq "ARRAY" and $l->{IS_ZERO_TERMINATED});
- }
-
- return 0;
-}
-
-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;
- my $name = "<ANONYMOUS>";
-
- $name = $e->{NAME} if defined($e->{NAME});
-
- if (defined($e->{PARENT}) and defined($e->{PARENT}->{NAME})) {
- return "$e->{PARENT}->{NAME}.$name";
- }
-
- if (defined($e->{PARENT}) and
- defined($e->{PARENT}->{PARENT}) and
- defined($e->{PARENT}->{PARENT}->{NAME})) {
- return "$e->{PARENT}->{PARENT}->{NAME}.$name";
- }
-
- return $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"],
- "helper" => ["INTERFACE"],
- "authservice" => ["INTERFACE"],
- "restricted" => ["INTERFACE"],
-
- # dcom
- "object" => ["INTERFACE"],
- "local" => ["INTERFACE", "FUNCTION"],
- "iid_is" => ["ELEMENT"],
- "call_as" => ["FUNCTION"],
- "idempotent" => ["FUNCTION"],
-
- # function
- "noopnum" => ["FUNCTION"],
- "in" => ["ELEMENT"],
- "out" => ["ELEMENT"],
- "async" => ["FUNCTION"],
-
- # pointer
- "ref" => ["ELEMENT"],
- "ptr" => ["ELEMENT"],
- "unique" => ["ELEMENT"],
- "ignore" => ["ELEMENT"],
- "relative" => ["ELEMENT"],
- "null_is_ffffffff" => ["ELEMENT"],
- "relative_base" => ["TYPEDEF", "STRUCT", "UNION"],
-
- "gensize" => ["TYPEDEF", "STRUCT", "UNION"],
- "value" => ["ELEMENT"],
- "flag" => ["ELEMENT", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP"],
-
- # generic
- "public" => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP"],
- "nopush" => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP"],
- "nopull" => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP"],
- "nosize" => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP"],
- "noprint" => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP", "ELEMENT"],
- "noejs" => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP"],
- "todo" => ["FUNCTION"],
-
- # union
- "switch_is" => ["ELEMENT"],
- "switch_type" => ["ELEMENT", "UNION"],
- "nodiscriminant" => ["UNION"],
- "case" => ["ELEMENT"],
- "default" => ["ELEMENT"],
-
- "represent_as" => ["ELEMENT"],
- "transmit_as" => ["ELEMENT"],
-
- # subcontext
- "subcontext" => ["ELEMENT"],
- "subcontext_size" => ["ELEMENT"],
- "compression" => ["ELEMENT"],
-
- # enum
- "enum8bit" => ["ENUM"],
- "enum16bit" => ["ENUM"],
- "v1_enum" => ["ENUM"],
-
- # bitmap
- "bitmap8bit" => ["BITMAP"],
- "bitmap16bit" => ["BITMAP"],
- "bitmap32bit" => ["BITMAP"],
- "bitmap64bit" => ["BITMAP"],
-
- # 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}}) {
- warning($e, el_name($e) . ": unknown property '$key'")
- unless defined($property_list{$key});
-
- fatal($e, el_name($e) . ": property '$key' not allowed on '$t'")
- unless grep(/^$t$/, @{$property_list{$key}});
- }
-}
-
-sub mapToScalar($)
-{
- sub mapToScalar($);
- my $t = shift;
- return $t->{NAME} if (ref($t) eq "HASH" and $t->{TYPE} eq "SCALAR");
- my $ti = getType($t);
-
- if (not defined ($ti)) {
- return undef;
- } elsif ($ti->{TYPE} eq "TYPEDEF") {
- return mapToScalar($ti->{DATA});
- } elsif ($ti->{TYPE} eq "ENUM") {
- return Parse::Pidl::Typelist::enum_type_fn($ti);
- } elsif ($ti->{TYPE} eq "BITMAP") {
- return Parse::Pidl::Typelist::bitmap_type_fn($ti);
- }
-
- return undef;
-}
-
-#####################################################################
-# validate an element
-sub ValidElement($)
-{
- my $e = shift;
-
- ValidProperties($e,"ELEMENT");
-
- # 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 (not has_property($type->{DATA}, "nodiscriminant") and defined($e2)) {
- my $discriminator_type = has_property($type->{DATA}, "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) {
- warning($e, el_name($e) . ": switch_is() is of type $e2->{TYPE} ($t2), while discriminator type for union $type->{NAME} is $discriminator_type ($t1)");
- }
- }
- }
-
- if (has_property($e, "subcontext") and has_property($e, "represent_as")) {
- fatal($e, el_name($e) . " : subcontext() and represent_as() can not be used on the same element");
- }
-
- if (has_property($e, "subcontext") and has_property($e, "transmit_as")) {
- fatal($e, el_name($e) . " : subcontext() and transmit_as() can not be used on the same element");
- }
-
- if (has_property($e, "represent_as") and has_property($e, "transmit_as")) {
- fatal($e, el_name($e) . " : represent_as() and transmit_as() can not be used on the same element");
- }
-
- if (has_property($e, "represent_as") and has_property($e, "value")) {
- fatal($e, el_name($e) . " : represent_as() and value() can not be used on the same element");
- }
-
- if (has_property($e, "subcontext")) {
- warning($e, "subcontext() is deprecated. Use represent_as() or transmit_as() instead");
- }
-
- 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 (!$e->{POINTERS} && (
- has_property($e, "ptr") 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");
- }
-}
-
-#####################################################################
-# validate an enum
-sub ValidEnum($)
-{
- my ($enum) = @_;
-
- ValidProperties($enum, "ENUM");
-}
-
-#####################################################################
-# validate a bitmap
-sub ValidBitmap($)
-{
- my ($bitmap) = @_;
-
- ValidProperties($bitmap, "BITMAP");
-}
-
-#####################################################################
-# validate a struct
-sub ValidStruct($)
-{
- my($struct) = shift;
-
- ValidProperties($struct, "STRUCT");
-
- return unless defined($struct->{ELEMENTS});
-
- 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(" . $union->{PARENT}->{PROPERTIES}->{switch_type} . ") on union without discriminant");
- }
-
- return unless defined($union->{ELEMENTS});
-
- 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!");
- }
-
- unless (defined ($e->{PROPERTIES}->{default}) or
- defined ($e->{PROPERTIES}->{case})) {
- fatal($e, "Union member $e->{NAME} must have default or case property");
- }
-
- 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;
-
- $data->{FILE} = $typedef->{FILE} unless defined($data->{FILE});
- $data->{LINE} = $typedef->{LINE} unless defined($data->{LINE});
-
- ValidType($data) if (ref($data) eq "HASH");
-}
-
-#####################################################################
-# validate 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})");
- }
- ValidElement($e);
- }
-}
-
-#####################################################################
-# validate a type
-sub ValidType($)
-{
- my ($t) = @_;
-
- {
- TYPEDEF => \&ValidTypedef,
- STRUCT => \&ValidStruct,
- UNION => \&ValidUnion,
- ENUM => \&ValidEnum,
- BITMAP => \&ValidBitmap
- }->{$t->{TYPE}}->($t);
-}
-
-#####################################################################
-# parse the interface definitions
-sub ValidInterface($)
-{
- my($interface) = shift;
- my($data) = $interface->{DATA};
-
- if (has_property($interface, "helper")) {
- warning($interface, "helper() is pidl-specific and deprecated. Use `include' instead");
- }
-
- ValidProperties($interface,"INTERFACE");
-
- if (has_property($interface, "pointer_default")) {
- if (not grep (/$interface->{PROPERTIES}->{pointer_default}/,
- ("ref", "unique", "ptr"))) {
- fatal($interface, "Unknown default pointer type `$interface->{PROPERTIES}->{pointer_default}'");
- }
- }
-
- 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})");
- }
-
- if (!defined($interface->{BASE}) &&
- not ($interface->{NAME} eq "IUnknown")) {
- fatal($interface, "Object interfaces must all derive from IUnknown ($interface->{NAME})");
- }
- }
-
- foreach my $d (@{$data}) {
- ($d->{TYPE} eq "FUNCTION") && ValidFunction($d);
- ($d->{TYPE} eq "TYPEDEF" or
- $d->{TYPE} eq "STRUCT" or
- $d->{TYPE} eq "UNION" or
- $d->{TYPE} eq "ENUM" or
- $d->{TYPE} eq "BITMAP") && ValidType($d);
- }
-
-}
-
-#####################################################################
-# Validate an IDL structure
-sub Validate($)
-{
- my($idl) = shift;
-
- foreach my $x (@{$idl}) {
- ($x->{TYPE} eq "INTERFACE") &&
- ValidInterface($x);
- ($x->{TYPE} eq "IMPORTLIB") &&
- fatal($x, "importlib() not supported");
- }
-}
-
-sub is_charset_array($$)
-{
- my ($e,$l) = @_;
-
- return 0 if ($l->{TYPE} ne "ARRAY");
-
- my $nl = GetNextLevel($e,$l);
-
- return 0 unless ($nl->{TYPE} eq "DATA");
-
- return has_property($e, "charset");
-}
-
-
-
-1;
generated by cgit (git 2.34.1) at 2024-06-28 00:39:17 +0000