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         my($props) = $e->{PROPERTIES};
 154
 155         foreach my $d (@{$props}) {
 156                 if (ref($d) ne "HASH") {
 157                         if ($d eq $p) {
 158                                 return 1;
 159                         }
 160                 } else {
 161                         foreach my $k (keys %{$d}) {
 162                                 if ($k eq $p) {
 163                                         return $d->{$k};
 164                                 }
 165                         }
 166                 }
 167         }
 168
 169     return undef;
 170 }
 171
 172
 173 sub is_scalar_type($)
 174 {
 175     my($type) = shift;
 176
 177     return 1, if ($type eq "uint32");
 178     return 1, if ($type eq "long");
 179     return 1, if ($type eq "short");
 180     return 1, if ($type eq "char");
 181     return 1, if ($type eq "uint8");
 182     return 1, if ($type eq "uint16");
 183     return 1, if ($type eq "NTTIME");
 184     return 1, if ($type eq "hyper");
 185     return 1, if ($type eq "wchar_t");
 186
 187     return 0;
 188 }
 189
 190 # return the NDR alignment for a type
 191 sub type_align($)
 192 {
 193     my($e) = shift;
 194     my $type = $e->{TYPE};
 195
 196     if ($e->{POINTERS} || array_size($e)) {
 197             # FIXME: we really should recurse here
 198             return 4;
 199     }
 200
 201     return 4, if ($type eq "uint32");
 202     return 4, if ($type eq "long");
 203     return 2, if ($type eq "short");
 204     return 1, if ($type eq "char");
 205     return 1, if ($type eq "uint8");
 206     return 2, if ($type eq "uint16");
 207     return 4, if ($type eq "NTTIME");
 208     return 8, if ($type eq "hyper");
 209     return 2, if ($type eq "wchar_t");
 210
 211     return 0;
 212 }
 213
 214 # this is used to determine if the ndr push/pull functions will need
 215 # a ndr_flags field to split by buffers/scalars
 216 sub is_builtin_type($)
 217 {
 218     my($type) = shift;
 219
 220     return 1, if (is_scalar_type($type));
 221     return 1, if ($type =~ "unistr.*");
 222     return 1, if ($type eq "security_descriptor");
 223     return 1, if ($type eq "dom_sid");
 224     return 1, if ($type eq "dom_sid2");
 225     return 1, if ($type eq "policy_handle");
 226
 227     return 0;
 228 }
 229
 230 # determine if an element needs a reference pointer on the wire
 231 # in its NDR representation
 232 sub need_wire_pointer($)
 233 {
 234         my $e = shift;
 235         if ($e->{POINTERS} &&
 236             !has_property($e, "ref")) {
 237                 return $e->{POINTERS};
 238         }
 239         return undef;
 240 }
 241
 242
 243 # determine if an element is a pass-by-reference structure
 244 sub is_ref_struct($)
 245 {
 246         my $e = shift;
 247         if (!is_scalar_type($e->{TYPE}) &&
 248             has_property($e, "ref")) {
 249                 return 1;
 250         }
 251         return 0;
 252 }
 253
 254 # determine if an element is a pure scalar. pure scalars do not
 255 # have a "buffers" section in NDR
 256 sub is_pure_scalar($)
 257 {
 258         my $e = shift;
 259         if (has_property($e, "ref")) {
 260                 return 1;
 261         }
 262         if (is_scalar_type($e->{TYPE}) &&
 263             !$e->{POINTERS} &&
 264             !array_size($e)) {
 265                 return 1;
 266         }
 267         return 0;
 268 }
 269
 270 # determine the array size (size_is() or ARRAY_LEN)
 271 sub array_size($)
 272 {
 273         my $e = shift;
 274         my $size = has_property($e, "size_is");
 275         if ($size) {
 276                 return $size;
 277         }
 278         $size = $e->{ARRAY_LEN};
 279         if ($size) {
 280                 return $size;
 281         }
 282         return undef;
 283 }
 284
 285 # see if a variable needs to be allocated by the NDR subsystem on pull
 286 sub need_alloc($)
 287 {
 288         my $e = shift;
 289
 290         if (has_property($e, "ref")) {
 291                 return 0;
 292         }
 293
 294         if ($e->{POINTERS} || array_size($e)) {
 295                 return 1;
 296         }
 297
 298         return 0;
 299 }
 300
 301 # determine the C prefix used to refer to a variable when passing to a push
 302 # function. This will be '*' for pointers to scalar types, '' for scalar
 303 # types and normal pointers and '&' for pass-by-reference structures
 304 sub c_push_prefix($)
 305 {
 306         my $e = shift;
 307         if (is_scalar_type($e->{TYPE}) &&
 308             $e->{POINTERS}) {
 309                 return "*";
 310         }
 311         if (!is_scalar_type($e->{TYPE}) &&
 312             !$e->{POINTERS} &&
 313             !array_size($e)) {
 314                 return "&";
 315         }
 316         return "";
 317 }
 318
 319 # determine the C prefix used to refer to a variable when passing to a pull
 320 # return '&' or ''
 321 sub c_pull_prefix($)
 322 {
 323         my $e = shift;
 324
 325         if (!$e->{POINTERS} && !array_size($e)) {
 326                 return "&";
 327         }
 328
 329         if ($e->{TYPE} =~ "unistr.*") {
 330                 return "&";
 331         }
 332
 333         return "";
 334 }
 335
 336 # determine if an element has a direct buffers component
 337 sub has_direct_buffers($)
 338 {
 339         my $e = shift;
 340         if ($e->{POINTERS} || array_size($e)) {
 341                 return 1;
 342         }
 343         return 0;
 344 }
 345
 346 1;
 347