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