pidl/lib/Parse/Pidl/NDR.pm

   1 ###################################################
   2 # Samba4 NDR info tree generator
   3 # Copyright tridge@samba.org 2000-2003
   4 # Copyright tpot@samba.org 2001
   5 # Copyright jelmer@samba.org 2004-2006
   6 # released under the GNU GPL
   7
   8 =pod
   9
  10 =head1 NAME
  11
  12 Parse::Pidl::NDR - NDR parsing information generator
  13
  14 =head1 DESCRIPTION
  15
  16 Return a table describing the order in which the parts of an element
  17 should be parsed
  18 Possible level types:
  19  - POINTER
  20  - ARRAY
  21  - SUBCONTEXT
  22  - SWITCH
  23  - DATA
  24
  25 =head1 AUTHOR
  26
  27 Jelmer Vernooij <jelmer@samba.org>
  28
  29 =cut
  30
  31 package Parse::Pidl::NDR;
  32
  33 require Exporter;
  34 use vars qw($VERSION);
  35 $VERSION = '0.01';
  36 @ISA = qw(Exporter);
  37 @EXPORT = qw(GetPrevLevel GetNextLevel ContainsDeferred ContainsPipe ContainsString);
  38 @EXPORT_OK = qw(GetElementLevelTable ParseElement ReturnTypeElement ValidElement align_type mapToScalar ParseType can_contain_deferred is_charset_array);
  39
  40 use strict;
  41 use warnings;
  42 use Parse::Pidl qw(warning fatal);
  43 use Parse::Pidl::Typelist qw(hasType getType typeIs expandAlias mapScalarType is_fixed_size_scalar);
  44 use Parse::Pidl::Util qw(has_property property_matches);
  45
  46 # Alignment of the built-in scalar types
  47 my $scalar_alignment = {
  48         'void' => 0,
  49         'char' => 1,
  50         'int8' => 1,
  51         'uint8' => 1,
  52         'int16' => 2,
  53         'uint16' => 2,
  54         'int1632' => 3,
  55         'uint1632' => 3,
  56         'int32' => 4,
  57         'uint32' => 4,
  58         'int3264' => 5,
  59         'uint3264' => 5,
  60         'hyper' => 8,
  61         'int64' => 8,
  62         'double' => 8,
  63         'pointer' => 8,
  64         'dlong' => 4,
  65         'udlong' => 4,
  66         'udlongr' => 4,
  67         'DATA_BLOB' => 4,
  68         'string' => 4,
  69         'string_array' => 4, #???
  70         'time_t' => 4,
  71         'uid_t' => 8,
  72         'gid_t' => 8,
  73         'NTTIME' => 4,
  74         'NTTIME_1sec' => 4,
  75         'NTTIME_hyper' => 8,
  76         'WERROR' => 4,
  77         'NTSTATUS' => 4,
  78         'COMRESULT' => 4,
  79         'dns_string' => 4,
  80         'nbt_string' => 4,
  81         'wrepl_nbt_name' => 4,
  82         'ipv4address' => 4,
  83         'ipv6address' => 4, #16?
  84         'dnsp_name' => 1,
  85         'dnsp_string' => 1,
  86         'HRESULT' => 4,
  87         'libndr_flags' => 4,
  88 };
  89
  90 sub GetElementLevelTable($$$)
  91 {
  92         my ($e, $pointer_default, $ms_union) = @_;
  93
  94         my $order = [];
  95         my $is_deferred = 0;
  96         my @bracket_array = ();
  97         my @length_is = ();
  98         my @size_is = ();
  99         my $pointer_idx = 0;
 100
 101         if (has_property($e, "size_is")) {
 102                 @size_is = split /,/, has_property($e, "size_is");
 103         }
 104
 105         if (has_property($e, "length_is")) {
 106                 @length_is = split /,/, has_property($e, "length_is");
 107         }
 108
 109         if (defined($e->{ARRAY_LEN})) {
 110                 @bracket_array = @{$e->{ARRAY_LEN}};
 111         }
 112
 113         if (has_property($e, "out")) {
 114                 my $needptrs = 1;
 115
 116                 if (has_property($e, "string") and not has_property($e, "in")) { $needptrs++; }
 117                 if ($#bracket_array >= 0) { $needptrs = 0; }
 118
 119                 warning($e, "[out] argument `$e->{NAME}' not a pointer") if ($needptrs > $e->{POINTERS});
 120         }
 121
 122         my $allow_pipe = (($e->{PARENT}->{TYPE} // '') eq "FUNCTION");
 123         my $is_pipe = typeIs($e->{TYPE}, "PIPE");
 124
 125         if ($is_pipe) {
 126                 if (not $allow_pipe) {
 127                         fatal($e, "argument `$e->{NAME}' is a pipe and not allowed on $e->{PARENT}->{TYPE}");
 128                 }
 129
 130                 if ($e->{POINTERS} > 1) {
 131                         fatal($e, "$e->{POINTERS} are not allowed on pipe element $e->{NAME}");
 132                 }
 133
 134                 if ($e->{POINTERS} < 0) {
 135                         fatal($e, "pipe element $e->{NAME} needs pointer");
 136                 }
 137
 138                 if ($e->{POINTERS} == 1 and pointer_type($e) ne "ref") {
 139                         fatal($e, "pointer should be 'ref' on pipe element $e->{NAME}");
 140                 }
 141
 142                 if (scalar(@size_is) > 0) {
 143                         fatal($e, "size_is() on pipe element");
 144                 }
 145
 146                 if (scalar(@length_is) > 0) {
 147                         fatal($e, "length_is() on pipe element");
 148                 }
 149
 150                 if (scalar(@bracket_array) > 0) {
 151                         fatal($e, "brackets on pipe element");
 152                 }
 153
 154                 if (defined(has_property($e, "subcontext"))) {
 155                         fatal($e, "subcontext on pipe element");
 156                 }
 157
 158                 if (has_property($e, "switch_is")) {
 159                         fatal($e, "switch_is on pipe element");
 160                 }
 161
 162                 if (can_contain_deferred($e->{TYPE})) {
 163                         fatal($e, "$e->{TYPE} can_contain_deferred - not allowed on pipe element");
 164                 }
 165         }
 166
 167         # Parse the [][][][] style array stuff
 168         for my $i (0 .. $#bracket_array) {
 169                 my $d = $bracket_array[$#bracket_array - $i];
 170                 my $size = $d;
 171                 my $length = $d;
 172                 my $is_surrounding = 0;
 173                 my $is_varying = 0;
 174                 my $is_conformant = 0;
 175                 my $is_string = 0;
 176                 my $is_fixed = 0;
 177                 my $is_inline = 0;
 178                 my $is_to_null = 0;
 179
 180                 if ($d eq "*") {
 181                         $is_conformant = 1;
 182                         if ($size = shift @size_is) {
 183                                 if ($e->{POINTERS} < 1 and has_property($e, "string")) {
 184                                         $is_string = 1;
 185                                         delete($e->{PROPERTIES}->{string});
 186                                 }
 187                         } elsif ((scalar(@size_is) == 0) and has_property($e, "string")) {
 188                                 $is_string = 1;
 189                                 delete($e->{PROPERTIES}->{string});
 190                         } else {
 191                                 fatal($e, "Must specify size_is() for conformant array!")
 192                         }
 193
 194                         if (($length = shift @length_is) or $is_string) {
 195                                 $is_varying = 1;
 196                         } else {
 197                                 $length = $size;
 198                         }
 199
 200                         if ($e == $e->{PARENT}->{ELEMENTS}[-1]
 201                                 and $e->{PARENT}->{TYPE} ne "FUNCTION") {
 202                                 $is_surrounding = 1;
 203                         }
 204                 }
 205
 206                 $is_fixed = 1 if (not $is_conformant and Parse::Pidl::Util::is_constant($size));
 207                 $is_inline = 1 if (not $is_conformant and not Parse::Pidl::Util::is_constant($size));
 208
 209                 if ($i == 0 and $is_fixed and has_property($e, "string")) {
 210                         $is_fixed = 0;
 211                         $is_varying = 1;
 212                         $is_string = 1;
 213                         delete($e->{PROPERTIES}->{string});
 214                 }
 215
 216                 if (has_property($e, "to_null")) {
 217                         $is_to_null = 1;
 218                 }
 219
 220                 push (@$order, {
 221                         TYPE => "ARRAY",
 222                         SIZE_IS => $size,
 223                         LENGTH_IS => $length,
 224                         IS_DEFERRED => $is_deferred,
 225                         IS_SURROUNDING => $is_surrounding,
 226                         IS_ZERO_TERMINATED => $is_string,
 227                         IS_VARYING => $is_varying,
 228                         IS_CONFORMANT => $is_conformant,
 229                         IS_FIXED => $is_fixed,
 230                         IS_INLINE => $is_inline,
 231                         IS_TO_NULL => $is_to_null
 232                 });
 233         }
 234
 235         # Next, all the pointers
 236         foreach my $i (1..$e->{POINTERS}) {
 237                 my $level = "EMBEDDED";
 238                 # Top level "ref" pointers do not have a referrent identifier
 239                 $level = "TOP" if ($i == 1 and $e->{PARENT}->{TYPE} eq "FUNCTION");
 240
 241                 my $pt;
 242                 #
 243                 # Only the first level gets the pointer type from the
 244                 # pointer property, the others get them from
 245                 # the pointer_default() interface property
 246                 #
 247                 # see http://msdn2.microsoft.com/en-us/library/aa378984(VS.85).aspx
 248                 # (Here they talk about the rightmost pointer, but testing shows
 249                 #  they mean the leftmost pointer.)
 250                 #
 251                 # --metze
 252                 #
 253                 $pt = pointer_type($e);
 254                 if ($i > 1) {
 255                         $is_deferred = 1 if ($pt ne "ref" and $e->{PARENT}->{TYPE} eq "FUNCTION");
 256                         $pt = $pointer_default;
 257                 }
 258
 259                 push (@$order, {
 260                         TYPE => "POINTER",
 261                         POINTER_TYPE => $pt,
 262                         POINTER_INDEX => $pointer_idx,
 263                         IS_DEFERRED => "$is_deferred",
 264                         LEVEL => $level
 265                 });
 266
 267                 warning($e, "top-level \[out\] pointer `$e->{NAME}' is not a \[ref\] pointer")
 268                         if ($i == 1 and $pt ne "ref" and
 269                                 $e->{PARENT}->{TYPE} eq "FUNCTION" and
 270                                 not has_property($e, "in"));
 271
 272                 $pointer_idx++;
 273
 274                 # everything that follows will be deferred
 275                 $is_deferred = 1 if ($level ne "TOP");
 276
 277                 my $array_size = shift @size_is;
 278                 my $array_length;
 279                 my $is_varying;
 280                 my $is_conformant;
 281                 my $is_string = 0;
 282                 if ($array_size) {
 283                         $is_conformant = 1;
 284                         if ($array_length = shift @length_is) {
 285                                 $is_varying = 1;
 286                         } else {
 287                                 $array_length = $array_size;
 288                                 $is_varying =0;
 289                         }
 290                 }
 291
 292                 if (scalar(@size_is) == 0 and has_property($e, "string") and
 293                     $i == $e->{POINTERS}) {
 294                         $is_string = 1;
 295                         $is_varying = $is_conformant = has_property($e, "noheader")?0:1;
 296                         delete($e->{PROPERTIES}->{string});
 297                 }
 298
 299                 if ($array_size or $is_string) {
 300                         push (@$order, {
 301                                 TYPE => "ARRAY",
 302                                 SIZE_IS => $array_size,
 303                                 LENGTH_IS => $array_length,
 304                                 IS_DEFERRED => $is_deferred,
 305                                 IS_SURROUNDING => 0,
 306                                 IS_ZERO_TERMINATED => $is_string,
 307                                 IS_VARYING => $is_varying,
 308                                 IS_CONFORMANT => $is_conformant,
 309                                 IS_FIXED => 0,
 310                                 IS_INLINE => 0
 311                         });
 312
 313                         $is_deferred = 0;
 314                 }
 315         }
 316
 317         if ($is_pipe) {
 318                 push (@$order, {
 319                         TYPE => "PIPE",
 320                         IS_DEFERRED => 0,
 321                         CONTAINS_DEFERRED => 0,
 322                 });
 323
 324                 my $i = 0;
 325                 foreach (@$order) { $_->{LEVEL_INDEX} = $i; $i+=1; }
 326
 327                 return $order;
 328         }
 329
 330         if (defined(has_property($e, "subcontext"))) {
 331                 my $hdr_size = has_property($e, "subcontext");
 332                 my $subsize = has_property($e, "subcontext_size");
 333                 if (not defined($subsize)) {
 334                         $subsize = -1;
 335                 }
 336
 337                 push (@$order, {
 338                         TYPE => "SUBCONTEXT",
 339                         HEADER_SIZE => $hdr_size,
 340                         SUBCONTEXT_SIZE => $subsize,
 341                         IS_DEFERRED => $is_deferred,
 342                         COMPRESSION => has_property($e, "compression"),
 343                 });
 344         }
 345
 346         if (my $switch = has_property($e, "switch_is")) {
 347                 push (@$order, {
 348                         TYPE => "SWITCH",
 349                         SWITCH_IS => $switch,
 350                         IS_DEFERRED => $is_deferred
 351                 });
 352         }
 353
 354         if (scalar(@size_is) > 0) {
 355                 fatal($e, "size_is() on non-array element");
 356         }
 357
 358         if (scalar(@length_is) > 0) {
 359                 fatal($e, "length_is() on non-array element");
 360         }
 361
 362         if (has_property($e, "string")) {
 363                 fatal($e, "string() attribute on non-array element");
 364         }
 365
 366         push (@$order, {
 367                 TYPE => "DATA",
 368                 DATA_TYPE => $e->{TYPE},
 369                 IS_DEFERRED => $is_deferred,
 370                 CONTAINS_DEFERRED => can_contain_deferred($e->{TYPE}),
 371                 IS_SURROUNDING => 0 #FIXME
 372         });
 373
 374         my $i = 0;
 375         foreach (@$order) { $_->{LEVEL_INDEX} = $i; $i+=1; }
 376
 377         return $order;
 378 }
 379
 380 sub GetTypedefLevelTable($$$$)
 381 {
 382         my ($e, $data, $pointer_default, $ms_union) = @_;
 383
 384         my $order = [];
 385
 386         push (@$order, {
 387                 TYPE => "TYPEDEF"
 388         });
 389
 390         my $i = 0;
 391         foreach (@$order) { $_->{LEVEL_INDEX} = $i; $i+=1; }
 392
 393         return $order;
 394 }
 395
 396 #####################################################################
 397 # see if a type contains any deferred data
 398 sub can_contain_deferred
 399 {
 400         sub can_contain_deferred;
 401         my ($type, @types_visited) = @_;
 402
 403         return 1 unless (hasType($type)); # assume the worst
 404
 405         $type = getType($type);
 406
 407         return 0 if (Parse::Pidl::Typelist::is_scalar($type));
 408
 409         foreach (@types_visited) {
 410                 if ($_ == $type) {
 411                         # we have already encountered this
 412                         # type, avoid recursion loop here
 413                         # and return
 414                         return 0;
 415                 }
 416         }
 417
 418         return can_contain_deferred($type->{DATA},
 419                 @types_visited) if ($type->{TYPE} eq "TYPEDEF");
 420
 421         return 0 unless defined($type->{ELEMENTS});
 422
 423         foreach (@{$type->{ELEMENTS}}) {
 424                 return 1 if ($_->{POINTERS});
 425                 push(@types_visited,$type);
 426                 if (can_contain_deferred ($_->{TYPE},@types_visited)) {
 427                         pop(@types_visited);
 428                         return 1;
 429                 }
 430                 pop(@types_visited);
 431         }
 432         return 0;
 433 }
 434
 435 sub pointer_type($)
 436 {
 437         my $e = shift;
 438
 439         return undef unless $e->{POINTERS};
 440
 441         return "ref" if (has_property($e, "ref"));
 442         return "full" if (has_property($e, "ptr"));
 443         return "sptr" if (has_property($e, "sptr"));
 444         return "unique" if (has_property($e, "unique"));
 445         return "relative" if (has_property($e, "relative"));
 446         return "relative_short" if (has_property($e, "relative_short"));
 447         return "ignore" if (has_property($e, "ignore"));
 448
 449         return undef;
 450 }
 451
 452 #####################################################################
 453 # work out the correct alignment for a structure or union
 454 sub find_largest_alignment
 455 {
 456         my ($s, @types_visited) = @_;
 457
 458         my $align = 1;
 459         for my $e (@{$s->{ELEMENTS}}) {
 460                 my $a = 1;
 461                 if ($e->{POINTERS}) {
 462                         # this is a hack for NDR64
 463                         # the NDR layer translates this into
 464                         # an alignment of 4 for NDR and 8 for NDR64
 465                         $a = 5;
 466                 } elsif (has_property($e, "subcontext")) {
 467                         $a = 1;
 468                 } elsif (has_property($e, "transmit_as")) {
 469                         $a = align_type($e->{PROPERTIES}->{transmit_as},
 470                                 @types_visited);
 471                 } else {
 472                         $a = align_type($e->{TYPE}, @types_visited);
 473                 }
 474
 475                 $align = $a if ($align < $a);
 476         }
 477
 478         return $align;
 479 }
 480
 481 #####################################################################
 482 # align a type
 483 sub align_type
 484 {
 485         sub align_type;
 486         my ($e, @types_visited) = @_;
 487         if (ref($e) eq "HASH" and $e->{TYPE} eq "SCALAR") {
 488                 my $ret = $scalar_alignment->{$e->{NAME}};
 489                 if (not defined $ret) {
 490                         warning($e, "no scalar alignment for $e->{NAME}!");
 491                         return 0;
 492                 }
 493                 return $ret;
 494         }
 495
 496         return 0 if ($e eq "EMPTY");
 497
 498         unless (hasType($e)) {
 499             # it must be an external type - all we can do is guess
 500                 # warning($e, "assuming alignment of unknown type '$e' is 4");
 501             return 4;
 502         }
 503         my $dt = getType($e);
 504
 505         foreach (@types_visited) {
 506                 if ($_ == $dt) {
 507                         # Chapt 14 of the DCE 1.1: Remote Procedure Call
 508                         # specification (available from pubs.opengroup.org)
 509                         # states:
 510                         # "The alignment of a structure in the octet stream is
 511                         # the largest of the alignments of the fields it
 512                         # contains. These fields may also be constructed types.
 513                         # The same alignment rules apply recursively to
 514                         # nested constructed types. "
 515                         #
 516                         # in the worst case scenario
 517                         # struct c1 {
 518                         #   membertypea mema;
 519                         #   membertypeb memb;
 520                         #   struct c1 memc;
 521                         # }
 522                         # the nested struct c1 memc when encountered
 523                         # returns 0 ensuring the alignment will be calculated
 524                         # based on the other fields
 525                         return 0;
 526                 }
 527         }
 528
 529
 530         if ($dt->{TYPE} eq "TYPEDEF") {
 531                 return align_type($dt->{DATA}, @types_visited);
 532         } elsif ($dt->{TYPE} eq "CONFORMANCE") {
 533                 return $dt->{DATA}->{ALIGN};
 534         } elsif ($dt->{TYPE} eq "ENUM") {
 535                 return align_type(Parse::Pidl::Typelist::enum_type_fn($dt),
 536                         @types_visited);
 537         } elsif ($dt->{TYPE} eq "BITMAP") {
 538                 return align_type(Parse::Pidl::Typelist::bitmap_type_fn($dt),
 539                         @types_visited);
 540         } elsif (($dt->{TYPE} eq "STRUCT") or ($dt->{TYPE} eq "UNION")) {
 541                 # Struct/union without body: assume 4
 542                 return 4 unless (defined($dt->{ELEMENTS}));
 543                 my $res;
 544                 push(@types_visited, $dt);
 545                 $res = find_largest_alignment($dt, @types_visited);
 546                 pop(@types_visited);
 547                 return $res
 548         } elsif (($dt->{TYPE} eq "PIPE")) {
 549                 return 5;
 550         }
 551
 552         die("Unknown data type type $dt->{TYPE}");
 553 }
 554
 555 sub ParseElement($$$)
 556 {
 557         my ($e, $pointer_default, $ms_union) = @_;
 558
 559         $e->{TYPE} = expandAlias($e->{TYPE});
 560
 561         if (ref($e->{TYPE}) eq "HASH") {
 562                 $e->{TYPE} = ParseType($e->{TYPE}, $pointer_default, $ms_union);
 563         }
 564
 565         return {
 566                 NAME => $e->{NAME},
 567                 TYPE => $e->{TYPE},
 568                 PROPERTIES => $e->{PROPERTIES},
 569                 LEVELS => GetElementLevelTable($e, $pointer_default, $ms_union),
 570                 REPRESENTATION_TYPE => ($e->{PROPERTIES}->{represent_as} or $e->{TYPE}),
 571                 ALIGN => align_type($e->{TYPE}),
 572                 ORIGINAL => $e
 573         };
 574 }
 575
 576 sub ParseStruct($$$)
 577 {
 578         my ($struct, $pointer_default, $ms_union) = @_;
 579         my @elements = ();
 580         my $surrounding = undef;
 581
 582         return {
 583                 TYPE => "STRUCT",
 584                 NAME => $struct->{NAME},
 585                 SURROUNDING_ELEMENT => undef,
 586                 ELEMENTS => undef,
 587                 PROPERTIES => $struct->{PROPERTIES},
 588                 ORIGINAL => $struct,
 589                 ALIGN => undef
 590         } unless defined($struct->{ELEMENTS});
 591
 592         CheckPointerTypes($struct, $pointer_default);
 593
 594         foreach my $x (@{$struct->{ELEMENTS}})
 595         {
 596                 my $e = ParseElement($x, $pointer_default, $ms_union);
 597                 if ($x != $struct->{ELEMENTS}[-1] and
 598                         $e->{LEVELS}[0]->{IS_SURROUNDING}) {
 599                         fatal($x, "conformant member not at end of struct");
 600                 }
 601                 push @elements, $e;
 602         }
 603
 604         my $e = $elements[-1];
 605         if (defined($e) and defined($e->{LEVELS}[0]->{IS_SURROUNDING}) and
 606                 $e->{LEVELS}[0]->{IS_SURROUNDING}) {
 607                 $surrounding = $e;
 608         }
 609
 610         if (defined $e->{TYPE} && $e->{TYPE} eq "string"
 611             &&  property_matches($e, "flag", ".*LIBNDR_FLAG_STR_CONFORMANT.*")) {
 612                 $surrounding = $struct->{ELEMENTS}[-1];
 613         }
 614
 615         my $align = undef;
 616         if ($struct->{NAME}) {
 617                 $align = align_type($struct->{NAME});
 618         }
 619
 620         return {
 621                 TYPE => "STRUCT",
 622                 NAME => $struct->{NAME},
 623                 SURROUNDING_ELEMENT => $surrounding,
 624                 ELEMENTS => \@elements,
 625                 PROPERTIES => $struct->{PROPERTIES},
 626                 ORIGINAL => $struct,
 627                 ALIGN => $align
 628         };
 629 }
 630
 631 sub ParseUnion($$)
 632 {
 633         my ($e, $pointer_default, $ms_union) = @_;
 634         my @elements = ();
 635         my $is_ms_union = $ms_union;
 636         $is_ms_union = 1 if has_property($e, "ms_union");
 637         my $hasdefault = 0;
 638         my $switch_type = has_property($e, "switch_type");
 639         unless (defined($switch_type)) { $switch_type = "uint32"; }
 640         if (has_property($e, "nodiscriminant")) { $switch_type = undef; }
 641
 642         return {
 643                 TYPE => "UNION",
 644                 NAME => $e->{NAME},
 645                 SWITCH_TYPE => $switch_type,
 646                 ELEMENTS => undef,
 647                 PROPERTIES => $e->{PROPERTIES},
 648                 HAS_DEFAULT => $hasdefault,
 649                 IS_MS_UNION => $is_ms_union,
 650                 ORIGINAL => $e,
 651                 ALIGN => undef
 652         } unless defined($e->{ELEMENTS});
 653
 654         CheckPointerTypes($e, $pointer_default);
 655
 656         foreach my $x (@{$e->{ELEMENTS}})
 657         {
 658                 my $t;
 659                 if ($x->{TYPE} eq "EMPTY") {
 660                         $t = { TYPE => "EMPTY" };
 661                 } else {
 662                         $t = ParseElement($x, $pointer_default, $ms_union);
 663                 }
 664                 if (has_property($x, "default")) {
 665                         $t->{CASE} = "default";
 666                         $hasdefault = 1;
 667                 } elsif (defined($x->{PROPERTIES}->{case})) {
 668                         $t->{CASE} = "case $x->{PROPERTIES}->{case}";
 669                 } else {
 670                         die("Union element $x->{NAME} has neither default nor case property");
 671                 }
 672                 push @elements, $t;
 673         }
 674
 675         my $align = undef;
 676         if ($e->{NAME}) {
 677                 $align = align_type($e->{NAME});
 678         }
 679
 680         return {
 681                 TYPE => "UNION",
 682                 NAME => $e->{NAME},
 683                 SWITCH_TYPE => $switch_type,
 684                 ELEMENTS => \@elements,
 685                 PROPERTIES => $e->{PROPERTIES},
 686                 HAS_DEFAULT => $hasdefault,
 687                 IS_MS_UNION => $is_ms_union,
 688                 ORIGINAL => $e,
 689                 ALIGN => $align
 690         };
 691 }
 692
 693 sub ParseEnum($$)
 694 {
 695         my ($e, $pointer_default, $ms_union) = @_;
 696
 697         return {
 698                 TYPE => "ENUM",
 699                 NAME => $e->{NAME},
 700                 BASE_TYPE => Parse::Pidl::Typelist::enum_type_fn($e),
 701                 ELEMENTS => $e->{ELEMENTS},
 702                 PROPERTIES => $e->{PROPERTIES},
 703                 ORIGINAL => $e
 704         };
 705 }
 706
 707 sub ParseBitmap($$$)
 708 {
 709         my ($e, $pointer_default, $ms_union) = @_;
 710
 711         return {
 712                 TYPE => "BITMAP",
 713                 NAME => $e->{NAME},
 714                 BASE_TYPE => Parse::Pidl::Typelist::bitmap_type_fn($e),
 715                 ELEMENTS => $e->{ELEMENTS},
 716                 PROPERTIES => $e->{PROPERTIES},
 717                 ORIGINAL => $e
 718         };
 719 }
 720
 721 sub ParsePipe($$$)
 722 {
 723         my ($pipe, $pointer_default, $ms_union) = @_;
 724
 725         my $pname = $pipe->{NAME};
 726         $pname = $pipe->{PARENT}->{NAME} unless defined $pname;
 727
 728         if (not defined($pipe->{PROPERTIES})
 729             and defined($pipe->{PARENT}->{PROPERTIES})) {
 730                 $pipe->{PROPERTIES} = $pipe->{PARENT}->{PROPERTIES};
 731         }
 732
 733         if (ref($pipe->{DATA}) eq "HASH") {
 734                 if (not defined($pipe->{DATA}->{PROPERTIES})
 735                     and defined($pipe->{PROPERTIES})) {
 736                         $pipe->{DATA}->{PROPERTIES} = $pipe->{PROPERTIES};
 737                 }
 738         }
 739
 740         my $struct = ParseStruct($pipe->{DATA}, $pointer_default, $ms_union);
 741         $struct->{ALIGN} = 5;
 742         $struct->{NAME} = "$pname\_chunk";
 743
 744         # 'count' is element [0] and 'array' [1]
 745         my $e = $struct->{ELEMENTS}[1];
 746         # level [0] is of type "ARRAY"
 747         my $l = $e->{LEVELS}[1];
 748
 749         # here we check that pipe elements have a fixed size type
 750         while (defined($l)) {
 751                 my $cl = $l;
 752                 $l = GetNextLevel($e, $cl);
 753                 if ($cl->{TYPE} ne "DATA") {
 754                         fatal($pipe, el_name($pipe) . ": pipe contains non DATA level");
 755                 }
 756
 757                 # for now we only support scalars
 758                 next if is_fixed_size_scalar($cl->{DATA_TYPE});
 759
 760                 fatal($pipe, el_name($pipe) . ": pipe contains non fixed size type[$cl->{DATA_TYPE}]");
 761         }
 762
 763         return {
 764                 TYPE => "PIPE",
 765                 NAME => $pipe->{NAME},
 766                 DATA => $struct,
 767                 PROPERTIES => $pipe->{PROPERTIES},
 768                 ORIGINAL => $pipe,
 769         };
 770 }
 771
 772 sub ParseType($$$)
 773 {
 774         my ($d, $pointer_default, $ms_union) = @_;
 775
 776         my $data = {
 777                 STRUCT => \&ParseStruct,
 778                 UNION => \&ParseUnion,
 779                 ENUM => \&ParseEnum,
 780                 BITMAP => \&ParseBitmap,
 781                 TYPEDEF => \&ParseTypedef,
 782                 PIPE => \&ParsePipe,
 783         }->{$d->{TYPE}}->($d, $pointer_default, $ms_union);
 784
 785         return $data;
 786 }
 787
 788 sub ParseTypedef($$)
 789 {
 790         my ($d, $pointer_default, $ms_union) = @_;
 791
 792         my $data;
 793
 794         if (ref($d->{DATA}) eq "HASH") {
 795                 if (defined($d->{DATA}->{PROPERTIES})
 796                     and not defined($d->{PROPERTIES})) {
 797                         $d->{PROPERTIES} = $d->{DATA}->{PROPERTIES};
 798                 }
 799
 800                 $data = ParseType($d->{DATA}, $pointer_default, $ms_union);
 801                 $data->{ALIGN} = align_type($d->{NAME});
 802         } else {
 803                 $data = getType($d->{DATA});
 804         }
 805
 806         return {
 807                 NAME => $d->{NAME},
 808                 TYPE => $d->{TYPE},
 809                 PROPERTIES => $d->{PROPERTIES},
 810                 LEVELS => GetTypedefLevelTable($d, $data, $pointer_default, $ms_union),
 811                 DATA => $data,
 812                 ORIGINAL => $d
 813         };
 814 }
 815
 816 sub ParseConst($$)
 817 {
 818         my ($ndr,$d) = @_;
 819
 820         return $d;
 821 }
 822
 823 sub ParseFunction($$$$)
 824 {
 825         my ($ndr,$d,$opnum,$ms_union) = @_;
 826         my @elements = ();
 827         my $rettype = undef;
 828         my $thisopnum = undef;
 829
 830         CheckPointerTypes($d, "ref");
 831
 832         if (not defined($d->{PROPERTIES}{noopnum})) {
 833                 $thisopnum = ${$opnum};
 834                 ${$opnum}++;
 835         }
 836
 837         foreach my $x (@{$d->{ELEMENTS}}) {
 838                 my $e = ParseElement($x, $ndr->{PROPERTIES}->{pointer_default}, $ms_union);
 839                 push (@{$e->{DIRECTION}}, "in") if (has_property($x, "in"));
 840                 push (@{$e->{DIRECTION}}, "out") if (has_property($x, "out"));
 841
 842                 push (@elements, $e);
 843         }
 844
 845         if ($d->{RETURN_TYPE} ne "void") {
 846                 $rettype = expandAlias($d->{RETURN_TYPE});
 847         }
 848
 849         return {
 850                         NAME => $d->{NAME},
 851                         TYPE => "FUNCTION",
 852                         OPNUM => $thisopnum,
 853                         RETURN_TYPE => $rettype,
 854                         PROPERTIES => $d->{PROPERTIES},
 855                         ELEMENTS => \@elements,
 856                         ORIGINAL => $d
 857                 };
 858 }
 859
 860 sub ReturnTypeElement($)
 861 {
 862         my ($fn) = @_;
 863
 864         return undef unless defined($fn->{RETURN_TYPE});
 865
 866         my $e = {
 867                 "NAME" => "result",
 868                 "TYPE" => $fn->{RETURN_TYPE},
 869                 "PROPERTIES" => undef,
 870                 "POINTERS" => 0,
 871                 "ARRAY_LEN" => [],
 872                 "FILE" => $fn->{FILE},
 873                 "LINE" => $fn->{LINE},
 874         };
 875
 876         return ParseElement($e, 0, 0);
 877 }
 878
 879 sub CheckPointerTypes($$)
 880 {
 881         my ($s,$default) = @_;
 882
 883         return unless defined($s->{ELEMENTS});
 884
 885         foreach my $e (@{$s->{ELEMENTS}}) {
 886                 if ($e->{POINTERS} and not defined(pointer_type($e))) {
 887                         $e->{PROPERTIES}->{$default} = '1';
 888                 }
 889         }
 890 }
 891
 892 sub FindNestedTypes($$)
 893 {
 894         sub FindNestedTypes($$);
 895         my ($l, $t) = @_;
 896
 897         return unless defined($t->{ELEMENTS});
 898         return if ($t->{TYPE} eq "ENUM");
 899         return if ($t->{TYPE} eq "BITMAP");
 900
 901         foreach (@{$t->{ELEMENTS}}) {
 902                 if (ref($_->{TYPE}) eq "HASH") {
 903                         push (@$l, $_->{TYPE}) if (defined($_->{TYPE}->{NAME}));
 904                         FindNestedTypes($l, $_->{TYPE});
 905                 }
 906         }
 907 }
 908
 909 sub ParseInterface($)
 910 {
 911         my $idl = shift;
 912         my @types = ();
 913         my @consts = ();
 914         my @functions = ();
 915         my @endpoints;
 916         my $opnum = 0;
 917         my $version;
 918         my $ms_union = 0;
 919         $ms_union = 1 if has_property($idl, "ms_union");
 920
 921         if (not has_property($idl, "pointer_default")) {
 922                 # MIDL defaults to "ptr" in DCE compatible mode (/osf)
 923                 # and "unique" in Microsoft Extensions mode (default)
 924                 $idl->{PROPERTIES}->{pointer_default} = "unique";
 925         }
 926
 927         foreach my $d (@{$idl->{DATA}}) {
 928                 if ($d->{TYPE} eq "FUNCTION") {
 929                         push (@functions, ParseFunction($idl, $d, \$opnum, $ms_union));
 930                 } elsif ($d->{TYPE} eq "CONST") {
 931                         push (@consts, ParseConst($idl, $d));
 932                 } else {
 933                         push (@types, ParseType($d, $idl->{PROPERTIES}->{pointer_default}, $ms_union));
 934                         FindNestedTypes(\@types, $d);
 935                 }
 936         }
 937
 938         $version = "0.0";
 939
 940         if(defined $idl->{PROPERTIES}->{version}) {
 941                 my @if_version = split(/\./, $idl->{PROPERTIES}->{version});
 942                 if ($if_version[0] == $idl->{PROPERTIES}->{version}) {
 943                                 $version = $idl->{PROPERTIES}->{version};
 944                 } else {
 945                                 $version = $if_version[1] << 16 | $if_version[0];
 946                 }
 947         }
 948
 949         # If no endpoint is set, default to the interface name as a named pipe
 950         if (!defined $idl->{PROPERTIES}->{endpoint}) {
 951                 push @endpoints, "\"ncacn_np:[\\\\pipe\\\\" . $idl->{NAME} . "]\"";
 952         } else {
 953                 @endpoints = split /,/, $idl->{PROPERTIES}->{endpoint};
 954         }
 955
 956         return {
 957                 NAME => $idl->{NAME},
 958                 UUID => lc(has_property($idl, "uuid") // ''),
 959                 VERSION => $version,
 960                 TYPE => "INTERFACE",
 961                 PROPERTIES => $idl->{PROPERTIES},
 962                 FUNCTIONS => \@functions,
 963                 CONSTS => \@consts,
 964                 TYPES => \@types,
 965                 ENDPOINTS => \@endpoints,
 966                 ORIGINAL => $idl
 967         };
 968 }
 969
 970 # Convert a IDL tree to a NDR tree
 971 # Gives a result tree describing all that's necessary for easily generating
 972 # NDR parsers / generators
 973 sub Parse($)
 974 {
 975         my $idl = shift;
 976
 977         return undef unless (defined($idl));
 978
 979         Parse::Pidl::NDR::Validate($idl);
 980
 981         my @ndr = ();
 982
 983         foreach (@{$idl}) {
 984                 ($_->{TYPE} eq "CPP_QUOTE") && push(@ndr, $_);
 985                 ($_->{TYPE} eq "INTERFACE") && push(@ndr, ParseInterface($_));
 986                 ($_->{TYPE} eq "IMPORT") && push(@ndr, $_);
 987         }
 988
 989         return \@ndr;
 990 }
 991
 992 sub GetNextLevel($$)
 993 {
 994         my $e = shift;
 995         my $fl = shift;
 996
 997         my $seen = 0;
 998
 999         foreach my $l (@{$e->{LEVELS}}) {
1000                 return $l if ($seen);
1001                 ($seen = 1) if ($l == $fl);
1002         }
1003
1004         return undef;
1005 }
1006
1007 sub GetPrevLevel($$)
1008 {
1009         my ($e,$fl) = @_;
1010         my $prev = undef;
1011
1012         foreach my $l (@{$e->{LEVELS}}) {
1013                 (return $prev) if ($l == $fl);
1014                 $prev = $l;
1015         }
1016
1017         return undef;
1018 }
1019
1020 sub ContainsString($)
1021 {
1022         my ($e) = @_;
1023
1024         if (property_matches($e, "flag", ".*STR_NULLTERM.*")) {
1025                 return 1;
1026         }
1027         if (exists($e->{LEVELS}) and $e->{LEVELS}->[0]->{TYPE} eq "ARRAY" and
1028                 ($e->{LEVELS}->[0]->{IS_FIXED} or $e->{LEVELS}->[0]->{IS_INLINE}) and
1029                 has_property($e, "charset"))
1030         {
1031                 return 1;
1032         }
1033
1034         foreach my $l (@{$e->{LEVELS}}) {
1035                 return 1 if ($l->{TYPE} eq "ARRAY" and $l->{IS_ZERO_TERMINATED});
1036         }
1037         if (property_matches($e, "charset", ".*DOS.*")) {
1038                 return 1;
1039         }
1040
1041         return 0;
1042 }
1043
1044 sub ContainsDeferred($$)
1045 {
1046         my ($e,$l) = @_;
1047
1048         return 1 if ($l->{CONTAINS_DEFERRED});
1049
1050         while ($l = GetNextLevel($e,$l))
1051         {
1052                 return 1 if ($l->{IS_DEFERRED});
1053                 return 1 if ($l->{CONTAINS_DEFERRED});
1054         }
1055
1056         return 0;
1057 }
1058
1059 sub ContainsPipe($$)
1060 {
1061         my ($e,$l) = @_;
1062
1063         return 1 if ($l->{TYPE} eq "PIPE");
1064
1065         while ($l = GetNextLevel($e,$l))
1066         {
1067                 return 1 if ($l->{TYPE} eq "PIPE");
1068         }
1069
1070         return 0;
1071 }
1072
1073 sub el_name($)
1074 {
1075         my $e = shift;
1076         my $name = "<ANONYMOUS>";
1077
1078         $name = $e->{NAME} if defined($e->{NAME});
1079
1080         if (defined($e->{PARENT}) and defined($e->{PARENT}->{NAME})) {
1081                 return "$e->{PARENT}->{NAME}.$name";
1082         }
1083
1084         if (defined($e->{PARENT}) and
1085             defined($e->{PARENT}->{PARENT}) and
1086             defined($e->{PARENT}->{PARENT}->{NAME})) {
1087                 return "$e->{PARENT}->{PARENT}->{NAME}.$name";
1088         }
1089
1090         return $name;
1091 }
1092
1093 ###################################
1094 # find a sibling var in a structure
1095 sub find_sibling($$)
1096 {
1097         my($e,$name) = @_;
1098         my($fn) = $e->{PARENT};
1099
1100         if ($name =~ /\*(.*)/) {
1101                 $name = $1;
1102         }
1103
1104         for my $e2 (@{$fn->{ELEMENTS}}) {
1105                 return $e2 if ($e2->{NAME} eq $name);
1106         }
1107
1108         return undef;
1109 }
1110
1111 my %property_list = (
1112         # interface
1113         "helpstring"            => ["INTERFACE", "FUNCTION"],
1114         "version"               => ["INTERFACE"],
1115         "uuid"                  => ["INTERFACE"],
1116         "endpoint"              => ["INTERFACE"],
1117         "pointer_default"       => ["INTERFACE"],
1118         "helper"                => ["INTERFACE"],
1119         "pyhelper"              => ["INTERFACE"],
1120         "authservice"           => ["INTERFACE"],
1121         "restricted"            => ["INTERFACE"],
1122         "no_srv_register"       => ["INTERFACE"],
1123
1124         # dcom
1125         "object"                => ["INTERFACE"],
1126         "local"                 => ["INTERFACE", "FUNCTION"],
1127         "iid_is"                => ["ELEMENT"],
1128         "call_as"               => ["FUNCTION"],
1129         "idempotent"            => ["FUNCTION"],
1130
1131         # function
1132         "noopnum"               => ["FUNCTION"],
1133         "in"                    => ["ELEMENT"],
1134         "out"                   => ["ELEMENT"],
1135
1136         # pointer
1137         "ref"                   => ["ELEMENT", "TYPEDEF"],
1138         "ptr"                   => ["ELEMENT", "TYPEDEF"],
1139         "unique"                => ["ELEMENT", "TYPEDEF"],
1140         "ignore"                => ["ELEMENT"],
1141         "relative"              => ["ELEMENT", "TYPEDEF"],
1142         "relative_short"        => ["ELEMENT", "TYPEDEF"],
1143         "null_is_ffffffff"      => ["ELEMENT"],
1144         "relative_base"         => ["TYPEDEF", "STRUCT", "UNION"],
1145
1146         "gensize"               => ["TYPEDEF", "STRUCT", "UNION"],
1147         "value"                 => ["ELEMENT"],
1148         "flag"                  => ["ELEMENT", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP", "PIPE"],
1149         "max_recursion"         => ["ELEMENT"],
1150
1151         # generic
1152         "public"                => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP", "PIPE"],
1153         "nopush"                => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP", "PIPE"],
1154         "nopull"                => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP", "PIPE"],
1155         "nosize"                => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP"],
1156         "noprint"               => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP", "ELEMENT", "PIPE"],
1157         "nopython"              => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP"],
1158         "todo"                  => ["FUNCTION"],
1159         "skip"                  => ["ELEMENT"],
1160         "skip_noinit"           => ["ELEMENT"],
1161
1162         # union
1163         "switch_is"             => ["ELEMENT"],
1164         "switch_type"           => ["ELEMENT", "UNION"],
1165         "nodiscriminant"        => ["UNION"],
1166         "ms_union"              => ["INTERFACE", "UNION"],
1167         "case"                  => ["ELEMENT"],
1168         "default"               => ["ELEMENT"],
1169
1170         "represent_as"          => ["ELEMENT"],
1171         "transmit_as"           => ["ELEMENT"],
1172
1173         # subcontext
1174         "subcontext"            => ["ELEMENT"],
1175         "subcontext_size"       => ["ELEMENT"],
1176         "compression"           => ["ELEMENT"],
1177
1178         # enum
1179         "enum8bit"              => ["ENUM"],
1180         "enum16bit"             => ["ENUM"],
1181         "v1_enum"               => ["ENUM"],
1182
1183         # bitmap
1184         "bitmap8bit"            => ["BITMAP"],
1185         "bitmap16bit"           => ["BITMAP"],
1186         "bitmap32bit"           => ["BITMAP"],
1187         "bitmap64bit"           => ["BITMAP"],
1188
1189         # array
1190         "range"                 => ["ELEMENT", "PIPE"],
1191         "size_is"               => ["ELEMENT"],
1192         "string"                => ["ELEMENT"],
1193         "noheader"              => ["ELEMENT"],
1194         "charset"               => ["ELEMENT"],
1195         "length_is"             => ["ELEMENT"],
1196         "to_null"               => ["ELEMENT"],
1197 );
1198
1199 #####################################################################
1200 # check for unknown properties
1201 sub ValidProperties($$)
1202 {
1203         my ($e,$t) = @_;
1204
1205         return unless defined $e->{PROPERTIES};
1206
1207         foreach my $key (keys %{$e->{PROPERTIES}}) {
1208                 warning($e, el_name($e) . ": unknown property '$key'")
1209                         unless defined($property_list{$key});
1210
1211                 fatal($e, el_name($e) . ": property '$key' not allowed on '$t'")
1212                         unless grep(/^$t$/, @{$property_list{$key}});
1213         }
1214 }
1215
1216 sub mapToScalar($)
1217 {
1218         sub mapToScalar($);
1219         my $t = shift;
1220         return $t->{NAME} if (ref($t) eq "HASH" and $t->{TYPE} eq "SCALAR");
1221         my $ti = getType($t);
1222
1223         if (not defined ($ti)) {
1224                 return undef;
1225         } elsif ($ti->{TYPE} eq "TYPEDEF") {
1226                 return mapToScalar($ti->{DATA});
1227         } elsif ($ti->{TYPE} eq "ENUM") {
1228                 return Parse::Pidl::Typelist::enum_type_fn($ti);
1229         } elsif ($ti->{TYPE} eq "BITMAP") {
1230                 return Parse::Pidl::Typelist::bitmap_type_fn($ti);
1231         }
1232
1233         return undef;
1234 }
1235
1236 #####################################################################
1237 # validate an element
1238 sub ValidElement($)
1239 {
1240         my $e = shift;
1241
1242         ValidProperties($e,"ELEMENT");
1243
1244         # Check whether switches are used correctly.
1245         if (my $switch = has_property($e, "switch_is")) {
1246                 my $e2 = find_sibling($e, $switch);
1247                 my $type = getType($e->{TYPE});
1248
1249                 if (defined($type) and $type->{DATA}->{TYPE} ne "UNION") {
1250                         fatal($e, el_name($e) . ": switch_is() used on non-union type $e->{TYPE} which is a $type->{DATA}->{TYPE}");
1251                 }
1252
1253                 if (not has_property($type->{DATA}, "nodiscriminant") and defined($e2)) {
1254                         my $discriminator_type = has_property($type->{DATA}, "switch_type");
1255                         $discriminator_type = "uint32" unless defined ($discriminator_type);
1256
1257                         my $t1 = mapScalarType(mapToScalar($discriminator_type));
1258
1259                         if (not defined($t1)) {
1260                                 fatal($e, el_name($e) . ": unable to map discriminator type '$discriminator_type' to scalar");
1261                         }
1262
1263                         my $t2 = mapScalarType(mapToScalar($e2->{TYPE}));
1264                         if (not defined($t2)) {
1265                                 fatal($e, el_name($e) . ": unable to map variable used for switch_is() to scalar");
1266                         }
1267
1268                         if ($t1 ne $t2) {
1269                                 warning($e, el_name($e) . ": switch_is() is of type $e2->{TYPE} ($t2), while discriminator type for union $type->{NAME} is $discriminator_type ($t1)");
1270                         }
1271                 }
1272         }
1273
1274         if (has_property($e, "subcontext") and has_property($e, "represent_as")) {
1275                 fatal($e, el_name($e) . " : subcontext() and represent_as() can not be used on the same element");
1276         }
1277
1278         if (has_property($e, "subcontext") and has_property($e, "transmit_as")) {
1279                 fatal($e, el_name($e) . " : subcontext() and transmit_as() can not be used on the same element");
1280         }
1281
1282         if (has_property($e, "represent_as") and has_property($e, "transmit_as")) {
1283                 fatal($e, el_name($e) . " : represent_as() and transmit_as() can not be used on the same element");
1284         }
1285
1286         if (has_property($e, "represent_as") and has_property($e, "value")) {
1287                 fatal($e, el_name($e) . " : represent_as() and value() can not be used on the same element");
1288         }
1289
1290         if (has_property($e, "subcontext")) {
1291                 warning($e, "subcontext() is deprecated. Use represent_as() or transmit_as() instead");
1292         }
1293
1294         if (defined (has_property($e, "subcontext_size")) and not defined(has_property($e, "subcontext"))) {
1295                 fatal($e, el_name($e) . " : subcontext_size() on non-subcontext element");
1296         }
1297
1298         if (defined (has_property($e, "compression")) and not defined(has_property($e, "subcontext"))) {
1299                 fatal($e, el_name($e) . " : compression() on non-subcontext element");
1300         }
1301
1302         if (!$e->{POINTERS} && (
1303                 has_property($e, "ptr") or
1304                 has_property($e, "unique") or
1305                 has_property($e, "relative") or
1306                 has_property($e, "relative_short") or
1307                 has_property($e, "ref"))) {
1308                 fatal($e, el_name($e) . " : pointer properties on non-pointer element\n");
1309         }
1310 }
1311
1312 #####################################################################
1313 # validate an enum
1314 sub ValidEnum($)
1315 {
1316         my ($enum) = @_;
1317
1318         ValidProperties($enum, "ENUM");
1319 }
1320
1321 #####################################################################
1322 # validate a bitmap
1323 sub ValidBitmap($)
1324 {
1325         my ($bitmap) = @_;
1326
1327         ValidProperties($bitmap, "BITMAP");
1328 }
1329
1330 #####################################################################
1331 # validate a struct
1332 sub ValidStruct($)
1333 {
1334         my($struct) = shift;
1335
1336         ValidProperties($struct, "STRUCT");
1337
1338         return unless defined($struct->{ELEMENTS});
1339
1340         foreach my $e (@{$struct->{ELEMENTS}}) {
1341                 $e->{PARENT} = $struct;
1342                 ValidElement($e);
1343         }
1344 }
1345
1346 #####################################################################
1347 # parse a union
1348 sub ValidUnion($)
1349 {
1350         my($union) = shift;
1351
1352         ValidProperties($union,"UNION");
1353
1354         if (has_property($union->{PARENT}, "nodiscriminant") and
1355                 has_property($union->{PARENT}, "switch_type")) {
1356                 fatal($union->{PARENT}, $union->{PARENT}->{NAME} . ": switch_type(" . $union->{PARENT}->{PROPERTIES}->{switch_type} . ") on union without discriminant");
1357         }
1358
1359         return unless defined($union->{ELEMENTS});
1360
1361         foreach my $e (@{$union->{ELEMENTS}}) {
1362                 $e->{PARENT} = $union;
1363
1364                 if (defined($e->{PROPERTIES}->{default}) and
1365                         defined($e->{PROPERTIES}->{case})) {
1366                         fatal($e, "Union member $e->{NAME} can not have both default and case properties!");
1367                 }
1368
1369                 unless (defined ($e->{PROPERTIES}->{default}) or
1370                                 defined ($e->{PROPERTIES}->{case})) {
1371                         fatal($e, "Union member $e->{NAME} must have default or case property");
1372                 }
1373
1374                 if (has_property($e, "ref")) {
1375                         fatal($e, el_name($e) . ": embedded ref pointers are not supported yet\n");
1376                 }
1377
1378
1379                 ValidElement($e);
1380         }
1381 }
1382
1383 #####################################################################
1384 # validate a pipe
1385 sub ValidPipe($)
1386 {
1387         my ($pipe) = @_;
1388         my $struct = $pipe->{DATA};
1389
1390         ValidProperties($pipe, "PIPE");
1391
1392         $struct->{PARENT} = $pipe;
1393
1394         $struct->{FILE} = $pipe->{FILE} unless defined($struct->{FILE});
1395         $struct->{LINE} = $pipe->{LINE} unless defined($struct->{LINE});
1396
1397         ValidType($struct);
1398 }
1399
1400 #####################################################################
1401 # parse a typedef
1402 sub ValidTypedef($)
1403 {
1404         my($typedef) = shift;
1405         my $data = $typedef->{DATA};
1406
1407         ValidProperties($typedef, "TYPEDEF");
1408
1409         return unless (ref($data) eq "HASH");
1410
1411         $data->{PARENT} = $typedef;
1412
1413         $data->{FILE} = $typedef->{FILE} unless defined($data->{FILE});
1414         $data->{LINE} = $typedef->{LINE} unless defined($data->{LINE});
1415
1416         ValidType($data);
1417 }
1418
1419 #####################################################################
1420 # validate a function
1421 sub ValidFunction($)
1422 {
1423         my($fn) = shift;
1424
1425         ValidProperties($fn,"FUNCTION");
1426
1427         foreach my $e (@{$fn->{ELEMENTS}}) {
1428                 $e->{PARENT} = $fn;
1429                 if (has_property($e, "ref") && !$e->{POINTERS}) {
1430                         fatal($e, "[ref] variables must be pointers ($fn->{NAME}/$e->{NAME})");
1431                 }
1432                 ValidElement($e);
1433         }
1434 }
1435
1436 #####################################################################
1437 # validate a type
1438 sub ValidType($)
1439 {
1440         my ($t) = @_;
1441
1442         {
1443                 TYPEDEF => \&ValidTypedef,
1444                 STRUCT => \&ValidStruct,
1445                 UNION => \&ValidUnion,
1446                 ENUM => \&ValidEnum,
1447                 BITMAP => \&ValidBitmap,
1448                 PIPE => \&ValidPipe
1449         }->{$t->{TYPE}}->($t);
1450 }
1451
1452 #####################################################################
1453 # parse the interface definitions
1454 sub ValidInterface($)
1455 {
1456         my($interface) = shift;
1457         my($data) = $interface->{DATA};
1458
1459         if (has_property($interface, "helper")) {
1460                 warning($interface, "helper() is pidl-specific and deprecated. Use `include' instead");
1461         }
1462
1463         ValidProperties($interface,"INTERFACE");
1464
1465         if (has_property($interface, "pointer_default")) {
1466                 if (not grep (/$interface->{PROPERTIES}->{pointer_default}/,
1467                                         ("ref", "unique", "ptr"))) {
1468                         fatal($interface, "Unknown default pointer type `$interface->{PROPERTIES}->{pointer_default}'");
1469                 }
1470         }
1471
1472         if (has_property($interface, "object")) {
1473                 if (has_property($interface, "version") &&
1474                         $interface->{PROPERTIES}->{version} != 0) {
1475                         fatal($interface, "Object interfaces must have version 0.0 ($interface->{NAME})");
1476                 }
1477
1478                 if (!defined($interface->{BASE}) &&
1479                         not ($interface->{NAME} eq "IUnknown")) {
1480                         fatal($interface, "Object interfaces must all derive from IUnknown ($interface->{NAME})");
1481                 }
1482         }
1483
1484         foreach my $d (@{$data}) {
1485                 ($d->{TYPE} eq "FUNCTION") && ValidFunction($d);
1486                 ($d->{TYPE} eq "TYPEDEF" or
1487                  $d->{TYPE} eq "STRUCT" or
1488                  $d->{TYPE} eq "UNION" or
1489                  $d->{TYPE} eq "ENUM" or
1490                  $d->{TYPE} eq "BITMAP" or
1491                  $d->{TYPE} eq "PIPE") && ValidType($d);
1492         }
1493
1494 }
1495
1496 #####################################################################
1497 # Validate an IDL structure
1498 sub Validate($)
1499 {
1500         my($idl) = shift;
1501
1502         foreach my $x (@{$idl}) {
1503                 ($x->{TYPE} eq "INTERFACE") &&
1504                     ValidInterface($x);
1505                 ($x->{TYPE} eq "IMPORTLIB") &&
1506                         fatal($x, "importlib() not supported");
1507         }
1508 }
1509
1510 sub is_charset_array($$)
1511 {
1512         my ($e,$l) = @_;
1513
1514         return 0 if ($l->{TYPE} ne "ARRAY");
1515
1516         my $nl = GetNextLevel($e,$l);
1517
1518         return 0 unless ($nl->{TYPE} eq "DATA");
1519
1520         return has_property($e, "charset");
1521 }
1522
1523
1524
1525 1;