source/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 ContainsString);
  38 @EXPORT_OK = qw(GetElementLevelTable ParseElement ValidElement align_type mapToScalar ParseType can_contain_deferred);
  39
  40 use strict;
  41 use Parse::Pidl qw(warning fatal);
  42 use Parse::Pidl::Typelist qw(hasType getType expandAlias);
  43 use Parse::Pidl::Util qw(has_property property_matches);
  44
  45 # Alignment of the built-in scalar types
  46 my $scalar_alignment = {
  47         'void' => 0,
  48         'char' => 1,
  49         'int8' => 1,
  50         'uint8' => 1,
  51         'int16' => 2,
  52         'uint16' => 2,
  53         'int32' => 4,
  54         'uint32' => 4,
  55         'hyper' => 8,
  56         'pointer' => 8,
  57         'dlong' => 4,
  58         'udlong' => 4,
  59         'udlongr' => 4,
  60         'DATA_BLOB' => 4,
  61         'string' => 4,
  62         'string_array' => 4, #???
  63         'time_t' => 4,
  64         'NTTIME' => 4,
  65         'NTTIME_1sec' => 4,
  66         'NTTIME_hyper' => 8,
  67         'WERROR' => 4,
  68         'NTSTATUS' => 4,
  69         'COMRESULT' => 4,
  70         'nbt_string' => 4,
  71         'wrepl_nbt_name' => 4,
  72         'ipv4address' => 4
  73 };
  74
  75 sub GetElementLevelTable($)
  76 {
  77         my $e = shift;
  78
  79         my $order = [];
  80         my $is_deferred = 0;
  81         my @bracket_array = ();
  82         my @length_is = ();
  83         my @size_is = ();
  84         my $pointer_idx = 0;
  85
  86         if (has_property($e, "size_is")) {
  87                 @size_is = split /,/, has_property($e, "size_is");
  88         }
  89
  90         if (has_property($e, "length_is")) {
  91                 @length_is = split /,/, has_property($e, "length_is");
  92         }
  93
  94         if (defined($e->{ARRAY_LEN})) {
  95                 @bracket_array = @{$e->{ARRAY_LEN}};
  96         }
  97
  98         if (has_property($e, "out")) {
  99                 my $needptrs = 1;
 100
 101                 if (has_property($e, "string")) { $needptrs++; }
 102                 if ($#bracket_array >= 0) { $needptrs = 0; }
 103
 104                 warning($e, "[out] argument `$e->{NAME}' not a pointer") if ($needptrs > $e->{POINTERS});
 105         }
 106
 107         # Parse the [][][][] style array stuff
 108         for my $i (0 .. $#bracket_array) {
 109                 my $d = $bracket_array[$#bracket_array - $i];
 110                 my $size = $d;
 111                 my $length = $d;
 112                 my $is_surrounding = 0;
 113                 my $is_varying = 0;
 114                 my $is_conformant = 0;
 115                 my $is_string = 0;
 116                 my $is_fixed = 0;
 117                 my $is_inline = 0;
 118
 119                 if ($d eq "*") {
 120                         $is_conformant = 1;
 121                         if ($size = shift @size_is) {
 122                         } elsif ((scalar(@size_is) == 0) and has_property($e, "string")) {
 123                                 $is_string = 1;
 124                                 delete($e->{PROPERTIES}->{string});
 125                         } else {
 126                                 fatal($e, "Must specify size_is() for conformant array!")
 127                         }
 128
 129                         if (($length = shift @length_is) or $is_string) {
 130                                 $is_varying = 1;
 131                         } else {
 132                                 $length = $size;
 133                         }
 134
 135                         if ($e == $e->{PARENT}->{ELEMENTS}[-1]
 136                                 and $e->{PARENT}->{TYPE} ne "FUNCTION") {
 137                                 $is_surrounding = 1;
 138                         }
 139                 }
 140
 141                 $is_fixed = 1 if (not $is_conformant and Parse::Pidl::Util::is_constant($size));
 142                 $is_inline = 1 if (not $is_conformant and not Parse::Pidl::Util::is_constant($size));
 143
 144                 push (@$order, {
 145                         TYPE => "ARRAY",
 146                         SIZE_IS => $size,
 147                         LENGTH_IS => $length,
 148                         IS_DEFERRED => $is_deferred,
 149                         IS_SURROUNDING => $is_surrounding,
 150                         IS_ZERO_TERMINATED => $is_string,
 151                         IS_VARYING => $is_varying,
 152                         IS_CONFORMANT => $is_conformant,
 153                         IS_FIXED => $is_fixed,
 154                         IS_INLINE => $is_inline
 155                 });
 156         }
 157
 158         # Next, all the pointers
 159         foreach my $i (1..$e->{POINTERS}) {
 160                 my $pt = pointer_type($e);
 161
 162                 my $level = "EMBEDDED";
 163                 # Top level "ref" pointers do not have a referrent identifier
 164                 $level = "TOP" if ( defined($pt)
 165                                 and $i == 1
 166                                 and $e->{PARENT}->{TYPE} eq "FUNCTION");
 167
 168                 push (@$order, {
 169                         TYPE => "POINTER",
 170                         # for now, there can only be one pointer type per element
 171                         POINTER_TYPE => pointer_type($e),
 172                         POINTER_INDEX => $pointer_idx,
 173                         IS_DEFERRED => "$is_deferred",
 174                         LEVEL => $level
 175                 });
 176
 177                 warning($e, "top-level \[out\] pointer `$e->{NAME}' is not a \[ref\] pointer")
 178                         if ($i == 1 and pointer_type($e) ne "ref" and
 179                                 $e->{PARENT}->{TYPE} eq "FUNCTION" and
 180                                 not has_property($e, "in"));
 181
 182                 $pointer_idx++;
 183
 184                 # everything that follows will be deferred
 185                 $is_deferred = 1 if ($e->{PARENT}->{TYPE} ne "FUNCTION");
 186
 187                 my $array_size = shift @size_is;
 188                 my $array_length;
 189                 my $is_varying;
 190                 my $is_conformant;
 191                 my $is_string = 0;
 192                 if ($array_size) {
 193                         $is_conformant = 1;
 194                         if ($array_length = shift @length_is) {
 195                                 $is_varying = 1;
 196                         } else {
 197                                 $array_length = $array_size;
 198                                 $is_varying =0;
 199                         }
 200                 }
 201
 202                 if (scalar(@size_is) == 0 and has_property($e, "string") and
 203                     $i == $e->{POINTERS}) {
 204                         $is_string = 1;
 205                         $is_varying = $is_conformant = has_property($e, "noheader")?0:1;
 206                         delete($e->{PROPERTIES}->{string});
 207                 }
 208
 209                 if ($array_size or $is_string) {
 210                         push (@$order, {
 211                                 TYPE => "ARRAY",
 212                                 SIZE_IS => $array_size,
 213                                 LENGTH_IS => $array_length,
 214                                 IS_DEFERRED => $is_deferred,
 215                                 IS_SURROUNDING => 0,
 216                                 IS_ZERO_TERMINATED => $is_string,
 217                                 IS_VARYING => $is_varying,
 218                                 IS_CONFORMANT => $is_conformant,
 219                                 IS_FIXED => 0,
 220                                 IS_INLINE => 0
 221                         });
 222
 223                         $is_deferred = 0;
 224                 }
 225         }
 226
 227         if (defined(has_property($e, "subcontext"))) {
 228                 my $hdr_size = has_property($e, "subcontext");
 229                 my $subsize = has_property($e, "subcontext_size");
 230                 if (not defined($subsize)) {
 231                         $subsize = -1;
 232                 }
 233
 234                 push (@$order, {
 235                         TYPE => "SUBCONTEXT",
 236                         HEADER_SIZE => $hdr_size,
 237                         SUBCONTEXT_SIZE => $subsize,
 238                         IS_DEFERRED => $is_deferred,
 239                         COMPRESSION => has_property($e, "compression"),
 240                 });
 241         }
 242
 243         if (my $switch = has_property($e, "switch_is")) {
 244                 push (@$order, {
 245                         TYPE => "SWITCH",
 246                         SWITCH_IS => $switch,
 247                         IS_DEFERRED => $is_deferred
 248                 });
 249         }
 250
 251         if (scalar(@size_is) > 0) {
 252                 fatal($e, "size_is() on non-array element");
 253         }
 254
 255         if (scalar(@length_is) > 0) {
 256                 fatal($e, "length_is() on non-array element");
 257         }
 258
 259         if (has_property($e, "string")) {
 260                 fatal($e, "string() attribute on non-array element");
 261         }
 262
 263         push (@$order, {
 264                 TYPE => "DATA",
 265                 DATA_TYPE => $e->{TYPE},
 266                 IS_DEFERRED => $is_deferred,
 267                 CONTAINS_DEFERRED => can_contain_deferred($e->{TYPE}),
 268                 IS_SURROUNDING => 0 #FIXME
 269         });
 270
 271         my $i = 0;
 272         foreach (@$order) { $_->{LEVEL_INDEX} = $i; $i+=1; }
 273
 274         return $order;
 275 }
 276
 277 #####################################################################
 278 # see if a type contains any deferred data
 279 sub can_contain_deferred($)
 280 {
 281         sub can_contain_deferred($);
 282         my ($type) = @_;
 283
 284         return 1 unless (hasType($type)); # assume the worst
 285
 286         $type = getType($type);
 287
 288         return 0 if (Parse::Pidl::Typelist::is_scalar($type));
 289
 290         return can_contain_deferred($type->{DATA}) if ($type->{TYPE} eq "TYPEDEF");
 291
 292         return 0 unless defined($type->{ELEMENTS});
 293
 294         foreach (@{$type->{ELEMENTS}}) {
 295                 return 1 if ($_->{POINTERS});
 296                 return 1 if (can_contain_deferred ($_->{TYPE}));
 297         }
 298
 299         return 0;
 300 }
 301
 302 sub pointer_type($)
 303 {
 304         my $e = shift;
 305
 306         return undef unless $e->{POINTERS};
 307
 308         return "ref" if (has_property($e, "ref"));
 309         return "full" if (has_property($e, "ptr"));
 310         return "sptr" if (has_property($e, "sptr"));
 311         return "unique" if (has_property($e, "unique"));
 312         return "relative" if (has_property($e, "relative"));
 313         return "ignore" if (has_property($e, "ignore"));
 314
 315         return undef;
 316 }
 317
 318 #####################################################################
 319 # work out the correct alignment for a structure or union
 320 sub find_largest_alignment($)
 321 {
 322         my $s = shift;
 323
 324         my $align = 1;
 325         for my $e (@{$s->{ELEMENTS}}) {
 326                 my $a = 1;
 327
 328                 if ($e->{POINTERS}) {
 329                         $a = 4;
 330                 } elsif (has_property($e, "subcontext")) {
 331                         $a = 1;
 332                 } elsif (has_property($e, "transmit_as")) {
 333                         $a = align_type($e->{PROPERTIES}->{transmit_as});
 334                 } else {
 335                         $a = align_type($e->{TYPE});
 336                 }
 337
 338                 $align = $a if ($align < $a);
 339         }
 340
 341         return $align;
 342 }
 343
 344 #####################################################################
 345 # align a type
 346 sub align_type($)
 347 {
 348         sub align_type($);
 349         my ($e) = @_;
 350
 351         if (ref($e) eq "HASH" and $e->{TYPE} eq "SCALAR") {
 352                 return $scalar_alignment->{$e->{NAME}};
 353         }
 354
 355         return 0 if ($e eq "EMPTY");
 356
 357         unless (hasType($e)) {
 358             # it must be an external type - all we can do is guess
 359                 # warning($e, "assuming alignment of unknown type '$e' is 4");
 360             return 4;
 361         }
 362
 363         my $dt = getType($e);
 364
 365         if ($dt->{TYPE} eq "TYPEDEF") {
 366                 return align_type($dt->{DATA});
 367         } elsif ($dt->{TYPE} eq "ENUM") {
 368                 return align_type(Parse::Pidl::Typelist::enum_type_fn($dt));
 369         } elsif ($dt->{TYPE} eq "BITMAP") {
 370                 return align_type(Parse::Pidl::Typelist::bitmap_type_fn($dt));
 371         } elsif (($dt->{TYPE} eq "STRUCT") or ($dt->{TYPE} eq "UNION")) {
 372                 # Struct/union without body: assume 4
 373                 return 4 unless (defined($dt->{ELEMENTS}));
 374                 return find_largest_alignment($dt);
 375         }
 376
 377         die("Unknown data type type $dt->{TYPE}");
 378 }
 379
 380 sub ParseElement($$)
 381 {
 382         my ($e, $pointer_default) = @_;
 383
 384         $e->{TYPE} = expandAlias($e->{TYPE});
 385
 386         if (ref($e->{TYPE}) eq "HASH") {
 387                 $e->{TYPE} = ParseType($e->{TYPE}, $pointer_default);
 388         }
 389
 390         return {
 391                 NAME => $e->{NAME},
 392                 TYPE => $e->{TYPE},
 393                 PROPERTIES => $e->{PROPERTIES},
 394                 LEVELS => GetElementLevelTable($e),
 395                 REPRESENTATION_TYPE => ($e->{PROPERTIES}->{represent_as} or $e->{TYPE}),
 396                 ALIGN => align_type($e->{TYPE}),
 397                 ORIGINAL => $e
 398         };
 399 }
 400
 401 sub ParseStruct($$)
 402 {
 403         my ($struct, $pointer_default) = @_;
 404         my @elements = ();
 405         my $surrounding = undef;
 406
 407         return {
 408                 TYPE => "STRUCT",
 409                 NAME => $struct->{NAME},
 410                 SURROUNDING_ELEMENT => undef,
 411                 ELEMENTS => undef,
 412                 PROPERTIES => $struct->{PROPERTIES},
 413                 ORIGINAL => $struct,
 414                 ALIGN => undef
 415         } unless defined($struct->{ELEMENTS});
 416
 417         CheckPointerTypes($struct, $pointer_default);
 418
 419         foreach my $x (@{$struct->{ELEMENTS}})
 420         {
 421                 my $e = ParseElement($x, $pointer_default);
 422                 if ($x != $struct->{ELEMENTS}[-1] and
 423                         $e->{LEVELS}[0]->{IS_SURROUNDING}) {
 424                         fatal($x, "conformant member not at end of struct");
 425                 }
 426                 push @elements, $e;
 427         }
 428
 429         my $e = $elements[-1];
 430         if (defined($e) and defined($e->{LEVELS}[0]->{IS_SURROUNDING}) and
 431                 $e->{LEVELS}[0]->{IS_SURROUNDING}) {
 432                 $surrounding = $e;
 433         }
 434
 435         if (defined $e->{TYPE} && $e->{TYPE} eq "string"
 436             &&  property_matches($e, "flag", ".*LIBNDR_FLAG_STR_CONFORMANT.*")) {
 437                 $surrounding = $struct->{ELEMENTS}[-1];
 438         }
 439
 440         my $align = undef;
 441         if ($struct->{NAME}) {
 442                 $align = align_type($struct->{NAME});
 443         }
 444
 445         return {
 446                 TYPE => "STRUCT",
 447                 NAME => $struct->{NAME},
 448                 SURROUNDING_ELEMENT => $surrounding,
 449                 ELEMENTS => \@elements,
 450                 PROPERTIES => $struct->{PROPERTIES},
 451                 ORIGINAL => $struct,
 452                 ALIGN => $align
 453         };
 454 }
 455
 456 sub ParseUnion($$)
 457 {
 458         my ($e, $pointer_default) = @_;
 459         my @elements = ();
 460         my $hasdefault = 0;
 461         my $switch_type = has_property($e, "switch_type");
 462         unless (defined($switch_type)) { $switch_type = "uint32"; }
 463         if (has_property($e, "nodiscriminant")) { $switch_type = undef; }
 464
 465         return {
 466                 TYPE => "UNION",
 467                 NAME => $e->{NAME},
 468                 SWITCH_TYPE => $switch_type,
 469                 ELEMENTS => undef,
 470                 PROPERTIES => $e->{PROPERTIES},
 471                 HAS_DEFAULT => $hasdefault,
 472                 ORIGINAL => $e
 473         } unless defined($e->{ELEMENTS});
 474
 475         CheckPointerTypes($e, $pointer_default);
 476
 477         foreach my $x (@{$e->{ELEMENTS}})
 478         {
 479                 my $t;
 480                 if ($x->{TYPE} eq "EMPTY") {
 481                         $t = { TYPE => "EMPTY" };
 482                 } else {
 483                         $t = ParseElement($x, $pointer_default);
 484                 }
 485                 if (has_property($x, "default")) {
 486                         $t->{CASE} = "default";
 487                         $hasdefault = 1;
 488                 } elsif (defined($x->{PROPERTIES}->{case})) {
 489                         $t->{CASE} = "case $x->{PROPERTIES}->{case}";
 490                 } else {
 491                         die("Union element $x->{NAME} has neither default nor case property");
 492                 }
 493                 push @elements, $t;
 494         }
 495
 496         return {
 497                 TYPE => "UNION",
 498                 NAME => $e->{NAME},
 499                 SWITCH_TYPE => $switch_type,
 500                 ELEMENTS => \@elements,
 501                 PROPERTIES => $e->{PROPERTIES},
 502                 HAS_DEFAULT => $hasdefault,
 503                 ORIGINAL => $e
 504         };
 505 }
 506
 507 sub ParseEnum($$)
 508 {
 509         my ($e, $pointer_default) = @_;
 510
 511         return {
 512                 TYPE => "ENUM",
 513                 NAME => $e->{NAME},
 514                 BASE_TYPE => Parse::Pidl::Typelist::enum_type_fn($e),
 515                 ELEMENTS => $e->{ELEMENTS},
 516                 PROPERTIES => $e->{PROPERTIES},
 517                 ORIGINAL => $e
 518         };
 519 }
 520
 521 sub ParseBitmap($$)
 522 {
 523         my ($e, $pointer_default) = @_;
 524
 525         return {
 526                 TYPE => "BITMAP",
 527                 NAME => $e->{NAME},
 528                 BASE_TYPE => Parse::Pidl::Typelist::bitmap_type_fn($e),
 529                 ELEMENTS => $e->{ELEMENTS},
 530                 PROPERTIES => $e->{PROPERTIES},
 531                 ORIGINAL => $e
 532         };
 533 }
 534
 535 sub ParseType($$)
 536 {
 537         my ($d, $pointer_default) = @_;
 538
 539         my $data = {
 540                 STRUCT => \&ParseStruct,
 541                 UNION => \&ParseUnion,
 542                 ENUM => \&ParseEnum,
 543                 BITMAP => \&ParseBitmap,
 544                 TYPEDEF => \&ParseTypedef,
 545         }->{$d->{TYPE}}->($d, $pointer_default);
 546
 547         return $data;
 548 }
 549
 550 sub ParseTypedef($$)
 551 {
 552         my ($d, $pointer_default) = @_;
 553
 554         if (defined($d->{DATA}->{PROPERTIES}) && !defined($d->{PROPERTIES})) {
 555                 $d->{PROPERTIES} = $d->{DATA}->{PROPERTIES};
 556         }
 557
 558         my $data = ParseType($d->{DATA}, $pointer_default);
 559         $data->{ALIGN} = align_type($d->{NAME});
 560
 561         return {
 562                 NAME => $d->{NAME},
 563                 TYPE => $d->{TYPE},
 564                 PROPERTIES => $d->{PROPERTIES},
 565                 DATA => $data,
 566                 ORIGINAL => $d
 567         };
 568 }
 569
 570 sub ParseConst($$)
 571 {
 572         my ($ndr,$d) = @_;
 573
 574         return $d;
 575 }
 576
 577 sub ParseFunction($$$)
 578 {
 579         my ($ndr,$d,$opnum) = @_;
 580         my @elements = ();
 581         my $rettype = undef;
 582         my $thisopnum = undef;
 583
 584         CheckPointerTypes($d, $ndr->{PROPERTIES}->{pointer_default_top});
 585
 586         if (not defined($d->{PROPERTIES}{noopnum})) {
 587                 $thisopnum = ${$opnum};
 588                 ${$opnum}++;
 589         }
 590
 591         foreach my $x (@{$d->{ELEMENTS}}) {
 592                 my $e = ParseElement($x, $ndr->{PROPERTIES}->{pointer_default});
 593                 push (@{$e->{DIRECTION}}, "in") if (has_property($x, "in"));
 594                 push (@{$e->{DIRECTION}}, "out") if (has_property($x, "out"));
 595
 596                 push (@elements, $e);
 597         }
 598
 599         if ($d->{RETURN_TYPE} ne "void") {
 600                 $rettype = expandAlias($d->{RETURN_TYPE});
 601         }
 602
 603         my $async = 0;
 604         if (has_property($d, "async")) { $async = 1; }
 605
 606         return {
 607                         NAME => $d->{NAME},
 608                         TYPE => "FUNCTION",
 609                         OPNUM => $thisopnum,
 610                         ASYNC => $async,
 611                         RETURN_TYPE => $rettype,
 612                         PROPERTIES => $d->{PROPERTIES},
 613                         ELEMENTS => \@elements,
 614                         ORIGINAL => $d
 615                 };
 616 }
 617
 618 sub CheckPointerTypes($$)
 619 {
 620         my ($s,$default) = @_;
 621
 622         return unless defined($s->{ELEMENTS});
 623
 624         foreach my $e (@{$s->{ELEMENTS}}) {
 625                 if ($e->{POINTERS} and not defined(pointer_type($e))) {
 626                         $e->{PROPERTIES}->{$default} = 1;
 627                 }
 628         }
 629 }
 630
 631 sub FindNestedTypes($$)
 632 {
 633         sub FindNestedTypes($$);
 634         my ($l, $t) = @_;
 635
 636         return if not defined($t->{ELEMENTS});
 637         return if ($t->{TYPE} eq "ENUM");
 638         return if ($t->{TYPE} eq "BITMAP");
 639
 640         foreach (@{$t->{ELEMENTS}}) {
 641                 if (ref($_->{TYPE}) eq "HASH") {
 642                         push (@$l, $_->{TYPE}) if (defined($_->{TYPE}->{NAME}));
 643                         FindNestedTypes($l, $_->{TYPE});
 644                 }
 645         }
 646 }
 647
 648 sub ParseInterface($)
 649 {
 650         my $idl = shift;
 651         my @types = ();
 652         my @consts = ();
 653         my @functions = ();
 654         my @endpoints;
 655         my $opnum = 0;
 656         my $version;
 657
 658         if (not has_property($idl, "pointer_default")) {
 659                 # MIDL defaults to "ptr" in DCE compatible mode (/osf)
 660                 # and "unique" in Microsoft Extensions mode (default)
 661                 $idl->{PROPERTIES}->{pointer_default} = "unique";
 662         }
 663
 664         if (not has_property($idl, "pointer_default_top")) {
 665                 $idl->{PROPERTIES}->{pointer_default_top} = "ref";
 666         } else {
 667                 warning($idl, "pointer_default_top() is a pidl extension and should not be used");
 668         }
 669
 670         foreach my $d (@{$idl->{DATA}}) {
 671                 if ($d->{TYPE} eq "FUNCTION") {
 672                         push (@functions, ParseFunction($idl, $d, \$opnum));
 673                 } elsif ($d->{TYPE} eq "CONST") {
 674                         push (@consts, ParseConst($idl, $d));
 675                 } else {
 676                         push (@types, ParseType($d, $idl->{PROPERTIES}->{pointer_default}));
 677                         FindNestedTypes(\@types, $d);
 678                 }
 679         }
 680
 681         $version = "0.0";
 682
 683         if(defined $idl->{PROPERTIES}->{version}) {
 684                 $version = $idl->{PROPERTIES}->{version};
 685         }
 686
 687         # If no endpoint is set, default to the interface name as a named pipe
 688         if (!defined $idl->{PROPERTIES}->{endpoint}) {
 689                 push @endpoints, "\"ncacn_np:[\\\\pipe\\\\" . $idl->{NAME} . "]\"";
 690         } else {
 691                 @endpoints = split / /, $idl->{PROPERTIES}->{endpoint};
 692         }
 693
 694         return {
 695                 NAME => $idl->{NAME},
 696                 UUID => lc(has_property($idl, "uuid")),
 697                 VERSION => $version,
 698                 TYPE => "INTERFACE",
 699                 PROPERTIES => $idl->{PROPERTIES},
 700                 FUNCTIONS => \@functions,
 701                 CONSTS => \@consts,
 702                 TYPES => \@types,
 703                 ENDPOINTS => \@endpoints
 704         };
 705 }
 706
 707 # Convert a IDL tree to a NDR tree
 708 # Gives a result tree describing all that's necessary for easily generating
 709 # NDR parsers / generators
 710 sub Parse($)
 711 {
 712         my $idl = shift;
 713
 714         return undef unless (defined($idl));
 715
 716         Parse::Pidl::NDR::Validate($idl);
 717
 718         my @ndr = ();
 719
 720         foreach (@{$idl}) {
 721                 ($_->{TYPE} eq "CPP_QUOTE") && push(@ndr, $_);
 722                 ($_->{TYPE} eq "INTERFACE") && push(@ndr, ParseInterface($_));
 723                 ($_->{TYPE} eq "IMPORT") && push(@ndr, $_);
 724         }
 725
 726         return \@ndr;
 727 }
 728
 729 sub GetNextLevel($$)
 730 {
 731         my $e = shift;
 732         my $fl = shift;
 733
 734         my $seen = 0;
 735
 736         foreach my $l (@{$e->{LEVELS}}) {
 737                 return $l if ($seen);
 738                 ($seen = 1) if ($l == $fl);
 739         }
 740
 741         return undef;
 742 }
 743
 744 sub GetPrevLevel($$)
 745 {
 746         my ($e,$fl) = @_;
 747         my $prev = undef;
 748
 749         foreach my $l (@{$e->{LEVELS}}) {
 750                 (return $prev) if ($l == $fl);
 751                 $prev = $l;
 752         }
 753
 754         return undef;
 755 }
 756
 757 sub ContainsString($)
 758 {
 759         my ($e) = @_;
 760
 761         foreach my $l (@{$e->{LEVELS}}) {
 762                 return 1 if ($l->{TYPE} eq "ARRAY" and $l->{IS_ZERO_TERMINATED});
 763         }
 764
 765         return 0;
 766 }
 767
 768 sub ContainsDeferred($$)
 769 {
 770         my ($e,$l) = @_;
 771
 772         return 1 if ($l->{CONTAINS_DEFERRED});
 773
 774         while ($l = GetNextLevel($e,$l))
 775         {
 776                 return 1 if ($l->{IS_DEFERRED});
 777                 return 1 if ($l->{CONTAINS_DEFERRED});
 778         }
 779
 780         return 0;
 781 }
 782
 783 sub el_name($)
 784 {
 785         my $e = shift;
 786
 787         if ($e->{PARENT} && $e->{PARENT}->{NAME}) {
 788                 return "$e->{PARENT}->{NAME}.$e->{NAME}";
 789         }
 790
 791         if ($e->{PARENT} && $e->{PARENT}->{PARENT}->{NAME}) {
 792                 return "$e->{PARENT}->{PARENT}->{NAME}.$e->{NAME}";
 793         }
 794
 795         if ($e->{PARENT}) {
 796                 return "$e->{PARENT}->{NAME}.$e->{NAME}";
 797         }
 798
 799         return $e->{NAME};
 800 }
 801
 802 ###################################
 803 # find a sibling var in a structure
 804 sub find_sibling($$)
 805 {
 806         my($e,$name) = @_;
 807         my($fn) = $e->{PARENT};
 808
 809         if ($name =~ /\*(.*)/) {
 810                 $name = $1;
 811         }
 812
 813         for my $e2 (@{$fn->{ELEMENTS}}) {
 814                 return $e2 if ($e2->{NAME} eq $name);
 815         }
 816
 817         return undef;
 818 }
 819
 820 my %property_list = (
 821         # interface
 822         "helpstring"            => ["INTERFACE", "FUNCTION"],
 823         "version"               => ["INTERFACE"],
 824         "uuid"                  => ["INTERFACE"],
 825         "endpoint"              => ["INTERFACE"],
 826         "pointer_default"       => ["INTERFACE"],
 827         "pointer_default_top"   => ["INTERFACE"],
 828         "helper"                => ["INTERFACE"],
 829         "authservice"           => ["INTERFACE"],
 830
 831         # dcom
 832         "object"                => ["INTERFACE"],
 833         "local"                 => ["INTERFACE", "FUNCTION"],
 834         "iid_is"                => ["ELEMENT"],
 835         "call_as"               => ["FUNCTION"],
 836         "idempotent"            => ["FUNCTION"],
 837
 838         # function
 839         "noopnum"               => ["FUNCTION"],
 840         "in"                    => ["ELEMENT"],
 841         "out"                   => ["ELEMENT"],
 842         "async"                 => ["FUNCTION"],
 843
 844         # pointer
 845         "ref"                   => ["ELEMENT"],
 846         "ptr"                   => ["ELEMENT"],
 847         "unique"                => ["ELEMENT"],
 848         "ignore"                => ["ELEMENT"],
 849         "relative"              => ["ELEMENT"],
 850         "relative_base"         => ["TYPEDEF"],
 851
 852         "gensize"               => ["TYPEDEF"],
 853         "value"                 => ["ELEMENT"],
 854         "flag"                  => ["ELEMENT", "TYPEDEF"],
 855
 856         # generic
 857         "public"                => ["FUNCTION", "TYPEDEF"],
 858         "nopush"                => ["FUNCTION", "TYPEDEF"],
 859         "nopull"                => ["FUNCTION", "TYPEDEF"],
 860         "nosize"                => ["FUNCTION", "TYPEDEF"],
 861         "noprint"               => ["FUNCTION", "TYPEDEF"],
 862         "noejs"                 => ["FUNCTION", "TYPEDEF"],
 863
 864         # union
 865         "switch_is"             => ["ELEMENT"],
 866         "switch_type"           => ["ELEMENT", "TYPEDEF"],
 867         "nodiscriminant"        => ["TYPEDEF"],
 868         "case"                  => ["ELEMENT"],
 869         "default"               => ["ELEMENT"],
 870
 871         "represent_as"          => ["ELEMENT"],
 872         "transmit_as"           => ["ELEMENT"],
 873
 874         # subcontext
 875         "subcontext"            => ["ELEMENT"],
 876         "subcontext_size"       => ["ELEMENT"],
 877         "compression"           => ["ELEMENT"],
 878
 879         # enum
 880         "enum8bit"              => ["TYPEDEF"],
 881         "enum16bit"             => ["TYPEDEF"],
 882         "v1_enum"               => ["TYPEDEF"],
 883
 884         # bitmap
 885         "bitmap8bit"            => ["TYPEDEF"],
 886         "bitmap16bit"           => ["TYPEDEF"],
 887         "bitmap32bit"           => ["TYPEDEF"],
 888         "bitmap64bit"           => ["TYPEDEF"],
 889
 890         # array
 891         "range"                 => ["ELEMENT"],
 892         "size_is"               => ["ELEMENT"],
 893         "string"                => ["ELEMENT"],
 894         "noheader"              => ["ELEMENT"],
 895         "charset"               => ["ELEMENT"],
 896         "length_is"             => ["ELEMENT"],
 897 );
 898
 899 #####################################################################
 900 # check for unknown properties
 901 sub ValidProperties($$)
 902 {
 903         my ($e,$t) = @_;
 904
 905         return unless defined $e->{PROPERTIES};
 906
 907         foreach my $key (keys %{$e->{PROPERTIES}}) {
 908                 warning($e, el_name($e) . ": unknown property '$key'")
 909                         unless defined($property_list{$key});
 910
 911                 fatal($e, el_name($e) . ": property '$key' not allowed on '$t'")
 912                         unless grep($t, @{$property_list{$key}});
 913         }
 914 }
 915
 916 sub mapToScalar($)
 917 {
 918         sub mapToScalar($);
 919         my $t = shift;
 920         return $t->{NAME} if (ref($t) eq "HASH" and $t->{TYPE} eq "SCALAR");
 921         my $ti = getType($t);
 922
 923         if (not defined ($ti)) {
 924                 return undef;
 925         } elsif ($ti->{TYPE} eq "TYPEDEF") {
 926                 return mapToScalar($ti->{DATA});
 927         } elsif ($ti->{TYPE} eq "ENUM") {
 928                 return Parse::Pidl::Typelist::enum_type_fn($ti);
 929         } elsif ($ti->{TYPE} eq "BITMAP") {
 930                 return Parse::Pidl::Typelist::bitmap_type_fn($ti);
 931         }
 932
 933         return undef;
 934 }
 935
 936 #####################################################################
 937 # validate an element
 938 sub ValidElement($)
 939 {
 940         my $e = shift;
 941
 942         ValidProperties($e,"ELEMENT");
 943
 944         # Check whether switches are used correctly.
 945         if (my $switch = has_property($e, "switch_is")) {
 946                 my $e2 = find_sibling($e, $switch);
 947                 my $type = getType($e->{TYPE});
 948
 949                 if (defined($type) and $type->{DATA}->{TYPE} ne "UNION") {
 950                         fatal($e, el_name($e) . ": switch_is() used on non-union type $e->{TYPE} which is a $type->{DATA}->{TYPE}");
 951                 }
 952
 953                 if (not has_property($type->{DATA}, "nodiscriminant") and defined($e2)) {
 954                         my $discriminator_type = has_property($type->{DATA}, "switch_type");
 955                         $discriminator_type = "uint32" unless defined ($discriminator_type);
 956
 957                         my $t1 = mapToScalar($discriminator_type);
 958
 959                         if (not defined($t1)) {
 960                                 fatal($e, el_name($e) . ": unable to map discriminator type '$discriminator_type' to scalar");
 961                         }
 962
 963                         my $t2 = mapToScalar($e2->{TYPE});
 964                         if (not defined($t2)) {
 965                                 fatal($e, el_name($e) . ": unable to map variable used for switch_is() to scalar");
 966                         }
 967
 968                         if ($t1 ne $t2) {
 969                                 warning($e, el_name($e) . ": switch_is() is of type $e2->{TYPE} ($t2), while discriminator type for union $type->{NAME} is $discriminator_type ($t1)");
 970                         }
 971                 }
 972         }
 973
 974         if (has_property($e, "subcontext") and has_property($e, "represent_as")) {
 975                 fatal($e, el_name($e) . " : subcontext() and represent_as() can not be used on the same element");
 976         }
 977
 978         if (has_property($e, "subcontext") and has_property($e, "transmit_as")) {
 979                 fatal($e, el_name($e) . " : subcontext() and transmit_as() can not be used on the same element");
 980         }
 981
 982         if (has_property($e, "represent_as") and has_property($e, "transmit_as")) {
 983                 fatal($e, el_name($e) . " : represent_as() and transmit_as() can not be used on the same element");
 984         }
 985
 986         if (has_property($e, "represent_as") and has_property($e, "value")) {
 987                 fatal($e, el_name($e) . " : represent_as() and value() can not be used on the same element");
 988         }
 989
 990         if (has_property($e, "subcontext")) {
 991                 warning($e, "subcontext() is deprecated. Use represent_as() or transmit_as() instead");
 992         }
 993
 994         if (defined (has_property($e, "subcontext_size")) and not defined(has_property($e, "subcontext"))) {
 995                 fatal($e, el_name($e) . " : subcontext_size() on non-subcontext element");
 996         }
 997
 998         if (defined (has_property($e, "compression")) and not defined(has_property($e, "subcontext"))) {
 999                 fatal($e, el_name($e) . " : compression() on non-subcontext element");
1000         }
1001
1002         if (!$e->{POINTERS} && (
1003                 has_property($e, "ptr") or
1004                 has_property($e, "unique") or
1005                 has_property($e, "relative") or
1006                 has_property($e, "ref"))) {
1007                 fatal($e, el_name($e) . " : pointer properties on non-pointer element\n");
1008         }
1009 }
1010
1011 #####################################################################
1012 # validate an enum
1013 sub ValidEnum($)
1014 {
1015         my ($enum) = @_;
1016
1017         ValidProperties($enum, "ENUM");
1018 }
1019
1020 #####################################################################
1021 # validate a bitmap
1022 sub ValidBitmap($)
1023 {
1024         my ($bitmap) = @_;
1025
1026         ValidProperties($bitmap, "BITMAP");
1027 }
1028
1029 #####################################################################
1030 # validate a struct
1031 sub ValidStruct($)
1032 {
1033         my($struct) = shift;
1034
1035         ValidProperties($struct, "STRUCT");
1036
1037         return unless defined($struct->{ELEMENTS});
1038
1039         foreach my $e (@{$struct->{ELEMENTS}}) {
1040                 $e->{PARENT} = $struct;
1041                 ValidElement($e);
1042         }
1043 }
1044
1045 #####################################################################
1046 # parse a union
1047 sub ValidUnion($)
1048 {
1049         my($union) = shift;
1050
1051         ValidProperties($union,"UNION");
1052
1053         if (has_property($union->{PARENT}, "nodiscriminant") and has_property($union->{PARENT}, "switch_type")) {
1054                 fatal($union->{PARENT}, $union->{PARENT}->{NAME} . ": switch_type() on union without discriminant");
1055         }
1056
1057         return unless defined($union->{ELEMENTS});
1058
1059         foreach my $e (@{$union->{ELEMENTS}}) {
1060                 $e->{PARENT} = $union;
1061
1062                 if (defined($e->{PROPERTIES}->{default}) and
1063                         defined($e->{PROPERTIES}->{case})) {
1064                         fatal($e, "Union member $e->{NAME} can not have both default and case properties!");
1065                 }
1066
1067                 unless (defined ($e->{PROPERTIES}->{default}) or
1068                                 defined ($e->{PROPERTIES}->{case})) {
1069                         fatal($e, "Union member $e->{NAME} must have default or case property");
1070                 }
1071
1072                 if (has_property($e, "ref")) {
1073                         fatal($e, el_name($e) . " : embedded ref pointers are not supported yet\n");
1074                 }
1075
1076
1077                 ValidElement($e);
1078         }
1079 }
1080
1081 #####################################################################
1082 # parse a typedef
1083 sub ValidTypedef($)
1084 {
1085         my($typedef) = shift;
1086         my $data = $typedef->{DATA};
1087
1088         ValidProperties($typedef, "TYPEDEF");
1089
1090         $data->{PARENT} = $typedef;
1091
1092         ValidType($data) if (ref($data) eq "HASH");
1093 }
1094
1095 #####################################################################
1096 # validate a function
1097 sub ValidFunction($)
1098 {
1099         my($fn) = shift;
1100
1101         ValidProperties($fn,"FUNCTION");
1102
1103         foreach my $e (@{$fn->{ELEMENTS}}) {
1104                 $e->{PARENT} = $fn;
1105                 if (has_property($e, "ref") && !$e->{POINTERS}) {
1106                         fatal($e, "[ref] variables must be pointers ($fn->{NAME}/$e->{NAME})");
1107                 }
1108                 ValidElement($e);
1109         }
1110 }
1111
1112 #####################################################################
1113 # validate a type
1114 sub ValidType($)
1115 {
1116         my ($t) = @_;
1117
1118         {
1119                 TYPEDEF => \&ValidTypedef,
1120                 STRUCT => \&ValidStruct,
1121                 UNION => \&ValidUnion,
1122                 ENUM => \&ValidEnum,
1123                 BITMAP => \&ValidBitmap
1124         }->{$t->{TYPE}}->($t);
1125 }
1126
1127 #####################################################################
1128 # parse the interface definitions
1129 sub ValidInterface($)
1130 {
1131         my($interface) = shift;
1132         my($data) = $interface->{DATA};
1133
1134         if (has_property($interface, "helper")) {
1135                 warning($interface, "helper() is pidl-specific and deprecated. Use `include' instead");
1136         }
1137
1138         ValidProperties($interface,"INTERFACE");
1139
1140         if (has_property($interface, "pointer_default")) {
1141                 if (not grep (/$interface->{PROPERTIES}->{pointer_default}/,
1142                                         ("ref", "unique", "ptr"))) {
1143                         fatal($interface, "Unknown default pointer type `$interface->{PROPERTIES}->{pointer_default}'");
1144                 }
1145         }
1146
1147         if (has_property($interface, "object")) {
1148                 if (has_property($interface, "version") &&
1149                         $interface->{PROPERTIES}->{version} != 0) {
1150                         fatal($interface, "Object interfaces must have version 0.0 ($interface->{NAME})");
1151                 }
1152
1153                 if (!defined($interface->{BASE}) &&
1154                         not ($interface->{NAME} eq "IUnknown")) {
1155                         fatal($interface, "Object interfaces must all derive from IUnknown ($interface->{NAME})");
1156                 }
1157         }
1158
1159         foreach my $d (@{$data}) {
1160                 ($d->{TYPE} eq "FUNCTION") && ValidFunction($d);
1161                 ($d->{TYPE} eq "TYPEDEF" or
1162                  $d->{TYPE} eq "STRUCT" or
1163                  $d->{TYPE} eq "UNION" or
1164                  $d->{TYPE} eq "ENUM" or
1165                  $d->{TYPE} eq "BITMAP") && ValidType($d);
1166         }
1167
1168 }
1169
1170 #####################################################################
1171 # Validate an IDL structure
1172 sub Validate($)
1173 {
1174         my($idl) = shift;
1175
1176         foreach my $x (@{$idl}) {
1177                 ($x->{TYPE} eq "INTERFACE") &&
1178                     ValidInterface($x);
1179                 ($x->{TYPE} eq "IMPORTLIB") &&
1180                         fatal($x, "importlib() not supported");
1181         }
1182 }
1183
1184 1;