source/build/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-2005
   6 # released under the GNU GPL
   7
   8 package Ndr;
   9
  10 use strict;
  11 use pidl::typelist;
  12
  13 #####################################################################
  14 # return a table describing the order in which the parts of an element
  15 # should be parsed
  16 # Possible level types:
  17 #  - POINTER
  18 #  - ARRAY
  19 #  - SUBCONTEXT
  20 #  - SWITCH
  21 #  - DATA
  22 sub GetElementLevelTable($)
  23 {
  24         my $e = shift;
  25
  26         my $order = [];
  27         my $is_deferred = 0;
  28         my @bracket_array = ();
  29         my @length_is = ();
  30         my @size_is = ();
  31
  32         if (util::has_property($e, "size_is")) {
  33                 @size_is = split /,/, util::has_property($e, "size_is");
  34         }
  35
  36         if (util::has_property($e, "length_is")) {
  37                 @length_is = split /,/, util::has_property($e, "length_is");
  38         }
  39
  40         if (defined($e->{ARRAY_LEN})) {
  41                 @bracket_array = @{$e->{ARRAY_LEN}};
  42         }
  43
  44         # Parse the [][][][] style array stuff
  45         foreach my $d (@bracket_array) {
  46                 my $size = $d;
  47                 my $length = $d;
  48                 my $is_surrounding = 0;
  49                 my $is_varying = 0;
  50                 my $is_conformant = 0;
  51
  52                 if ($d eq "*") {
  53                         $is_conformant = 1;
  54                         unless ($size = shift @size_is) {
  55                                 print "$e->{FILE}:$e->{LINE}: Must specify size_is() for conformant array!\n";
  56                                 exit 1;
  57                         }
  58
  59                         if ($length = shift @length_is) {
  60                                 $is_varying = 1;
  61                         } else {
  62                                 $length = $size;
  63                         }
  64
  65                         if ($e == $e->{PARENT}->{ELEMENTS}[-1]
  66                                 and $e->{PARENT}->{TYPE} ne "FUNCTION") {
  67                                 $is_surrounding = 1;
  68                         }
  69                 }
  70
  71                 push (@$order, {
  72                         TYPE => "ARRAY",
  73                         SIZE_IS => $size,
  74                         LENGTH_IS => $length,
  75                         IS_DEFERRED => "$is_deferred",
  76                         # Inline arrays (which are a pidl extension) are never encoded
  77                         # as surrounding the struct they're part of
  78                         IS_SURROUNDING => "$is_surrounding",
  79                         IS_VARYING => "$is_varying",
  80                         IS_CONFORMANT => "$is_conformant",
  81                         IS_FIXED => (not $is_conformant and util::is_constant($size)),
  82                         NO_METADATA => (not $is_conformant),
  83                         IS_INLINE => (not $is_conformant and not util::is_constant($size))
  84                 });
  85         }
  86
  87         # Next, all the pointers
  88         foreach my $i (1..$e->{POINTERS}) {
  89                 my $pt = pointer_type($e);
  90
  91                 my $level = "EMBEDDED";
  92                 # Top level "ref" pointers do not have a referrent identifier
  93                 $level = "TOP" if ( defined($pt)
  94                                 and $i == 1
  95                                 and $e->{PARENT}->{TYPE} eq "FUNCTION");
  96
  97                 push (@$order, {
  98                         TYPE => "POINTER",
  99                         # for now, there can only be one pointer type per element
 100                         POINTER_TYPE => pointer_type($e),
 101                         IS_DEFERRED => "$is_deferred",
 102                         LEVEL => $level
 103                 });
 104
 105                 # everything that follows will be deferred
 106                 $is_deferred = 1 if ($e->{PARENT}->{TYPE} ne "FUNCTION");
 107
 108                 my $array_size;
 109                 my $array_length;
 110                 if ($array_size = shift @size_is) {
 111                         my $is_varying = 0;
 112                         if ($array_length = shift @length_is) {
 113                                 $is_varying = 1;
 114                         } else {
 115                                 $array_length = $array_size;
 116                         }
 117
 118                         push (@$order, {
 119                                 TYPE => "ARRAY",
 120                                 SIZE_IS => $array_size,
 121                                 LENGTH_IS => $array_length,
 122                                 IS_DEFERRED => "$is_deferred",
 123                                 IS_SURROUNDING => 0,
 124                                 IS_VARYING => "$is_varying",
 125                                 IS_CONFORMANT => 1,
 126                                 IS_FIXED => 0,
 127                                 NO_METADATA => 0,
 128                                 IS_INLINE => 0,
 129                         });
 130
 131                         $is_deferred = 0;
 132                 }
 133         }
 134
 135         if (defined(util::has_property($e, "subcontext"))) {
 136                 my $hdr_size = util::has_property($e, "subcontext");
 137                 my $subsize = util::has_property($e, "subcontext_size");
 138                 if (not defined($subsize)) {
 139                         $subsize = -1;
 140                 }
 141
 142                 push (@$order, {
 143                         TYPE => "SUBCONTEXT",
 144                         HEADER_SIZE => $hdr_size,
 145                         SUBCONTEXT_SIZE => $subsize,
 146                         IS_DEFERRED => $is_deferred,
 147                         COMPRESSION => util::has_property($e, "compression"),
 148                         OBFUSCATION => util::has_property($e, "obfuscation")
 149                 });
 150         }
 151
 152         if (my $switch = util::has_property($e, "switch_is")) {
 153                 push (@$order, {
 154                         TYPE => "SWITCH",
 155                         SWITCH_IS => $switch,
 156                         IS_DEFERRED => $is_deferred
 157                 });
 158         }
 159
 160         push (@$order, {
 161                 TYPE => "DATA",
 162                 DATA_TYPE => $e->{TYPE},
 163                 IS_DEFERRED => $is_deferred,
 164                 CONTAINS_DEFERRED => can_contain_deferred($e),
 165                 IS_SURROUNDING => is_surrounding_string($e)
 166         });
 167
 168         my $i = 0;
 169         foreach (@$order) { $_->{LEVEL_INDEX} = $i; $i+=1; }
 170
 171         return $order;
 172 }
 173
 174 #####################################################################
 175 # see if a type contains any deferred data
 176 sub can_contain_deferred
 177 {
 178         my $e = shift;
 179
 180         return 1 if ($e->{POINTERS});
 181         return 0 if (typelist::is_scalar($e->{TYPE}));
 182         return 0 if (defined(util::has_property($e, "subcontext")));
 183         return 1 unless (typelist::hasType($e->{TYPE})); # assume the worst
 184
 185         my $type = typelist::getType($e->{TYPE});
 186
 187         foreach my $x (@{$type->{DATA}->{ELEMENTS}}) {
 188                 return 1 if (can_contain_deferred ($x));
 189         }
 190
 191         return 0;
 192 }
 193
 194 sub pointer_type($)
 195 {
 196         my $e = shift;
 197
 198         return undef unless $e->{POINTERS};
 199
 200         return "ref" if (util::has_property($e, "ref"));
 201         return "ptr" if (util::has_property($e, "ptr"));
 202         return "unique" if (util::has_property($e, "unique"));
 203         return "relative" if (util::has_property($e, "relative"));
 204         return "ignore" if (util::has_property($e, "ignore"));
 205
 206         return undef;
 207 }
 208
 209 sub is_surrounding_string($)
 210 {
 211         my $e = shift;
 212
 213         return 0; #FIXME
 214
 215         return ($e->{TYPE} eq "string") and ($e->{POINTERS} == 0)
 216                 and util::property_matches($e, "flag", ".*LIBNDR_FLAG_STR_CONFORMANT.*")
 217                 and $e->{PARENT}->{TYPE} ne "FUNCTION";
 218 }
 219
 220
 221 #####################################################################
 222 # work out the correct alignment for a structure or union
 223 sub find_largest_alignment($)
 224 {
 225         my $s = shift;
 226
 227         my $align = 1;
 228         for my $e (@{$s->{ELEMENTS}}) {
 229                 my $a = 1;
 230
 231                 if (Ndr::need_wire_pointer($e)) {
 232                         $a = 4;
 233                 } else {
 234                         $a = align_type($e->{TYPE});
 235                 }
 236
 237                 $align = $a if ($align < $a);
 238         }
 239
 240         return $align;
 241 }
 242
 243 #####################################################################
 244 # align a type
 245 sub align_type
 246 {
 247         my $e = shift;
 248
 249         unless (typelist::hasType($e)) {
 250             # it must be an external type - all we can do is guess
 251                 # print "Warning: assuming alignment of unknown type '$e' is 4\n";
 252             return 4;
 253         }
 254
 255         my $dt = typelist::getType($e)->{DATA};
 256
 257         if ($dt->{TYPE} eq "ENUM") {
 258                 return align_type(typelist::enum_type_fn($dt));
 259         } elsif ($dt->{TYPE} eq "BITMAP") {
 260                 return align_type(typelist::bitmap_type_fn($dt));
 261         } elsif (($dt->{TYPE} eq "STRUCT") or ($dt->{TYPE} eq "UNION")) {
 262                 return find_largest_alignment($dt);
 263         } elsif ($dt->{TYPE} eq "SCALAR") {
 264                 return typelist::getScalarAlignment($dt->{NAME});
 265         }
 266
 267         die("Unknown data type type $dt->{TYPE}");
 268 }
 269
 270 # determine if an element needs a reference pointer on the wire
 271 # in its NDR representation
 272 sub need_wire_pointer($)
 273 {
 274         my $e = shift;
 275
 276         my $n = $e->{POINTERS};
 277         my $pt = pointer_type($e);
 278
 279         # Top level "ref" pointers do not have a referrent identifier
 280         if (    defined($pt)
 281                 and $pt eq "ref"
 282                 and $e->{PARENT}->{TYPE} eq "FUNCTION")
 283         {
 284                 $n--;
 285         }
 286
 287         return $n;
 288 }
 289
 290 sub ParseElement($)
 291 {
 292         my $e = shift;
 293
 294         return {
 295                 NAME => $e->{NAME},
 296                 TYPE => $e->{TYPE},
 297                 PROPERTIES => $e->{PROPERTIES},
 298                 LEVELS => GetElementLevelTable($e)
 299         };
 300 }
 301
 302 sub ParseStruct($)
 303 {
 304         my $struct = shift;
 305         my @elements = ();
 306         my $surrounding = undef;
 307
 308         foreach my $x (@{$struct->{ELEMENTS}})
 309         {
 310                 push @elements, ParseElement($x);
 311         }
 312
 313         my $e = $elements[-1];
 314         if (defined($e) and defined($e->{LEVELS}[0]->{IS_SURROUNDING}) and
 315                 $e->{LEVELS}[0]->{IS_SURROUNDING}) {
 316                 $surrounding = $e;
 317         }
 318
 319         if (defined $e->{TYPE} && $e->{TYPE} eq "string"
 320             &&  util::property_matches($e, "flag", ".*LIBNDR_FLAG_STR_CONFORMANT.*")) {
 321                 $surrounding = $struct->{ELEMENTS}[-1];
 322         }
 323
 324         return {
 325                 TYPE => "STRUCT",
 326                 SURROUNDING_ELEMENT => $surrounding,
 327                 ELEMENTS => \@elements,
 328                 PROPERTIES => $struct->{PROPERTIES}
 329         };
 330 }
 331
 332 sub ParseUnion($)
 333 {
 334         my $e = shift;
 335         my @elements = ();
 336         my $switch_type = util::has_property($e, "switch_type");
 337         unless (defined($switch_type)) { $switch_type = "uint32"; }
 338
 339         if (util::has_property($e, "nodiscriminant")) { $switch_type = undef; }
 340
 341         foreach my $x (@{$e->{ELEMENTS}})
 342         {
 343                 my $t;
 344                 if ($x->{TYPE} eq "EMPTY") {
 345                         $t = { TYPE => "EMPTY" };
 346                 } else {
 347                         $t = ParseElement($x);
 348                 }
 349                 if (util::has_property($x, "default")) {
 350                         $t->{CASE} = "default";
 351                 } elsif (defined($x->{PROPERTIES}->{case})) {
 352                         $t->{CASE} = "case $x->{PROPERTIES}->{case}";
 353                 } else {
 354                         die("Union element $x->{NAME} has neither default nor case property");
 355                 }
 356                 push @elements, $t;
 357         }
 358
 359         return {
 360                 TYPE => "UNION",
 361                 SWITCH_TYPE => $switch_type,
 362                 ELEMENTS => \@elements,
 363                 PROPERTIES => $e->{PROPERTIES}
 364         };
 365 }
 366
 367 sub ParseEnum($)
 368 {
 369         my $e = shift;
 370
 371         return {
 372                 TYPE => "ENUM",
 373                 BASE_TYPE => typelist::enum_type_fn($e),
 374                 ELEMENTS => $e->{ELEMENTS},
 375                 PROPERTIES => $e->{PROPERTIES}
 376         };
 377 }
 378
 379 sub ParseBitmap($)
 380 {
 381         my $e = shift;
 382
 383         return {
 384                 TYPE => "BITMAP",
 385                 BASE_TYPE => typelist::bitmap_type_fn($e),
 386                 ELEMENTS => $e->{ELEMENTS},
 387                 PROPERTIES => $e->{PROPERTIES}
 388         };
 389 }
 390
 391 sub ParseDeclare($$)
 392 {
 393         my $ndr = shift;
 394         my $d = shift;
 395
 396 }
 397
 398 sub ParseTypedef($$)
 399 {
 400         my $ndr = shift;
 401         my $d = shift;
 402         my $data;
 403
 404         if ($d->{DATA}->{TYPE} eq "STRUCT" or $d->{DATA}->{TYPE} eq "UNION") {
 405                 CheckPointerTypes($d->{DATA}, $ndr->{PROPERTIES}->{pointer_default});
 406         }
 407
 408         if (defined($d->{PROPERTIES}) && !defined($d->{DATA}->{PROPERTIES})) {
 409                 $d->{DATA}->{PROPERTIES} = $d->{PROPERTIES};
 410         }
 411
 412         if ($d->{DATA}->{TYPE} eq "STRUCT") {
 413                 $data = ParseStruct($d->{DATA});
 414         } elsif ($d->{DATA}->{TYPE} eq "UNION") {
 415                 $data = ParseUnion($d->{DATA});
 416         } elsif ($d->{DATA}->{TYPE} eq "ENUM") {
 417                 $data = ParseEnum($d->{DATA});
 418         } elsif ($d->{DATA}->{TYPE} eq "BITMAP") {
 419                 $data = ParseBitmap($d->{DATA});
 420         } else {
 421                 die("Unknown data type '$d->{DATA}->{TYPE}'");
 422         }
 423
 424         $data->{ALIGN} = align_type($d->{NAME});
 425
 426         return {
 427                 NAME => $d->{NAME},
 428                 TYPE => $d->{TYPE},
 429                 PROPERTIES => $d->{PROPERTIES},
 430                 DATA => $data
 431         };
 432 }
 433
 434 sub ParseConst($$)
 435 {
 436         my $ndr = shift;
 437         my $d = shift;
 438
 439         return $d;
 440 }
 441
 442 sub ParseFunction($$$)
 443 {
 444         my $ndr = shift;
 445         my $d = shift;
 446         my $opnum = shift;
 447         my @elements = ();
 448         my $rettype = undef;
 449         my $thisopnum = undef;
 450
 451         CheckPointerTypes($d,
 452                 $ndr->{PROPERTIES}->{pointer_default_top}
 453         );
 454
 455         if (not defined($d->{PROPERTIES}{noopnum})) {
 456                 $thisopnum = ${$opnum};
 457                 ${$opnum}++;
 458         }
 459
 460         foreach my $x (@{$d->{ELEMENTS}}) {
 461                 my $e = ParseElement($x);
 462                 if (util::has_property($x, "in")) {
 463                         push (@{$e->{DIRECTION}}, "in");
 464                 }
 465
 466                 if (util::has_property($x, "out")) {
 467                         push (@{$e->{DIRECTION}}, "out");
 468                 }
 469
 470                 push (@elements, $e);
 471         }
 472
 473         if ($d->{RETURN_TYPE} ne "void") {
 474                 $rettype = $d->{RETURN_TYPE};
 475         }
 476
 477         return {
 478                         NAME => $d->{NAME},
 479                         TYPE => "FUNCTION",
 480                         OPNUM => $thisopnum,
 481                         RETURN_TYPE => $rettype,
 482                         PROPERTIES => $d->{PROPERTIES},
 483                         ELEMENTS => \@elements
 484                 };
 485 }
 486
 487 sub CheckPointerTypes($$)
 488 {
 489         my $s = shift;
 490         my $default = shift;
 491
 492         foreach my $e (@{$s->{ELEMENTS}}) {
 493                 if ($e->{POINTERS}) {
 494                         if (not defined(Ndr::pointer_type($e))) {
 495                                 $e->{PROPERTIES}->{$default} = 1;
 496                         }
 497
 498                         if (Ndr::pointer_type($e) eq "ptr") {
 499                                 print "Warning: ptr is not supported by pidl yet\n";
 500                         }
 501                 }
 502         }
 503 }
 504
 505 sub ParseInterface($)
 506 {
 507         my $idl = shift;
 508         my @typedefs = ();
 509         my @consts = ();
 510         my @functions = ();
 511         my @endpoints;
 512         my @declares = ();
 513         my $opnum = 0;
 514         my $version;
 515
 516         if (not util::has_property($idl, "pointer_default")) {
 517                 # MIDL defaults to "ptr" in DCE compatible mode (/osf)
 518                 # and "unique" in Microsoft Extensions mode (default)
 519                 $idl->{PROPERTIES}->{pointer_default} = "unique";
 520         }
 521
 522         if (not util::has_property($idl, "pointer_default_top")) {
 523                 $idl->{PROPERTIES}->{pointer_default_top} = "ref";
 524         }
 525
 526         foreach my $d (@{$idl->{DATA}}) {
 527                 if ($d->{TYPE} eq "TYPEDEF") {
 528                         push (@typedefs, ParseTypedef($idl, $d));
 529                 }
 530
 531                 if ($d->{TYPE} eq "DECLARE") {
 532                         push (@declares, ParseDeclare($idl, $d));
 533                 }
 534
 535                 if ($d->{TYPE} eq "FUNCTION") {
 536                         push (@functions, ParseFunction($idl, $d, \$opnum));
 537                 }
 538
 539                 if ($d->{TYPE} eq "CONST") {
 540                         push (@consts, ParseConst($idl, $d));
 541                 }
 542         }
 543
 544         $version = "0.0";
 545
 546         if(defined $idl->{PROPERTIES}->{version}) {
 547                 $version = $idl->{PROPERTIES}->{version};
 548         }
 549
 550         # If no endpoint is set, default to the interface name as a named pipe
 551         if (!defined $idl->{PROPERTIES}->{endpoint}) {
 552                 push @endpoints, "\"ncacn_np:[\\\\pipe\\\\" . $idl->{NAME} . "]\"";
 553         } else {
 554                 @endpoints = split / /, $idl->{PROPERTIES}->{endpoint};
 555         }
 556
 557         return {
 558                 NAME => $idl->{NAME},
 559                 UUID => util::has_property($idl, "uuid"),
 560                 VERSION => $version,
 561                 TYPE => "INTERFACE",
 562                 PROPERTIES => $idl->{PROPERTIES},
 563                 FUNCTIONS => \@functions,
 564                 CONSTS => \@consts,
 565                 TYPEDEFS => \@typedefs,
 566                 DECLARES => \@declares,
 567                 ENDPOINTS => \@endpoints
 568         };
 569 }
 570
 571 # Convert a IDL tree to a NDR tree
 572 # Gives a result tree describing all that's necessary for easily generating
 573 # NDR parsers
 574 # - list of interfaces
 575 #  - list with functions
 576 #   - list with in elements
 577 #   - list with out elements
 578 #  - list of typedefs
 579 #   - list with structs
 580 #    - alignment of structure
 581 #    - list with elements
 582 #   - list with unions
 583 #    - alignment of union
 584 #    - list with elements
 585 #   - list with enums
 586 #    - base type
 587 #   - list with bitmaps
 588 #    - base type
 589 # per element:
 590 #  - alignment
 591 #  - "level" table
 592 # properties are saved
 593 # pointer types explicitly specified
 594 sub Parse($)
 595 {
 596         my $idl = shift;
 597         my @ndr = ();
 598
 599         foreach my $x (@{$idl}) {
 600                 push @ndr, ParseInterface($x);
 601         }
 602
 603         return \@ndr;
 604 }
 605
 606 sub GetNextLevel($$)
 607 {
 608         my $e = shift;
 609         my $fl = shift;
 610
 611         my $seen = 0;
 612
 613         foreach my $l (@{$e->{LEVELS}}) {
 614                 return $l if ($seen);
 615                 ($seen = 1) if ($l == $fl);
 616         }
 617
 618         return undef;
 619 }
 620
 621 sub GetPrevLevel($$)
 622 {
 623         my $e = shift;
 624         my $fl = shift;
 625         my $prev = undef;
 626
 627         foreach my $l (@{$e->{LEVELS}}) {
 628                 (return $prev) if ($l == $fl);
 629                 $prev = $l;
 630         }
 631
 632         return undef;
 633 }
 634
 635 sub ContainsDeferred($$)
 636 {
 637         my $e = shift;
 638         my $l = shift;
 639
 640         do {
 641                 return 1 if ($l->{IS_DEFERRED});
 642                 return 1 if ($l->{CONTAINS_DEFERRED});
 643         } while ($l = Ndr::GetNextLevel($e,$l));
 644
 645         return 0;
 646 }
 647
 648
 649 1;