1b00bdea1bd597d1dad364fba85f3bb42dd4a601
[samba.git] / 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 # see if a pidl property matches a value
186 sub property_matches($$$)
187 {
188         my($e) = shift;
189         my($p) = shift;
190         my($v) = shift;
191
192         if (!defined has_property($e, $p)) {
193                 return undef;
194         }
195
196         if ($e->{PROPERTIES}->{$p} =~ /$v/) {
197                 return 1;
198         }
199
200         return undef;
201 }
202
203 my %enum_list;
204
205 sub register_enum($)
206 {
207         my $name = shift;
208         $enum_list{$name} = 1;
209 }
210
211 sub is_enum($)
212 {
213         my $name = shift;
214         return defined $enum_list{$name}
215 }
216
217 sub enum_type_decl($)
218 {
219         my $e = shift;
220         return "enum $e->{TYPE}";
221 }
222
223 sub enum_type_fn($)
224 {
225         my $e = shift;
226         return "$e->{TYPE}";
227 }
228
229 my %bitmap_list;
230
231 sub register_bitmap($$)
232 {
233         my $bitmap = shift;
234         my $name = shift;
235         $bitmap_list{$name} = $bitmap;
236 }
237
238 sub is_bitmap($)
239 {
240         my $name = shift;
241         return defined $bitmap_list{$name};
242 }
243
244 sub get_bitmap($)
245 {
246         my $name = shift;
247         return $bitmap_list{$name};
248 }
249
250 sub bitmap_type_decl($)
251 {
252         my $bitmap = shift;
253
254         if (util::has_property($bitmap->{PARENT}, "bitmap8bit")) {
255                 return "uint8";
256         } elsif (util::has_property($bitmap->{PARENT}, "bitmap16bit")) {
257                 return "uint16";
258         } elsif (util::has_property($bitmap->{PARENT}, "bitmap64bit")) {
259                 return "uint64";
260         }
261         return "uint32";
262 }
263
264 sub bitmap_type_fn($)
265 {
266         my $bitmap = shift;
267         return bitmap_type_decl($bitmap);
268 }
269
270 sub is_scalar_type($)
271 {
272     my($type) = shift;
273
274     if ($type =~ /^u?int\d+/) {
275             return 1;
276     }
277     if ($type =~ /char|short|long|NTTIME|NTTIME_1sec|
278         time_t|error_status_t|boolean32|unsigned32|
279         HYPER_T|wchar_t|DATA_BLOB|WERROR/x) {
280             return 1;
281     }
282
283     if (is_enum($type)) {
284             return 1;
285     }
286
287     if (is_bitmap($type)) {
288             return 1;
289     }
290
291     return 0;
292 }
293
294 # return the NDR alignment for a type
295 sub type_align($)
296 {
297     my($e) = shift;
298     my $type = $e->{TYPE};
299
300     if (need_wire_pointer($e)) {
301             return 4;
302     }
303
304     return 1, if ($type eq "char");
305     return 1, if ($type eq "int8");
306     return 1, if ($type eq "uint8");
307
308     return 2, if ($type eq "short");
309     return 2, if ($type eq "wchar_t");
310     return 2, if ($type eq "int16");
311     return 2, if ($type eq "uint16");
312
313     return 4, if ($type eq "long");
314     return 4, if ($type eq "int32");
315     return 4, if ($type eq "uint32");
316
317     return 4, if ($type eq "int64");
318     return 4, if ($type eq "uint64");
319
320     return 4, if ($type eq "NTTIME");
321     return 4, if ($type eq "NTTIME_1sec");
322     return 4, if ($type eq "time_t");
323
324     return 4, if ($type eq "DATA_BLOB");
325
326     return 8, if ($type eq "HYPER_T");
327
328     # it must be an external type - all we can do is guess 
329     return 4;
330 }
331
332 # this is used to determine if the ndr push/pull functions will need
333 # a ndr_flags field to split by buffers/scalars
334 sub is_builtin_type($)
335 {
336     my($type) = shift;
337
338     return 1, if (is_scalar_type($type));
339
340     return 0;
341 }
342
343 # determine if an element needs a reference pointer on the wire
344 # in its NDR representation
345 sub need_wire_pointer($)
346 {
347         my $e = shift;
348         if ($e->{POINTERS} && 
349             !has_property($e, "ref")) {
350                 return $e->{POINTERS};
351         }
352         return undef;
353 }
354
355 # determine if an element is a pass-by-reference structure
356 sub is_ref_struct($)
357 {
358         my $e = shift;
359         if (!is_scalar_type($e->{TYPE}) &&
360             has_property($e, "ref")) {
361                 return 1;
362         }
363         return 0;
364 }
365
366 # determine if an element is a pure scalar. pure scalars do not
367 # have a "buffers" section in NDR
368 sub is_pure_scalar($)
369 {
370         my $e = shift;
371         if (has_property($e, "ref")) {
372                 return 1;
373         }
374         if (is_scalar_type($e->{TYPE}) && 
375             !$e->{POINTERS} && 
376             !array_size($e)) {
377                 return 1;
378         }
379         return 0;
380 }
381
382 # determine the array size (size_is() or ARRAY_LEN)
383 sub array_size($)
384 {
385         my $e = shift;
386         my $size = has_property($e, "size_is");
387         if ($size) {
388                 return $size;
389         }
390         $size = $e->{ARRAY_LEN};
391         if ($size) {
392                 return $size;
393         }
394         return undef;
395 }
396
397 # see if a variable needs to be allocated by the NDR subsystem on pull
398 sub need_alloc($)
399 {
400         my $e = shift;
401
402         if (has_property($e, "ref")) {
403                 return 0;
404         }
405
406         if ($e->{POINTERS} || array_size($e)) {
407                 return 1;
408         }
409
410         return 0;
411 }
412
413 # determine the C prefix used to refer to a variable when passing to a push
414 # function. This will be '*' for pointers to scalar types, '' for scalar
415 # types and normal pointers and '&' for pass-by-reference structures
416 sub c_push_prefix($)
417 {
418         my $e = shift;
419
420         if ($e->{TYPE} =~ "string") {
421                 return "";
422         }
423
424         if (is_scalar_type($e->{TYPE}) &&
425             $e->{POINTERS}) {
426                 return "*";
427         }
428         if (!is_scalar_type($e->{TYPE}) &&
429             !$e->{POINTERS} &&
430             !array_size($e)) {
431                 return "&";
432         }
433         return "";
434 }
435
436
437 # determine the C prefix used to refer to a variable when passing to a pull
438 # return '&' or ''
439 sub c_pull_prefix($)
440 {
441         my $e = shift;
442
443         if (!$e->{POINTERS} && !array_size($e)) {
444                 return "&";
445         }
446
447         if ($e->{TYPE} =~ "string") {
448                 return "&";
449         }
450
451         return "";
452 }
453
454 # determine if an element has a direct buffers component
455 sub has_direct_buffers($)
456 {
457         my $e = shift;
458         if ($e->{POINTERS} || array_size($e)) {
459                 return 1;
460         }
461         return 0;
462 }
463
464 # return 1 if the string is a C constant
465 sub is_constant($)
466 {
467         my $s = shift;
468         if (defined $s && $s =~ /^\d/) {
469                 return 1;
470         }
471         return 0;
472 }
473
474 # return 1 if this is a fixed array
475 sub is_fixed_array($)
476 {
477         my $e = shift;
478         my $len = $e->{"ARRAY_LEN"};
479         if (defined $len && is_constant($len)) {
480                 return 1;
481         }
482         return 0;
483 }
484
485 # return 1 if this is a inline array
486 sub is_inline_array($)
487 {
488         my $e = shift;
489         my $len = $e->{"ARRAY_LEN"};
490         if (is_fixed_array($e) ||
491             defined $len && $len ne "*") {
492                 return 1;
493         }
494         return 0;
495 }
496
497 # return a "" quoted string, unless already quoted
498 sub make_str($)
499 {
500         my $str = shift;
501         if (substr($str, 0, 1) eq "\"") {
502                 return $str;
503         }
504         return "\"" . $str . "\"";
505 }
506
507 1;
508