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 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         return ($e->{NDR_ORDER_TABLE}) if (defined $e->{NDR_ORDER_TABLE});
  27
  28         my $order = [];
  29         my $is_deferred = 0;
  30
  31         # FIXME: Process {ARRAY_SIZE} kinds of arrays
  32
  33         # First, all the pointers
  34         foreach my $i (1..need_wire_pointer($e)) {
  35                 push (@$order, {
  36                         TYPE => "POINTER",
  37                         # for now, there can only be one pointer type per element
  38                         POINTER_TYPE => pointer_type($e),
  39                         IS_DEFERRED => "$is_deferred"
  40                 });
  41                 # everything that follows will be deferred
  42                 $is_deferred = 1;
  43                 # FIXME: Process array here possibly (in case of multi-dimensional arrays, etc)
  44         }
  45
  46         if (defined($e->{ARRAY_LEN})) {
  47                 push (@$order, {
  48                         TYPE => "ARRAY",
  49                         ARRAY_TYPE => array_type($e),
  50                         SIZE_IS => util::has_property($e, "size_is"),
  51                         LENGTH_IS => util::has_property($e, "length_is"),
  52                         IS_DEFERRED => "$is_deferred"
  53                 });
  54         }
  55
  56         if (my $sub_size = util::has_property($e, "subcontext")) {
  57                 push (@$order, {
  58                         TYPE => "SUBCONTEXT",
  59                         SUBCONTEXT_SIZE => $sub_size,
  60                         IS_DEFERRED => $is_deferred,
  61                         COMPRESSION => util::has_property($e, "compression")
  62                 });
  63         }
  64
  65         if (my $switch = util::has_property($e, "switch_is")) {
  66                 push (@$order, {
  67                         TYPE => "SWITCH",
  68                         SWITCH_IS => $switch,
  69                         IS_DEFERRED => $is_deferred
  70                 });
  71         }
  72
  73         push (@$order, {
  74                 TYPE => "DATA",
  75                 DATA_TYPE => $e->{TYPE},
  76                 NAME => $e->{NAME},
  77                 IS_DEFERRED => $is_deferred,
  78                 CONTAINS_DEFERRED => can_contain_deferred($e)
  79         });
  80
  81         $e->{NDR_ORDER_TABLE} = $order;
  82
  83         return $order;
  84 }
  85
  86 #####################################################################
  87 # see if a type contains any deferred data
  88 sub can_contain_deferred
  89 {
  90         my $e = shift;
  91
  92         return 1 if ($e->{POINTERS});
  93         return 0 if (is_scalar_type($e->{TYPE}));
  94         return 0 if (util::has_property($e, "subcontext"));
  95         return 1 unless (typelist::hasType($e->{TYPE})); # assume the worst
  96
  97         my $type = typelist::getType($e->{TYPE});
  98
  99         foreach my $x (@{$type->{DATA}->{ELEMENTS}}) {
 100                 return 1 if (can_contain_deferred ($x));
 101         }
 102
 103         return 0;
 104 }
 105
 106 sub is_scalar_type($)
 107 {
 108     my $type = shift;
 109
 110         return 0 unless typelist::hasType($type);
 111
 112         if (my $dt = typelist::getType($type)->{DATA}->{TYPE}) {
 113                 return 1 if ($dt eq "SCALAR" or $dt eq "ENUM" or $dt eq "BITMAP");
 114         }
 115
 116     return 0;
 117 }
 118
 119 sub pointer_type($)
 120 {
 121         my $e = shift;
 122
 123         return undef unless $e->{POINTERS};
 124
 125         return "ref" if (util::has_property($e, "ref"));
 126         return "ptr" if (util::has_property($e, "ptr"));
 127         return "unique" if (util::has_property($e, "unique"));
 128         return "relative" if (util::has_property($e, "relative"));
 129         return "ignore" if (util::has_property($e, "ignore"));
 130
 131         return undef;
 132 }
 133
 134 # return 1 if this is a fixed array
 135 sub is_fixed_array($)
 136 {
 137         my $e = shift;
 138         my $len = $e->{"ARRAY_LEN"};
 139         return 1 if (defined $len && util::is_constant($len));
 140         return 0;
 141 }
 142
 143 # return 1 if this is a conformant array
 144 sub is_conformant_array($)
 145 {
 146         my $e = shift;
 147         return 1 if (util::has_property($e, "size_is"));
 148         return 0;
 149 }
 150
 151 # return 1 if this is a inline array
 152 sub is_inline_array($)
 153 {
 154         my $e = shift;
 155         my $len = $e->{"ARRAY_LEN"};
 156         if (is_fixed_array($e) ||
 157             defined $len && $len ne "*") {
 158                 return 1;
 159         }
 160         return 0;
 161 }
 162
 163 # return 1 if this is a varying array
 164 sub is_varying_array($)
 165 {
 166         my $e = shift;
 167         return util::has_property($e, "length_is");
 168 }
 169
 170 # return 1 if this is a surrounding array (sometimes
 171 # referred to as an embedded array). Can only occur as
 172 # the last element in a struct and can not contain any pointers.
 173 sub is_surrounding_array($)
 174 {
 175         my $e = shift;
 176
 177         return ($e->{POINTERS} == 0
 178                 and defined $e->{ARRAY_LEN}
 179                 and     $e->{ARRAY_LEN} eq "*"
 180                 and $e == $e->{PARENT}->{ELEMENTS}[-1]
 181                 and $e->{PARENT}->{TYPE} ne "FUNCTION");
 182 }
 183
 184 sub array_type($)
 185 {
 186         my $e = shift;
 187
 188         return "conformant-varying" if (is_varying_array($e) and is_conformant_array($e));
 189         return "conformant" if (is_varying_array($e));
 190         return "varying" if (is_varying_array($e));
 191         return "inline" if (is_inline_array($e));
 192         return "fixed" if (is_fixed_array($e));
 193
 194         return undef;
 195 }
 196
 197 #####################################################################
 198 # work out the correct alignment for a structure or union
 199 sub find_largest_alignment($)
 200 {
 201         my $s = shift;
 202
 203         my $align = 1;
 204         for my $e (@{$s->{ELEMENTS}}) {
 205                 my $a = 1;
 206
 207                 if (Ndr::need_wire_pointer($e)) {
 208                         $a = 4;
 209                 } else {
 210                         $a = align_type($e->{TYPE});
 211                 }
 212
 213                 $align = $a if ($align < $a);
 214         }
 215
 216         return $align;
 217 }
 218
 219 #####################################################################
 220 # align a type
 221 sub align_type
 222 {
 223         my $e = shift;
 224
 225         unless (typelist::hasType($e)) {
 226             # it must be an external type - all we can do is guess
 227                 # print "Warning: assuming alignment of unknown type '$e' is 4\n";
 228             return 4;
 229         }
 230
 231         my $dt = typelist::getType($e)->{DATA};
 232
 233         if ($dt->{TYPE} eq "ENUM") {
 234                 return align_type(typelist::enum_type_fn($dt));
 235         } elsif ($dt->{TYPE} eq "BITMAP") {
 236                 return align_type(typelist::bitmap_type_fn($dt));
 237         } elsif (($dt->{TYPE} eq "STRUCT") or ($dt->{TYPE} eq "UNION")) {
 238                 return find_largest_alignment($dt);
 239         } elsif ($dt->{TYPE} eq "SCALAR") {
 240                 return typelist::getScalarAlignment($dt->{NAME});
 241         }
 242
 243         die("Unknown data type type $dt->{TYPE}");
 244 }
 245
 246 # determine if an element needs a reference pointer on the wire
 247 # in its NDR representation
 248 sub need_wire_pointer($)
 249 {
 250         my $e = shift;
 251
 252         my $n = $e->{POINTERS};
 253         my $pt = pointer_type($e);
 254
 255         # Top level "ref" pointers do not have a referrent identifier
 256         if (    defined($pt)
 257                 and $pt eq "ref"
 258                 and $e->{PARENT}->{TYPE} eq "FUNCTION")
 259         {
 260                 $n--;
 261         }
 262
 263         return $n;
 264 }
 265
 266 sub ParseElement($)
 267 {
 268         my $e = shift;
 269
 270         return {
 271                 NAME => $e->{NAME},
 272                 PROPERTIES => $e->{PROPERTIES},
 273                 LEVELS => GetElementLevelTable($e)
 274         };
 275 }
 276
 277 sub ParseStruct($)
 278 {
 279         my $e = shift;
 280         my @elements = ();
 281
 282         foreach my $x (@{$e->{ELEMENTS}})
 283         {
 284                 push @elements, ParseElement($x);
 285         }
 286
 287         return {
 288                 TYPE => "STRUCT",
 289                 ELEMENTS => \@elements,
 290                 PROPERTIES => $e->{PROPERTIES}
 291         };
 292 }
 293
 294 sub ParseUnion($)
 295 {
 296         my $e = shift;
 297         my @elements = ();
 298
 299         foreach my $x (@{$e->{ELEMENTS}})
 300         {
 301                 my $t;
 302                 if ($x->{TYPE} eq "EMPTY") {
 303                         $t = { TYPE => "EMPTY" };
 304                 } else {
 305                         $t = ParseElement($x);
 306                         if (util::has_property($t, "default")) {
 307                                 $t->{DEFAULT} = "default";
 308                         } else {
 309                                 $t->{CASE} = $t->{PROPERTIES}->{CASE};
 310                         }
 311                 }
 312                 push @elements, $t;
 313         }
 314
 315         return {
 316                 TYPE => "UNION",
 317                 ELEMENTS => \@elements,
 318                 PROPERTIES => $e->{PROPERTIES}
 319         };
 320 }
 321
 322 sub ParseEnum($)
 323 {
 324         my $e = shift;
 325
 326         return {
 327                 TYPE => "ENUM",
 328                 ELEMENTS => $e->{ELEMENTS},
 329                 PROPERTIES => $e->{PROPERTIES}
 330         };
 331 }
 332
 333 sub ParseBitmap($)
 334 {
 335         my $e = shift;
 336
 337         return {
 338                 TYPE => "BITMAP",
 339                 ELEMENTS => $e->{ELEMENTS},
 340                 PROPERTIES => $e->{PROPERTIES}
 341         };
 342 }
 343
 344 sub ParseTypedef($$)
 345 {
 346         my $ndr = shift;
 347         my $d = shift;
 348         my $data;
 349
 350         if ($d->{DATA}->{TYPE} eq "STRUCT" or $d->{DATA}->{TYPE} eq "UNION") {
 351                 CheckPointerTypes($d->{DATA}, $ndr->{PROPERTIES}->{pointer_default});
 352         }
 353
 354         if (defined($d->{PROPERTIES}) && !defined($d->{DATA}->{PROPERTIES})) {
 355                 $d->{DATA}->{PROPERTIES} = $d->{PROPERTIES};
 356         }
 357
 358         if ($d->{DATA}->{TYPE} eq "STRUCT") {
 359                 $data = ParseStruct($d->{DATA});
 360         } elsif ($d->{DATA}->{TYPE} eq "UNION") {
 361                 $data = ParseUnion($d->{DATA});
 362         } elsif ($d->{DATA}->{TYPE} eq "ENUM") {
 363                 $data = ParseEnum($d->{DATA});
 364         } elsif ($d->{DATA}->{TYPE} eq "BITMAP") {
 365                 $data = ParseBitmap($d->{DATA});
 366         } else {
 367                 die("Unknown data type '$d->{DATA}->{TYPE}'");
 368         }
 369
 370         $data->{ALIGN} = align_type($d->{NAME});
 371
 372         return {
 373                 NAME => $d->{NAME},
 374                 TYPE => "TYPEDEF",
 375                 PROPERTIES => $d->{PROPERTIES},
 376                 DATA => $data
 377         };
 378 }
 379
 380 sub ParseFunction($$)
 381 {
 382         my $ndr = shift;
 383         my $d = shift;
 384         my @in = ();
 385         my @out = ();
 386
 387         CheckPointerTypes($d,
 388                 $ndr->{PROPERTIES}->{pointer_default}  # MIDL defaults to "ref"
 389         );
 390
 391         foreach my $x (@{$d->{ELEMENTS}}) {
 392                 if (util::has_property($x, "in")) {
 393                         push (@in, ParseElement($x));
 394                 }
 395                 if (util::has_property($x, "out")) {
 396                         push (@out, ParseElement($x));
 397                 }
 398         }
 399
 400         return {
 401                         NAME => $d->{NAME},
 402                         TYPE => "FUNCTION",
 403                         RETURN_TYPE => $d->{RETURN_TYPE},
 404                         PROPERTIES => $d->{PROPERTIES},
 405                         ELEMENTS => {
 406                                 IN => \@in,
 407                                 OUT => \@out
 408                         }
 409                 };
 410 }
 411
 412 sub CheckPointerTypes($$)
 413 {
 414         my $s = shift;
 415         my $default = shift;
 416
 417         foreach my $e (@{$s->{ELEMENTS}}) {
 418                 if ($e->{POINTERS}) {
 419                         if (not defined(Ndr::pointer_type($e))) {
 420                                 $e->{PROPERTIES}->{$default} = 1;
 421                         }
 422
 423                         if (Ndr::pointer_type($e) eq "ptr") {
 424                                 print "Warning: ptr is not supported by pidl yet\n";
 425                         }
 426                 }
 427         }
 428 }
 429
 430 sub ParseInterface($)
 431 {
 432         my $idl = shift;
 433         my @functions = ();
 434         my @typedefs = ();
 435         my $version;
 436
 437         if (not util::has_property($idl, "pointer_default")) {
 438                 # MIDL defaults to "ptr" in DCE compatible mode (/osf)
 439                 # and "unique" in Microsoft Extensions mode (default)
 440                 $idl->{PROPERTIES}->{pointer_default} = "unique";
 441         }
 442
 443         foreach my $d (@{$idl->{DATA}}) {
 444                 if ($d->{TYPE} eq "DECLARE" or $d->{TYPE} eq "TYPEDEF") {
 445                         push (@typedefs, ParseTypedef($idl, $d));
 446                 }
 447
 448                 if ($d->{TYPE} eq "FUNCTION") {
 449                         push (@functions, ParseFunction($idl, $d));
 450                 }
 451         }
 452
 453         $version = "0.0";
 454
 455         if(defined $idl->{PROPERTIES}->{version}) {
 456                 $version = $idl->{PROPERTIES}->{version};
 457         }
 458
 459
 460         return {
 461                 NAME => $idl->{NAME},
 462                 UUID => util::has_property($idl, "uuid"),
 463                 VERSION => $version,
 464                 TYPE => "INTERFACE",
 465                 PROPERTIES => $idl->{PROPERTIES},
 466                 FUNCTIONS => \@functions,
 467                 TYPEDEFS => \@typedefs
 468         };
 469 }
 470
 471 # Convert a IDL tree to a NDR tree
 472 # Gives a result tree describing all that's necessary for easily generating
 473 # NDR parsers
 474 # - list of interfaces
 475 #  - list with functions
 476 #   - list with in elements
 477 #   - list with out elements
 478 #  - list of typedefs
 479 #   - list with structs
 480 #    - alignment of structure
 481 #    - list with elements
 482 #   - list with unions
 483 #    - alignment of union
 484 #    - list with elements
 485 #   - list with enums
 486 #    - base type
 487 #   - list with bitmaps
 488 #    - base type
 489 # per element:
 490 #  - alignment
 491 #  - "level" table
 492 # properties are saved
 493 # pointer types explicitly specified
 494 sub Parse($)
 495 {
 496         my $idl = shift;
 497         my @ndr = ();
 498
 499         foreach my $x (@{$idl}) {
 500                 push @ndr, ParseInterface($x);
 501         }
 502
 503         return \@ndr;
 504 }
 505
 506 1;