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 sub is_scalar_type($)
 186 {
 187     my($type) = shift;
 188
 189     if ($type =~ /^u?int\d+/) {
 190             return 1;
 191     }
 192     if ($type =~ /char|short|long|NTTIME|
 193         time_t|error_status_t|boolean32|unsigned32|
 194         HYPER_T|wchar_t|DATA_BLOB/x) {
 195             return 1;
 196     }
 197
 198     return 0;
 199 }
 200
 201 # return the NDR alignment for a type
 202 sub type_align($)
 203 {
 204     my($e) = shift;
 205     my $type = $e->{TYPE};
 206
 207     if (need_wire_pointer($e)) {
 208             return 4;
 209     }
 210
 211     return 4, if ($type eq "uint32");
 212     return 4, if ($type eq "long");
 213     return 2, if ($type eq "short");
 214     return 1, if ($type eq "char");
 215     return 1, if ($type eq "uint8");
 216     return 2, if ($type eq "uint16");
 217     return 4, if ($type eq "NTTIME");
 218     return 4, if ($type eq "time_t");
 219     return 8, if ($type eq "HYPER_T");
 220     return 2, if ($type eq "wchar_t");
 221     return 4, if ($type eq "DATA_BLOB");
 222
 223     # it must be an external type - all we can do is guess
 224     return 4;
 225 }
 226
 227 # this is used to determine if the ndr push/pull functions will need
 228 # a ndr_flags field to split by buffers/scalars
 229 sub is_builtin_type($)
 230 {
 231     my($type) = shift;
 232
 233     return 1, if (is_scalar_type($type));
 234
 235     return 0;
 236 }
 237
 238 # determine if an element needs a reference pointer on the wire
 239 # in its NDR representation
 240 sub need_wire_pointer($)
 241 {
 242         my $e = shift;
 243         if ($e->{POINTERS} &&
 244             !has_property($e, "ref")) {
 245                 return $e->{POINTERS};
 246         }
 247         return undef;
 248 }
 249
 250 # determine if an element is a pass-by-reference structure
 251 sub is_ref_struct($)
 252 {
 253         my $e = shift;
 254         if (!is_scalar_type($e->{TYPE}) &&
 255             has_property($e, "ref")) {
 256                 return 1;
 257         }
 258         return 0;
 259 }
 260
 261 # determine if an element is a pure scalar. pure scalars do not
 262 # have a "buffers" section in NDR
 263 sub is_pure_scalar($)
 264 {
 265         my $e = shift;
 266         if (has_property($e, "ref")) {
 267                 return 1;
 268         }
 269         if (is_scalar_type($e->{TYPE}) &&
 270             !$e->{POINTERS} &&
 271             !array_size($e)) {
 272                 return 1;
 273         }
 274         return 0;
 275 }
 276
 277 # determine the array size (size_is() or ARRAY_LEN)
 278 sub array_size($)
 279 {
 280         my $e = shift;
 281         my $size = has_property($e, "size_is");
 282         if ($size) {
 283                 return $size;
 284         }
 285         $size = $e->{ARRAY_LEN};
 286         if ($size) {
 287                 return $size;
 288         }
 289         return undef;
 290 }
 291
 292 # see if a variable needs to be allocated by the NDR subsystem on pull
 293 sub need_alloc($)
 294 {
 295         my $e = shift;
 296
 297         if (has_property($e, "ref")) {
 298                 return 0;
 299         }
 300
 301         if ($e->{POINTERS} || array_size($e)) {
 302                 return 1;
 303         }
 304
 305         return 0;
 306 }
 307
 308 # determine the C prefix used to refer to a variable when passing to a push
 309 # function. This will be '*' for pointers to scalar types, '' for scalar
 310 # types and normal pointers and '&' for pass-by-reference structures
 311 sub c_push_prefix($)
 312 {
 313         my $e = shift;
 314
 315         if ($e->{TYPE} =~ "string") {
 316                 return "";
 317         }
 318
 319         if (is_scalar_type($e->{TYPE}) &&
 320             $e->{POINTERS}) {
 321                 return "*";
 322         }
 323         if (!is_scalar_type($e->{TYPE}) &&
 324             !$e->{POINTERS} &&
 325             !array_size($e)) {
 326                 return "&";
 327         }
 328         return "";
 329 }
 330
 331
 332 # determine the C prefix used to refer to a variable when passing to a pull
 333 # return '&' or ''
 334 sub c_pull_prefix($)
 335 {
 336         my $e = shift;
 337
 338         if (!$e->{POINTERS} && !array_size($e)) {
 339                 return "&";
 340         }
 341
 342         if ($e->{TYPE} =~ "string") {
 343                 return "&";
 344         }
 345
 346         return "";
 347 }
 348
 349 # determine if an element has a direct buffers component
 350 sub has_direct_buffers($)
 351 {
 352         my $e = shift;
 353         if ($e->{POINTERS} || array_size($e)) {
 354                 return 1;
 355         }
 356         return 0;
 357 }
 358
 359 # return 1 if the string is a C constant
 360 sub is_constant($)
 361 {
 362         my $s = shift;
 363         if (defined $s && $s =~ /^\d/) {
 364                 return 1;
 365         }
 366         return 0;
 367 }
 368
 369 # return 1 if this is a fixed array
 370 sub is_fixed_array($)
 371 {
 372         my $e = shift;
 373         my $len = $e->{"ARRAY_LEN"};
 374         if (defined $len && is_constant($len)) {
 375                 return 1;
 376         }
 377         return 0;
 378 }
 379
 380 # return 1 if this is a inline array
 381 sub is_inline_array($)
 382 {
 383         my $e = shift;
 384         my $len = $e->{"ARRAY_LEN"};
 385         if (is_fixed_array($e) ||
 386             defined $len && $len ne "*") {
 387                 return 1;
 388         }
 389         return 0;
 390 }
 391
 392 1;
 393