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
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;
+++ /dev/null
-###################################################
-# check that a parsed IDL file is valid
-# Copyright tridge@samba.org 2003
-# released under the GNU GPL
-
-package Parse::Pidl::Validator;
-
-use Parse::Pidl::Util qw(has_property);
-use Parse::Pidl::Typelist qw(hasType getType);
-
-use strict;
-
-#####################################################################
-# signal a fatal validation error
-sub fatal($$)
-{
- my ($pos,$s) = @_;
- die("$pos->{FILE}:$pos->{LINE}:$s\n");
-}
-
-sub nonfatal($$)
-{
- my ($pos,$s) = @_;
- warn ("$pos->{FILE}:$pos->{LINE}:warning:$s\n");
-}
-
-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);
- }
-
-}
-
-#####################################################################
-# parse a parsed IDL into a C header
-sub Validate($)
-{
- my($idl) = shift;
-
- foreach my $x (@{$idl}) {
- ($x->{TYPE} eq "INTERFACE") &&
- ValidInterface($x);
- }
-}
-
-1;
defined @$pidl || die "Failed to parse $idl_file";
require Parse::Pidl::Typelist;
Parse::Pidl::Typelist::LoadIdl($pidl);
- require Parse::Pidl::Validator;
- Parse::Pidl::Validator::Validate($pidl);
if (defined($opt_keep) && !SaveStructure($pidl_file, $pidl)) {
die "Failed to save $pidl_file\n";
}
defined($opt_server) or defined($opt_ndr_parser) or
defined($opt_ejs)) {
require Parse::Pidl::NDR;
+ Parse::Pidl::NDR::Validate($pidl);
$ndr = Parse::Pidl::NDR::Parse($pidl);
}
git.samba.org / sfrench / samba-autobuild / .git / commitdiff