source4/build/pidl/validator.pm

   1 ###################################################
   2 # check that a parsed IDL file is valid
   3 # Copyright tridge@samba.org 2003
   4 # released under the GNU GPL
   5
   6 package IdlValidator;
   7 use Data::Dumper;
   8
   9 use strict;
  10
  11 #####################################################################
  12 # signal a fatal validation error
  13 sub fatal($$)
  14 {
  15         my $pos = shift;
  16         my $s = shift;
  17         die("$pos->{FILE}:$pos->{LINE}:$s\n");
  18 }
  19
  20 sub nonfatal($$)
  21 {
  22         my $pos = shift;
  23         my $s = shift;
  24         warn ("$pos->{FILE}:$pos->{LINE}:warning:$s\n");
  25 }
  26
  27 sub el_name($)
  28 {
  29         my $e = shift;
  30
  31         if ($e->{PARENT} && $e->{PARENT}->{NAME}) {
  32                 return "$e->{PARENT}->{NAME}.$e->{NAME}";
  33         }
  34
  35         if ($e->{PARENT} && $e->{PARENT}->{PARENT}->{NAME}) {
  36                 return "$e->{PARENT}->{PARENT}->{NAME}.$e->{NAME}";
  37         }
  38
  39         if ($e->{PARENT}) {
  40                 return "$e->{PARENT}->{NAME}.$e->{NAME}";
  41         }
  42         return $e->{NAME};
  43 }
  44
  45 my %property_list = (
  46         # interface
  47         "helpstring"            => {},
  48         "version"               => {},
  49         "uuid"                  => {},
  50         "endpoint"              => {},
  51         "pointer_default"       => {},
  52         "pointer_default_top"   => {},
  53         "depends"               => {},
  54         "authservice"           => {},
  55
  56         # dcom
  57         "object"                => {},
  58         "local"                 => {},
  59         "iid_is"                => {},
  60         "call_as"               => {},
  61         "iid_is"                => {},
  62         "idempotent"            => {},
  63
  64         # function
  65         "noopnum"               => {},
  66         "in"                    => {},
  67         "out"                   => {},
  68
  69         # pointer
  70         "ref"                   => {},
  71         "ptr"                   => {},
  72         "unique"                => {},
  73         "relative"              => {},
  74
  75         # ndr_size
  76         "gensize"               => {},
  77         "value"                 => {},
  78         "flag"                  => {},
  79
  80         # generic
  81         "public"                => {},
  82         "nopush"                => {},
  83         "nopull"                => {},
  84         "noprint"               => {},
  85
  86         # union
  87         "switch_is"             => {},
  88         "switch_type"           => {},
  89         "nodiscriminant"        => {},
  90         "case"                  => {},
  91         "default"               => {},
  92
  93         # subcontext
  94         "subcontext"            => {},
  95         "subcontext_size"       => {},
  96         "compression"           => {},
  97         "obfuscation"           => {},
  98
  99         # enum
 100         "enum8bit"              => {},
 101         "enum16bit"             => {},
 102         "v1_enum"               => {},
 103
 104         # bitmap
 105         "bitmap8bit"            => {},
 106         "bitmap16bit"           => {},
 107         "bitmap32bit"           => {},
 108         "bitmap64bit"           => {},
 109
 110         # array
 111         "range"                 => {},
 112         "size_is"               => {},
 113         "length_is"             => {},
 114 );
 115
 116 #####################################################################
 117 # check for unknown properties
 118 sub ValidProperties($)
 119 {
 120         my $e = shift;
 121
 122         return unless defined $e->{PROPERTIES};
 123
 124         foreach my $key (keys %{$e->{PROPERTIES}}) {
 125                 if (not defined $property_list{$key}) {
 126                         fatal($e, el_name($e) . ": unknown property '$key'\n");
 127                 }
 128         }
 129 }
 130
 131 #####################################################################
 132 # parse a struct
 133 sub ValidElement($)
 134 {
 135         my $e = shift;
 136
 137         ValidProperties($e);
 138
 139         if (util::has_property($e, "ptr")) {
 140                 fatal($e, el_name($e) . " : pidl does not support full NDR pointers yet\n");
 141         }
 142
 143         # Check whether switches are used correctly.
 144         if (my $switch = util::has_property($e, "switch_is")) {
 145                 my $e2 = util::find_sibling($e, $switch);
 146                 my $type = typelist::getType($e->{TYPE});
 147
 148                 if (defined($type) and $type->{DATA}->{TYPE} ne "UNION") {
 149                         fatal($e, el_name($e) . ": switch_is() used on non-union type $e->{TYPE} which is a $type->{DATA}->{TYPE}");
 150                 }
 151
 152                 if (!util::has_property($type, "nodiscriminant") and defined($e2)) {
 153                         my $discriminator_type = util::has_property($type, "switch_type");
 154                         $discriminator_type = "uint32" unless defined ($discriminator_type);
 155
 156                         if ($e2->{TYPE} ne $discriminator_type) {
 157                                 print el_name($e) . ": Warning: switch_is() is of type $e2->{TYPE}, while discriminator type for union $type->{NAME} is $discriminator_type\n";
 158                         }
 159                 }
 160         }
 161
 162         if (defined (util::has_property($e, "subcontext_size")) and not defined(util::has_property($e, "subcontext"))) {
 163                 fatal($e, el_name($e) . " : subcontext_size() on non-subcontext element");
 164         }
 165
 166         if (defined (util::has_property($e, "compression")) and not defined(util::has_property($e, "subcontext"))) {
 167                 fatal($e, el_name($e) . " : compression() on non-subcontext element");
 168         }
 169
 170         if (defined (util::has_property($e, "obfuscation")) and not defined(util::has_property($e, "subcontext"))) {
 171                 fatal($e, el_name($e) . " : obfuscation() on non-subcontext element");
 172         }
 173
 174         if (!$e->{POINTERS} && (
 175                 util::has_property($e, "ptr") or
 176                 util::has_property($e, "unique") or
 177                 util::has_property($e, "relative") or
 178                 util::has_property($e, "ref"))) {
 179                 fatal($e, el_name($e) . " : pointer properties on non-pointer element\n");
 180         }
 181 }
 182
 183 #####################################################################
 184 # parse a struct
 185 sub ValidStruct($)
 186 {
 187         my($struct) = shift;
 188
 189         ValidProperties($struct);
 190
 191         foreach my $e (@{$struct->{ELEMENTS}}) {
 192                 $e->{PARENT} = $struct;
 193                 ValidElement($e);
 194         }
 195 }
 196
 197 #####################################################################
 198 # parse a union
 199 sub ValidUnion($)
 200 {
 201         my($union) = shift;
 202
 203         ValidProperties($union);
 204
 205         if (util::has_property($union->{PARENT}, "nodiscriminant") and util::has_property($union->{PARENT}, "switch_type")) {
 206                 fatal($union->{PARENT}, $union->{PARENT}->{NAME} . ": switch_type() on union without discriminant");
 207         }
 208
 209         foreach my $e (@{$union->{ELEMENTS}}) {
 210                 $e->{PARENT} = $union;
 211
 212                 if (defined($e->{PROPERTIES}->{default}) and
 213                         defined($e->{PROPERTIES}->{case})) {
 214                         fatal $e, "Union member $e->{NAME} can not have both default and case properties!\n";
 215                 }
 216
 217                 unless (defined ($e->{PROPERTIES}->{default}) or
 218                                 defined ($e->{PROPERTIES}->{case})) {
 219                         fatal $e, "Union member $e->{NAME} must have default or case property\n";
 220                 }
 221
 222                 if (util::has_property($e, "ref")) {
 223                         fatal($e, el_name($e) . " : embedded ref pointers are not supported yet\n");
 224                 }
 225
 226
 227                 ValidElement($e);
 228         }
 229 }
 230
 231 #####################################################################
 232 # parse a typedef
 233 sub ValidTypedef($)
 234 {
 235         my($typedef) = shift;
 236         my $data = $typedef->{DATA};
 237
 238         ValidProperties($typedef);
 239
 240         $data->{PARENT} = $typedef;
 241
 242         if (ref($data) eq "HASH") {
 243                 if ($data->{TYPE} eq "STRUCT") {
 244                         ValidStruct($data);
 245                 }
 246
 247                 if ($data->{TYPE} eq "UNION") {
 248                         ValidUnion($data);
 249                 }
 250         }
 251 }
 252
 253 #####################################################################
 254 # parse a function
 255 sub ValidFunction($)
 256 {
 257         my($fn) = shift;
 258
 259         ValidProperties($fn);
 260
 261         foreach my $e (@{$fn->{ELEMENTS}}) {
 262                 $e->{PARENT} = $fn;
 263                 if (util::has_property($e, "ref") && !$e->{POINTERS}) {
 264                         fatal $e, "[ref] variables must be pointers ($fn->{NAME}/$e->{NAME})\n";
 265                 }
 266                 ValidElement($e);
 267         }
 268 }
 269
 270 #####################################################################
 271 # parse the interface definitions
 272 sub ValidInterface($)
 273 {
 274         my($interface) = shift;
 275         my($data) = $interface->{DATA};
 276
 277         ValidProperties($interface);
 278
 279         if (util::has_property($interface, "pointer_default") &&
 280                 $interface->{PROPERTIES}->{pointer_default} eq "ptr") {
 281                 fatal $interface, "Full pointers are not supported yet\n";
 282         }
 283
 284         if (util::has_property($interface, "object")) {
 285                 if (util::has_property($interface, "version") &&
 286                         $interface->{PROPERTIES}->{version} != 0) {
 287                         fatal $interface, "Object interfaces must have version 0.0 ($interface->{NAME})\n";
 288                 }
 289
 290                 if (!defined($interface->{BASE}) &&
 291                         not ($interface->{NAME} eq "IUnknown")) {
 292                         fatal $interface, "Object interfaces must all derive from IUnknown ($interface->{NAME})\n";
 293                 }
 294         }
 295
 296         foreach my $d (@{$data}) {
 297                 ($d->{TYPE} eq "TYPEDEF") &&
 298                     ValidTypedef($d);
 299                 ($d->{TYPE} eq "FUNCTION") &&
 300                     ValidFunction($d);
 301         }
 302
 303 }
 304
 305 #####################################################################
 306 # parse a parsed IDL into a C header
 307 sub Validate($)
 308 {
 309         my($idl) = shift;
 310
 311         foreach my $x (@{$idl}) {
 312                 ($x->{TYPE} eq "INTERFACE") &&
 313                     ValidInterface($x);
 314         }
 315 }
 316
 317 1;