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