source4/build/pidl/util.pm

   1 ###################################################
   2 # utility functions to support pidl
   3 # Copyright tridge@samba.org 2000
   4 # released under the GNU GPL
   5 package util;
   6
   7 #####################################################################
   8 # load a data structure from a file (as saved with SaveStructure)
   9 sub LoadStructure($)
  10 {
  11         my $f = shift;
  12         my $contents = FileLoad($f);
  13         defined $contents || return undef;
  14         return eval "$contents";
  15 }
  16
  17 use strict;
  18
  19 #####################################################################
  20 # flatten an array of arrays into a single array
  21 sub FlattenArray2($)
  22 {
  23     my $a = shift;
  24     my @b;
  25     for my $d (@{$a}) {
  26         for my $d1 (@{$d}) {
  27             push(@b, $d1);
  28         }
  29     }
  30     return \@b;
  31 }
  32
  33 #####################################################################
  34 # flatten an array of arrays into a single array
  35 sub FlattenArray($)
  36 {
  37     my $a = shift;
  38     my @b;
  39     for my $d (@{$a}) {
  40         for my $d1 (@{$d}) {
  41             push(@b, $d1);
  42         }
  43     }
  44     return \@b;
  45 }
  46
  47 #####################################################################
  48 # flatten an array of hashes into a single hash
  49 sub FlattenHash($)
  50 {
  51     my $a = shift;
  52     my %b;
  53     for my $d (@{$a}) {
  54         for my $k (keys %{$d}) {
  55             $b{$k} = $d->{$k};
  56         }
  57     }
  58     return \%b;
  59 }
  60
  61
  62 #####################################################################
  63 # traverse a perl data structure removing any empty arrays or
  64 # hashes and any hash elements that map to undef
  65 sub CleanData($)
  66 {
  67     sub CleanData($);
  68     my($v) = shift;
  69     if (ref($v) eq "ARRAY") {
  70         foreach my $i (0 .. $#{$v}) {
  71             CleanData($v->[$i]);
  72             if (ref($v->[$i]) eq "ARRAY" && $#{$v->[$i]}==-1) {
  73                     $v->[$i] = undef;
  74                     next;
  75             }
  76         }
  77         # this removes any undefined elements from the array
  78         @{$v} = grep { defined $_ } @{$v};
  79     } elsif (ref($v) eq "HASH") {
  80         foreach my $x (keys %{$v}) {
  81             CleanData($v->{$x});
  82             if (!defined $v->{$x}) { delete($v->{$x}); next; }
  83             if (ref($v->{$x}) eq "ARRAY" && $#{$v->{$x}}==-1) { delete($v->{$x}); next; }
  84         }
  85     }
  86 }
  87
  88
  89 #####################################################################
  90 # return the modification time of a file
  91 sub FileModtime($)
  92 {
  93     my($filename) = shift;
  94     return (stat($filename))[9];
  95 }
  96
  97
  98 #####################################################################
  99 # read a file into a string
 100 sub FileLoad($)
 101 {
 102     my($filename) = shift;
 103     local(*INPUTFILE);
 104     open(INPUTFILE, $filename) || return undef;
 105     my($saved_delim) = $/;
 106     undef $/;
 107     my($data) = <INPUTFILE>;
 108     close(INPUTFILE);
 109     $/ = $saved_delim;
 110     return $data;
 111 }
 112
 113 #####################################################################
 114 # write a string into a file
 115 sub FileSave($$)
 116 {
 117     my($filename) = shift;
 118     my($v) = shift;
 119     local(*FILE);
 120     open(FILE, ">$filename") || die "can't open $filename";
 121     print FILE $v;
 122     close(FILE);
 123 }
 124
 125 #####################################################################
 126 # return a filename with a changed extension
 127 sub ChangeExtension($$)
 128 {
 129     my($fname) = shift;
 130     my($ext) = shift;
 131     if ($fname =~ /^(.*)\.(.*?)$/) {
 132         return "$1$ext";
 133     }
 134     return "$fname$ext";
 135 }
 136
 137 #####################################################################
 138 # a dumper wrapper to prevent dependence on the Data::Dumper module
 139 # unless we actually need it
 140 sub MyDumper($)
 141 {
 142         require Data::Dumper;
 143         my $s = shift;
 144         return Data::Dumper::Dumper($s);
 145 }
 146
 147 #####################################################################
 148 # save a data structure into a file
 149 sub SaveStructure($$)
 150 {
 151         my($filename) = shift;
 152         my($v) = shift;
 153         FileSave($filename, MyDumper($v));
 154 }
 155
 156 #####################################################################
 157 # find an interface in an array of interfaces
 158 sub get_interface($$)
 159 {
 160         my($if) = shift;
 161         my($n) = shift;
 162
 163         foreach(@{$if}) {
 164                 if($_->{NAME} eq $n) { return $_; }
 165         }
 166
 167         return 0;
 168 }
 169
 170 #####################################################################
 171 # see if a pidl property list contains a give property
 172 sub has_property($$)
 173 {
 174         my($e) = shift;
 175         my($p) = shift;
 176
 177         if (!defined $e->{PROPERTIES}) {
 178                 return undef;
 179         }
 180
 181         return $e->{PROPERTIES}->{$p};
 182 }
 183
 184 #####################################################################
 185 # see if a pidl property matches a value
 186 sub property_matches($$$)
 187 {
 188         my($e) = shift;
 189         my($p) = shift;
 190         my($v) = shift;
 191
 192         if (!defined has_property($e, $p)) {
 193                 return undef;
 194         }
 195
 196         if ($e->{PROPERTIES}->{$p} =~ /$v/) {
 197                 return 1;
 198         }
 199
 200         return undef;
 201 }
 202
 203 my %enum_list;
 204
 205 sub register_enum($$)
 206 {
 207         my $enum = shift;
 208         my $name = shift;
 209         $enum_list{$name} = $enum;
 210 }
 211
 212 sub is_enum($)
 213 {
 214         my $name = shift;
 215         return defined $enum_list{$name}
 216 }
 217
 218 sub get_enum($)
 219 {
 220         my $name = shift;
 221         return $enum_list{$name};
 222 }
 223
 224 sub enum_type_decl($)
 225 {
 226         my $enum = shift;
 227         return "enum $enum->{TYPE}";
 228 }
 229
 230 sub enum_type_fn($)
 231 {
 232         my $enum = shift;
 233         if (util::has_property($enum->{PARENT}, "enum8bit")) {
 234                 return "uint8";
 235         } elsif (util::has_property($enum->{PARENT}, "v1_enum")) {
 236                 return "uint32";
 237         }
 238         return "uint16";
 239 }
 240
 241 my %bitmap_list;
 242
 243 sub register_bitmap($$)
 244 {
 245         my $bitmap = shift;
 246         my $name = shift;
 247         $bitmap_list{$name} = $bitmap;
 248 }
 249
 250 sub is_bitmap($)
 251 {
 252         my $name = shift;
 253         return defined $bitmap_list{$name};
 254 }
 255
 256 sub get_bitmap($)
 257 {
 258         my $name = shift;
 259         return $bitmap_list{$name};
 260 }
 261
 262 sub bitmap_type_fn($)
 263 {
 264         my $bitmap = shift;
 265
 266         if (util::has_property($bitmap->{PARENT}, "bitmap8bit")) {
 267                 return "uint8";
 268         } elsif (util::has_property($bitmap->{PARENT}, "bitmap16bit")) {
 269                 return "uint16";
 270         } elsif (util::has_property($bitmap->{PARENT}, "bitmap64bit")) {
 271                 return "uint64";
 272         }
 273         return "uint32";
 274 }
 275
 276 sub bitmap_type_decl($)
 277 {
 278         my $bitmap = shift;
 279         return map_type(bitmap_type_fn($bitmap));
 280 }
 281
 282
 283 my %type_alignments =
 284     (
 285      "char"           => 1,
 286      "int8"           => 1,
 287      "uint8"          => 1,
 288      "short"          => 2,
 289      "wchar_t"        => 2,
 290      "int16"          => 2,
 291      "uint16"         => 2,
 292      "long"           => 4,
 293      "int32"          => 4,
 294      "uint32"         => 4,
 295      "dlong"          => 4,
 296      "udlong"         => 4,
 297      "NTTIME"         => 4,
 298      "NTTIME_1sec"    => 4,
 299      "time_t"         => 4,
 300      "DATA_BLOB"      => 4,
 301      "error_status_t" => 4,
 302      "WERROR"         => 4,
 303      "boolean32"      => 4,
 304      "unsigned32"     => 4,
 305      "hyper"          => 8,
 306      "NTTIME_hyper"   => 8
 307      );
 308
 309 sub is_scalar_type($)
 310 {
 311     my $type = shift;
 312
 313     if (defined $type_alignments{$type}) {
 314             return 1;
 315     }
 316     if (is_enum($type)) {
 317             return 1;
 318     }
 319     if (is_bitmap($type)) {
 320             return 1;
 321     }
 322
 323     return 0;
 324 }
 325
 326 # return the NDR alignment for a type
 327 sub type_align($)
 328 {
 329     my($e) = shift;
 330     my $type = $e->{TYPE};
 331
 332     if (need_wire_pointer($e)) {
 333             return 4;
 334     }
 335
 336     if (is_enum($type)) {
 337             $type = enum_type_fn(get_enum($type));
 338     }
 339
 340     if (my $ret = $type_alignments{$type}) {
 341             return $ret;
 342     }
 343
 344     # it must be an external type - all we can do is guess
 345     return 4;
 346 }
 347
 348 # this is used to determine if the ndr push/pull functions will need
 349 # a ndr_flags field to split by buffers/scalars
 350 sub is_builtin_type($)
 351 {
 352     my($type) = shift;
 353
 354     return 1, if (is_scalar_type($type));
 355
 356     return 0;
 357 }
 358
 359 # determine if an element needs a reference pointer on the wire
 360 # in its NDR representation
 361 sub need_wire_pointer($)
 362 {
 363         my $e = shift;
 364         if ($e->{POINTERS} &&
 365             !has_property($e, "ref")) {
 366                 return $e->{POINTERS};
 367         }
 368         return undef;
 369 }
 370
 371 # determine if an element is a pass-by-reference structure
 372 sub is_ref_struct($)
 373 {
 374         my $e = shift;
 375         if (!is_scalar_type($e->{TYPE}) &&
 376             has_property($e, "ref")) {
 377                 return 1;
 378         }
 379         return 0;
 380 }
 381
 382 # determine if an element is a pure scalar. pure scalars do not
 383 # have a "buffers" section in NDR
 384 sub is_pure_scalar($)
 385 {
 386         my $e = shift;
 387         if (has_property($e, "ref")) {
 388                 return 1;
 389         }
 390         if (is_scalar_type($e->{TYPE}) &&
 391             !$e->{POINTERS} &&
 392             !array_size($e)) {
 393                 return 1;
 394         }
 395         return 0;
 396 }
 397
 398 # determine the array size (size_is() or ARRAY_LEN)
 399 sub array_size($)
 400 {
 401         my $e = shift;
 402         my $size = has_property($e, "size_is");
 403         if ($size) {
 404                 return $size;
 405         }
 406         $size = $e->{ARRAY_LEN};
 407         if ($size) {
 408                 return $size;
 409         }
 410         return undef;
 411 }
 412
 413 # see if a variable needs to be allocated by the NDR subsystem on pull
 414 sub need_alloc($)
 415 {
 416         my $e = shift;
 417
 418         if (has_property($e, "ref")) {
 419                 return 0;
 420         }
 421
 422         if ($e->{POINTERS} || array_size($e)) {
 423                 return 1;
 424         }
 425
 426         return 0;
 427 }
 428
 429 # determine the C prefix used to refer to a variable when passing to a push
 430 # function. This will be '*' for pointers to scalar types, '' for scalar
 431 # types and normal pointers and '&' for pass-by-reference structures
 432 sub c_push_prefix($)
 433 {
 434         my $e = shift;
 435
 436         if ($e->{TYPE} =~ "string") {
 437                 return "";
 438         }
 439
 440         if (is_scalar_type($e->{TYPE}) &&
 441             $e->{POINTERS}) {
 442                 return "*";
 443         }
 444         if (!is_scalar_type($e->{TYPE}) &&
 445             !$e->{POINTERS} &&
 446             !array_size($e)) {
 447                 return "&";
 448         }
 449         return "";
 450 }
 451
 452
 453 # determine the C prefix used to refer to a variable when passing to a pull
 454 # return '&' or ''
 455 sub c_pull_prefix($)
 456 {
 457         my $e = shift;
 458
 459         if (!$e->{POINTERS} && !array_size($e)) {
 460                 return "&";
 461         }
 462
 463         if ($e->{TYPE} =~ "string") {
 464                 return "&";
 465         }
 466
 467         return "";
 468 }
 469
 470 # determine if an element has a direct buffers component
 471 sub has_direct_buffers($)
 472 {
 473         my $e = shift;
 474         if ($e->{POINTERS} || array_size($e)) {
 475                 return 1;
 476         }
 477         return 0;
 478 }
 479
 480 # return 1 if the string is a C constant
 481 sub is_constant($)
 482 {
 483         my $s = shift;
 484         if (defined $s && $s =~ /^\d/) {
 485                 return 1;
 486         }
 487         return 0;
 488 }
 489
 490 # return 1 if this is a fixed array
 491 sub is_fixed_array($)
 492 {
 493         my $e = shift;
 494         my $len = $e->{"ARRAY_LEN"};
 495         if (defined $len && is_constant($len)) {
 496                 return 1;
 497         }
 498         return 0;
 499 }
 500
 501 # return 1 if this is a inline array
 502 sub is_inline_array($)
 503 {
 504         my $e = shift;
 505         my $len = $e->{"ARRAY_LEN"};
 506         if (is_fixed_array($e) ||
 507             defined $len && $len ne "*") {
 508                 return 1;
 509         }
 510         return 0;
 511 }
 512
 513 # return a "" quoted string, unless already quoted
 514 sub make_str($)
 515 {
 516         my $str = shift;
 517         if (substr($str, 0, 1) eq "\"") {
 518                 return $str;
 519         }
 520         return "\"" . $str . "\"";
 521 }
 522
 523
 524 # provide mappings between IDL base types and types in our headers
 525 my %type_mappings =
 526     (
 527      "int8"         => "int8_t",
 528      "uint8"        => "uint8_t",
 529      "short"        => "int16_t",
 530      "wchar_t"      => "uint16_t",
 531      "int16"        => "int16_t",
 532      "uint16"       => "uint16_t",
 533      "int32"        => "int32_t",
 534      "uint32"       => "uint32_t",
 535      "int64"        => "int64_t",
 536      "uint64"       => "uint64_t",
 537      "dlong"        => "int64_t",
 538      "udlong"       => "uint64_t",
 539      "hyper"        => "uint64_t",
 540      "NTTIME_1sec"  => "NTTIME",
 541      "NTTIME_hyper" => "NTTIME"
 542      );
 543
 544 # map from a IDL type to a C header type
 545 sub map_type($)
 546 {
 547         my $name = shift;
 548         if (my $ret = $type_mappings{$name}) {
 549                 return $ret;
 550         }
 551         return $name;
 552 }
 553
 554 1;
 555