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