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 my %is_enum;
   8
   9 #####################################################################
  10 # load a data structure from a file (as saved with SaveStructure)
  11 sub LoadStructure($)
  12 {
  13         my $f = shift;
  14         my $contents = FileLoad($f);
  15         defined $contents || return undef;
  16         return eval "$contents";
  17 }
  18
  19 use strict;
  20
  21 #####################################################################
  22 # flatten an array of arrays into a single array
  23 sub FlattenArray2($)
  24 {
  25     my $a = shift;
  26     my @b;
  27     for my $d (@{$a}) {
  28         for my $d1 (@{$d}) {
  29             push(@b, $d1);
  30         }
  31     }
  32     return \@b;
  33 }
  34
  35 #####################################################################
  36 # flatten an array of arrays into a single array
  37 sub FlattenArray($)
  38 {
  39     my $a = shift;
  40     my @b;
  41     for my $d (@{$a}) {
  42         for my $d1 (@{$d}) {
  43             push(@b, $d1);
  44         }
  45     }
  46     return \@b;
  47 }
  48
  49 #####################################################################
  50 # flatten an array of hashes into a single hash
  51 sub FlattenHash($)
  52 {
  53     my $a = shift;
  54     my %b;
  55     for my $d (@{$a}) {
  56         for my $k (keys %{$d}) {
  57             $b{$k} = $d->{$k};
  58         }
  59     }
  60     return \%b;
  61 }
  62
  63
  64 #####################################################################
  65 # traverse a perl data structure removing any empty arrays or
  66 # hashes and any hash elements that map to undef
  67 sub CleanData($)
  68 {
  69     sub CleanData($);
  70     my($v) = shift;
  71     if (ref($v) eq "ARRAY") {
  72         foreach my $i (0 .. $#{$v}) {
  73             CleanData($v->[$i]);
  74             if (ref($v->[$i]) eq "ARRAY" && $#{$v->[$i]}==-1) {
  75                     $v->[$i] = undef;
  76                     next;
  77             }
  78         }
  79         # this removes any undefined elements from the array
  80         @{$v} = grep { defined $_ } @{$v};
  81     } elsif (ref($v) eq "HASH") {
  82         foreach my $x (keys %{$v}) {
  83             CleanData($v->{$x});
  84             if (!defined $v->{$x}) { delete($v->{$x}); next; }
  85             if (ref($v->{$x}) eq "ARRAY" && $#{$v->{$x}}==-1) { delete($v->{$x}); next; }
  86         }
  87     }
  88 }
  89
  90
  91 #####################################################################
  92 # return the modification time of a file
  93 sub FileModtime($)
  94 {
  95     my($filename) = shift;
  96     return (stat($filename))[9];
  97 }
  98
  99
 100 #####################################################################
 101 # read a file into a string
 102 sub FileLoad($)
 103 {
 104     my($filename) = shift;
 105     local(*INPUTFILE);
 106     open(INPUTFILE, $filename) || return undef;
 107     my($saved_delim) = $/;
 108     undef $/;
 109     my($data) = <INPUTFILE>;
 110     close(INPUTFILE);
 111     $/ = $saved_delim;
 112     return $data;
 113 }
 114
 115 #####################################################################
 116 # write a string into a file
 117 sub FileSave($$)
 118 {
 119     my($filename) = shift;
 120     my($v) = shift;
 121     local(*FILE);
 122     open(FILE, ">$filename") || die "can't open $filename";
 123     print FILE $v;
 124     close(FILE);
 125 }
 126
 127 #####################################################################
 128 # return a filename with a changed extension
 129 sub ChangeExtension($$)
 130 {
 131     my($fname) = shift;
 132     my($ext) = shift;
 133     if ($fname =~ /^(.*)\.(.*?)$/) {
 134         return "$1$ext";
 135     }
 136     return "$fname$ext";
 137 }
 138
 139 #####################################################################
 140 # a dumper wrapper to prevent dependence on the Data::Dumper module
 141 # unless we actually need it
 142 sub MyDumper($)
 143 {
 144         require Data::Dumper;
 145         my $s = shift;
 146         return Data::Dumper::Dumper($s);
 147 }
 148
 149 #####################################################################
 150 # save a data structure into a file
 151 sub SaveStructure($$)
 152 {
 153         my($filename) = shift;
 154         my($v) = shift;
 155         FileSave($filename, MyDumper($v));
 156 }
 157
 158 #####################################################################
 159 # find an interface in an array of interfaces
 160 sub get_interface($$)
 161 {
 162         my($if) = shift;
 163         my($n) = shift;
 164
 165         foreach(@{$if}) {
 166                 if($_->{NAME} eq $n) { return $_; }
 167         }
 168
 169         return 0;
 170 }
 171
 172 #####################################################################
 173 # see if a pidl property list contains a give property
 174 sub has_property($$)
 175 {
 176         my($e) = shift;
 177         my($p) = shift;
 178
 179         if (!defined $e->{PROPERTIES}) {
 180                 return undef;
 181         }
 182
 183         return $e->{PROPERTIES}->{$p};
 184 }
 185
 186 #####################################################################
 187 # see if a pidl property matches a value
 188 sub property_matches($$$)
 189 {
 190         my($e) = shift;
 191         my($p) = shift;
 192         my($v) = shift;
 193
 194         if (!defined has_property($e, $p)) {
 195                 return undef;
 196         }
 197
 198         if ($e->{PROPERTIES}->{$p} =~ /$v/) {
 199                 return 1;
 200         }
 201
 202         return undef;
 203 }
 204
 205 my %enum_list;
 206
 207 sub register_enum($)
 208 {
 209         my $name = shift;
 210         $enum_list{$name} = 1;
 211 }
 212
 213 sub is_enum($)
 214 {
 215         my $name = shift;
 216         return defined $enum_list{$name}
 217 }
 218
 219 sub is_scalar_type($)
 220 {
 221     my($type) = shift;
 222
 223     if ($type =~ /^u?int\d+/) {
 224             return 1;
 225     }
 226     if ($type =~ /char|short|long|NTTIME|NTTIME_1sec|
 227         time_t|error_status_t|boolean32|unsigned32|
 228         HYPER_T|wchar_t|DATA_BLOB|WERROR/x) {
 229             return 1;
 230     }
 231
 232     if (is_enum($type)) {
 233             return 1;
 234     }
 235
 236     return 0;
 237 }
 238
 239 # return the NDR alignment for a type
 240 sub type_align($)
 241 {
 242     my($e) = shift;
 243     my $type = $e->{TYPE};
 244
 245     if (need_wire_pointer($e)) {
 246             return 4;
 247     }
 248
 249     return 4, if ($type eq "uint32");
 250     return 4, if ($type eq "long");
 251     return 2, if ($type eq "short");
 252     return 1, if ($type eq "char");
 253     return 1, if ($type eq "uint8");
 254     return 2, if ($type eq "uint16");
 255     return 4, if ($type eq "NTTIME");
 256     return 4, if ($type eq "NTTIME_1sec");
 257     return 4, if ($type eq "time_t");
 258     return 8, if ($type eq "HYPER_T");
 259     return 2, if ($type eq "wchar_t");
 260     return 4, if ($type eq "DATA_BLOB");
 261     return 4, if ($type eq "int32");
 262
 263     # it must be an external type - all we can do is guess
 264     return 4;
 265 }
 266
 267 # this is used to determine if the ndr push/pull functions will need
 268 # a ndr_flags field to split by buffers/scalars
 269 sub is_builtin_type($)
 270 {
 271     my($type) = shift;
 272
 273     return 1, if (is_scalar_type($type));
 274
 275     return 0;
 276 }
 277
 278 # determine if an element needs a reference pointer on the wire
 279 # in its NDR representation
 280 sub need_wire_pointer($)
 281 {
 282         my $e = shift;
 283         if ($e->{POINTERS} &&
 284             !has_property($e, "ref")) {
 285                 return $e->{POINTERS};
 286         }
 287         return undef;
 288 }
 289
 290 # determine if an element is a pass-by-reference structure
 291 sub is_ref_struct($)
 292 {
 293         my $e = shift;
 294         if (!is_scalar_type($e->{TYPE}) &&
 295             has_property($e, "ref")) {
 296                 return 1;
 297         }
 298         return 0;
 299 }
 300
 301 # determine if an element is a pure scalar. pure scalars do not
 302 # have a "buffers" section in NDR
 303 sub is_pure_scalar($)
 304 {
 305         my $e = shift;
 306         if (has_property($e, "ref")) {
 307                 return 1;
 308         }
 309         if (is_scalar_type($e->{TYPE}) &&
 310             !$e->{POINTERS} &&
 311             !array_size($e)) {
 312                 return 1;
 313         }
 314         return 0;
 315 }
 316
 317 # determine the array size (size_is() or ARRAY_LEN)
 318 sub array_size($)
 319 {
 320         my $e = shift;
 321         my $size = has_property($e, "size_is");
 322         if ($size) {
 323                 return $size;
 324         }
 325         $size = $e->{ARRAY_LEN};
 326         if ($size) {
 327                 return $size;
 328         }
 329         return undef;
 330 }
 331
 332 # see if a variable needs to be allocated by the NDR subsystem on pull
 333 sub need_alloc($)
 334 {
 335         my $e = shift;
 336
 337         if (has_property($e, "ref")) {
 338                 return 0;
 339         }
 340
 341         if ($e->{POINTERS} || array_size($e)) {
 342                 return 1;
 343         }
 344
 345         return 0;
 346 }
 347
 348 # determine the C prefix used to refer to a variable when passing to a push
 349 # function. This will be '*' for pointers to scalar types, '' for scalar
 350 # types and normal pointers and '&' for pass-by-reference structures
 351 sub c_push_prefix($)
 352 {
 353         my $e = shift;
 354
 355         if ($e->{TYPE} =~ "string") {
 356                 return "";
 357         }
 358
 359         if (is_scalar_type($e->{TYPE}) &&
 360             $e->{POINTERS}) {
 361                 return "*";
 362         }
 363         if (!is_scalar_type($e->{TYPE}) &&
 364             !$e->{POINTERS} &&
 365             !array_size($e)) {
 366                 return "&";
 367         }
 368         return "";
 369 }
 370
 371
 372 # determine the C prefix used to refer to a variable when passing to a pull
 373 # return '&' or ''
 374 sub c_pull_prefix($)
 375 {
 376         my $e = shift;
 377
 378         if (!$e->{POINTERS} && !array_size($e)) {
 379                 return "&";
 380         }
 381
 382         if ($e->{TYPE} =~ "string") {
 383                 return "&";
 384         }
 385
 386         return "";
 387 }
 388
 389 # determine if an element has a direct buffers component
 390 sub has_direct_buffers($)
 391 {
 392         my $e = shift;
 393         if ($e->{POINTERS} || array_size($e)) {
 394                 return 1;
 395         }
 396         return 0;
 397 }
 398
 399 # return 1 if the string is a C constant
 400 sub is_constant($)
 401 {
 402         my $s = shift;
 403         if (defined $s && $s =~ /^\d/) {
 404                 return 1;
 405         }
 406         return 0;
 407 }
 408
 409 # return 1 if this is a fixed array
 410 sub is_fixed_array($)
 411 {
 412         my $e = shift;
 413         my $len = $e->{"ARRAY_LEN"};
 414         if (defined $len && is_constant($len)) {
 415                 return 1;
 416         }
 417         return 0;
 418 }
 419
 420 # return 1 if this is a inline array
 421 sub is_inline_array($)
 422 {
 423         my $e = shift;
 424         my $len = $e->{"ARRAY_LEN"};
 425         if (is_fixed_array($e) ||
 426             defined $len && $len ne "*") {
 427                 return 1;
 428         }
 429         return 0;
 430 }
 431
 432 # return a "" quoted string, unless already quoted
 433 sub make_str($)
 434 {
 435         my $str = shift;
 436         if (substr($str, 0, 1) eq "\"") {
 437                 return $str;
 438         }
 439         return "\"" . $str . "\"";
 440 }
 441
 442 1;
 443