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