80ecec938aad694765229a1ce86737b70a8f7713
[ira/wip.git] / source / pidl / lib / Parse / Pidl / NDR.pm
1 ###################################################
2 # Samba4 NDR info tree generator
3 # Copyright tridge@samba.org 2000-2003
4 # Copyright tpot@samba.org 2001
5 # Copyright jelmer@samba.org 2004-2006
6 # released under the GNU GPL
7
8 =pod
9
10 =head1 NAME
11
12 Parse::Pidl::NDR - NDR parsing information generator
13
14 =head1 DESCRIPTION
15
16 Return a table describing the order in which the parts of an element
17 should be parsed
18 Possible level types:
19  - POINTER
20  - ARRAY
21  - SUBCONTEXT
22  - SWITCH
23  - DATA
24
25 =head1 AUTHOR
26
27 Jelmer Vernooij <jelmer@samba.org>
28
29 =cut
30
31 package Parse::Pidl::NDR;
32
33 require Exporter;
34 use vars qw($VERSION);
35 $VERSION = '0.01';
36 @ISA = qw(Exporter);
37 @EXPORT = qw(GetPrevLevel GetNextLevel ContainsDeferred ContainsString);
38 @EXPORT_OK = qw(GetElementLevelTable ParseElement ValidElement align_type mapToScalar ParseType can_contain_deferred);
39
40 use strict;
41 use Parse::Pidl qw(warning fatal);
42 use Parse::Pidl::Typelist qw(hasType getType expandAlias);
43 use Parse::Pidl::Util qw(has_property property_matches);
44
45 # Alignment of the built-in scalar types
46 my $scalar_alignment = {
47         'void' => 0,
48         'char' => 1,
49         'int8' => 1,
50         'uint8' => 1,
51         'int16' => 2,
52         'uint16' => 2,
53         'int32' => 4,
54         'uint32' => 4,
55         'hyper' => 8,
56         'pointer' => 8,
57         'dlong' => 4,
58         'udlong' => 4,
59         'udlongr' => 4,
60         'DATA_BLOB' => 4,
61         'string' => 4,
62         'string_array' => 4, #???
63         'time_t' => 4,
64         'NTTIME' => 4,
65         'NTTIME_1sec' => 4,
66         'NTTIME_hyper' => 8,
67         'WERROR' => 4,
68         'NTSTATUS' => 4,
69         'COMRESULT' => 4,
70         'nbt_string' => 4,
71         'wrepl_nbt_name' => 4,
72         'ipv4address' => 4
73 };
74
75 sub GetElementLevelTable($)
76 {
77         my $e = shift;
78
79         my $order = [];
80         my $is_deferred = 0;
81         my @bracket_array = ();
82         my @length_is = ();
83         my @size_is = ();
84         my $pointer_idx = 0;
85
86         if (has_property($e, "size_is")) {
87                 @size_is = split /,/, has_property($e, "size_is");
88         }
89
90         if (has_property($e, "length_is")) {
91                 @length_is = split /,/, has_property($e, "length_is");
92         }
93
94         if (defined($e->{ARRAY_LEN})) {
95                 @bracket_array = @{$e->{ARRAY_LEN}};
96         }
97
98         if (has_property($e, "out")) {
99                 my $needptrs = 1;
100
101                 if (has_property($e, "string")) { $needptrs++; }
102                 if ($#bracket_array >= 0) { $needptrs = 0; }
103
104                 warning($e, "[out] argument `$e->{NAME}' not a pointer") if ($needptrs > $e->{POINTERS});
105         }
106
107         # Parse the [][][][] style array stuff
108         for my $i (0 .. $#bracket_array) {
109                 my $d = $bracket_array[$#bracket_array - $i];
110                 my $size = $d;
111                 my $length = $d;
112                 my $is_surrounding = 0;
113                 my $is_varying = 0;
114                 my $is_conformant = 0;
115                 my $is_string = 0;
116                 my $is_fixed = 0;
117                 my $is_inline = 0;
118
119                 if ($d eq "*") {
120                         $is_conformant = 1;
121                         if ($size = shift @size_is) {
122                         } elsif ((scalar(@size_is) == 0) and has_property($e, "string")) {
123                                 $is_string = 1;
124                                 delete($e->{PROPERTIES}->{string});
125                         } else {
126                                 fatal($e, "Must specify size_is() for conformant array!")
127                         }
128
129                         if (($length = shift @length_is) or $is_string) {
130                                 $is_varying = 1;
131                         } else {
132                                 $length = $size;
133                         }
134
135                         if ($e == $e->{PARENT}->{ELEMENTS}[-1] 
136                                 and $e->{PARENT}->{TYPE} ne "FUNCTION") {
137                                 $is_surrounding = 1;
138                         }
139                 }
140
141                 $is_fixed = 1 if (not $is_conformant and Parse::Pidl::Util::is_constant($size));
142                 $is_inline = 1 if (not $is_conformant and not Parse::Pidl::Util::is_constant($size));
143
144                 push (@$order, {
145                         TYPE => "ARRAY",
146                         SIZE_IS => $size,
147                         LENGTH_IS => $length,
148                         IS_DEFERRED => $is_deferred,
149                         IS_SURROUNDING => $is_surrounding,
150                         IS_ZERO_TERMINATED => $is_string,
151                         IS_VARYING => $is_varying,
152                         IS_CONFORMANT => $is_conformant,
153                         IS_FIXED => $is_fixed,
154                         IS_INLINE => $is_inline
155                 });
156         }
157
158         # Next, all the pointers
159         foreach my $i (1..$e->{POINTERS}) {
160                 my $pt = pointer_type($e);
161
162                 my $level = "EMBEDDED";
163                 # Top level "ref" pointers do not have a referrent identifier
164                 $level = "TOP" if ( defined($pt) 
165                                 and $i == 1
166                                 and $e->{PARENT}->{TYPE} eq "FUNCTION");
167
168                 push (@$order, { 
169                         TYPE => "POINTER",
170                         # for now, there can only be one pointer type per element
171                         POINTER_TYPE => pointer_type($e),
172                         POINTER_INDEX => $pointer_idx,
173                         IS_DEFERRED => "$is_deferred",
174                         LEVEL => $level
175                 });
176
177                 warning($e, "top-level \[out\] pointer `$e->{NAME}' is not a \[ref\] pointer") 
178                         if ($i == 1 and pointer_type($e) ne "ref" and 
179                                 $e->{PARENT}->{TYPE} eq "FUNCTION" and 
180                                 not has_property($e, "in"));
181
182                 $pointer_idx++;
183                 
184                 # everything that follows will be deferred
185                 $is_deferred = 1 if ($e->{PARENT}->{TYPE} ne "FUNCTION");
186
187                 my $array_size = shift @size_is;
188                 my $array_length;
189                 my $is_varying;
190                 my $is_conformant;
191                 my $is_string = 0;
192                 if ($array_size) {
193                         $is_conformant = 1;
194                         if ($array_length = shift @length_is) {
195                                 $is_varying = 1;
196                         } else {
197                                 $array_length = $array_size;
198                                 $is_varying =0;
199                         }
200                 } 
201                 
202                 if (scalar(@size_is) == 0 and has_property($e, "string") and 
203                     $i == $e->{POINTERS}) {
204                         $is_string = 1;
205                         $is_varying = $is_conformant = has_property($e, "noheader")?0:1;
206                         delete($e->{PROPERTIES}->{string});
207                 }
208
209                 if ($array_size or $is_string) {
210                         push (@$order, {
211                                 TYPE => "ARRAY",
212                                 SIZE_IS => $array_size,
213                                 LENGTH_IS => $array_length,
214                                 IS_DEFERRED => $is_deferred,
215                                 IS_SURROUNDING => 0,
216                                 IS_ZERO_TERMINATED => $is_string,
217                                 IS_VARYING => $is_varying,
218                                 IS_CONFORMANT => $is_conformant,
219                                 IS_FIXED => 0,
220                                 IS_INLINE => 0
221                         });
222
223                         $is_deferred = 0;
224                 } 
225         }
226
227         if (defined(has_property($e, "subcontext"))) {
228                 my $hdr_size = has_property($e, "subcontext");
229                 my $subsize = has_property($e, "subcontext_size");
230                 if (not defined($subsize)) { 
231                         $subsize = -1; 
232                 }
233                 
234                 push (@$order, {
235                         TYPE => "SUBCONTEXT",
236                         HEADER_SIZE => $hdr_size,
237                         SUBCONTEXT_SIZE => $subsize,
238                         IS_DEFERRED => $is_deferred,
239                         COMPRESSION => has_property($e, "compression"),
240                 });
241         }
242
243         if (my $switch = has_property($e, "switch_is")) {
244                 push (@$order, {
245                         TYPE => "SWITCH", 
246                         SWITCH_IS => $switch,
247                         IS_DEFERRED => $is_deferred
248                 });
249         }
250
251         if (scalar(@size_is) > 0) {
252                 fatal($e, "size_is() on non-array element");
253         }
254
255         if (scalar(@length_is) > 0) {
256                 fatal($e, "length_is() on non-array element");
257         }
258
259         if (has_property($e, "string")) {
260                 fatal($e, "string() attribute on non-array element");
261         }
262
263         push (@$order, {
264                 TYPE => "DATA",
265                 DATA_TYPE => $e->{TYPE},
266                 IS_DEFERRED => $is_deferred,
267                 CONTAINS_DEFERRED => can_contain_deferred($e->{TYPE}),
268                 IS_SURROUNDING => 0 #FIXME
269         });
270
271         my $i = 0;
272         foreach (@$order) { $_->{LEVEL_INDEX} = $i; $i+=1; }
273
274         return $order;
275 }
276
277 #####################################################################
278 # see if a type contains any deferred data 
279 sub can_contain_deferred($)
280 {
281         sub can_contain_deferred($);
282         my ($type) = @_;
283
284         return 1 unless (hasType($type)); # assume the worst
285
286         $type = getType($type);
287
288         return 0 if (Parse::Pidl::Typelist::is_scalar($type));
289
290         return can_contain_deferred($type->{DATA}) if ($type->{TYPE} eq "TYPEDEF");
291
292         return 0 unless defined($type->{ELEMENTS});
293
294         foreach (@{$type->{ELEMENTS}}) {
295                 return 1 if ($_->{POINTERS});
296                 return 1 if (can_contain_deferred ($_->{TYPE}));
297         }
298         
299         return 0;
300 }
301
302 sub pointer_type($)
303 {
304         my $e = shift;
305
306         return undef unless $e->{POINTERS};
307         
308         return "ref" if (has_property($e, "ref"));
309         return "full" if (has_property($e, "ptr"));
310         return "sptr" if (has_property($e, "sptr"));
311         return "unique" if (has_property($e, "unique"));
312         return "relative" if (has_property($e, "relative"));
313         return "ignore" if (has_property($e, "ignore"));
314
315         return undef;
316 }
317
318 #####################################################################
319 # work out the correct alignment for a structure or union
320 sub find_largest_alignment($)
321 {
322         my $s = shift;
323
324         my $align = 1;
325         for my $e (@{$s->{ELEMENTS}}) {
326                 my $a = 1;
327
328                 if ($e->{POINTERS}) {
329                         $a = 4; 
330                 } elsif (has_property($e, "subcontext")) { 
331                         $a = 1;
332                 } elsif (has_property($e, "transmit_as")) {
333                         $a = align_type($e->{PROPERTIES}->{transmit_as});
334                 } else {
335                         $a = align_type($e->{TYPE}); 
336                 }
337
338                 $align = $a if ($align < $a);
339         }
340
341         return $align;
342 }
343
344 #####################################################################
345 # align a type
346 sub align_type($)
347 {
348         sub align_type($);
349         my ($e) = @_;
350
351         if (ref($e) eq "HASH" and $e->{TYPE} eq "SCALAR") {
352                 return $scalar_alignment->{$e->{NAME}};
353         }
354
355         return 0 if ($e eq "EMPTY");
356
357         unless (hasType($e)) {
358             # it must be an external type - all we can do is guess 
359                 # warning($e, "assuming alignment of unknown type '$e' is 4");
360             return 4;
361         }
362
363         my $dt = getType($e);
364
365         if ($dt->{TYPE} eq "TYPEDEF") {
366                 return align_type($dt->{DATA});
367         } elsif ($dt->{TYPE} eq "ENUM") {
368                 return align_type(Parse::Pidl::Typelist::enum_type_fn($dt));
369         } elsif ($dt->{TYPE} eq "BITMAP") {
370                 return align_type(Parse::Pidl::Typelist::bitmap_type_fn($dt));
371         } elsif (($dt->{TYPE} eq "STRUCT") or ($dt->{TYPE} eq "UNION")) {
372                 # Struct/union without body: assume 4
373                 return 4 unless (defined($dt->{ELEMENTS}));
374                 return find_largest_alignment($dt);
375         }
376
377         die("Unknown data type type $dt->{TYPE}");
378 }
379
380 sub ParseElement($$)
381 {
382         my ($e, $pointer_default) = @_;
383
384         $e->{TYPE} = expandAlias($e->{TYPE});
385
386         if (ref($e->{TYPE}) eq "HASH") {
387                 $e->{TYPE} = ParseType($e->{TYPE}, $pointer_default);
388         }
389
390         return {
391                 NAME => $e->{NAME},
392                 TYPE => $e->{TYPE},
393                 PROPERTIES => $e->{PROPERTIES},
394                 LEVELS => GetElementLevelTable($e),
395                 REPRESENTATION_TYPE => ($e->{PROPERTIES}->{represent_as} or $e->{TYPE}),
396                 ALIGN => align_type($e->{TYPE}),
397                 ORIGINAL => $e
398         };
399 }
400
401 sub ParseStruct($$)
402 {
403         my ($struct, $pointer_default) = @_;
404         my @elements = ();
405         my $surrounding = undef;
406
407         return {
408                 TYPE => "STRUCT",
409                 NAME => $struct->{NAME},
410                 SURROUNDING_ELEMENT => undef,
411                 ELEMENTS => undef,
412                 PROPERTIES => $struct->{PROPERTIES},
413                 ORIGINAL => $struct,
414                 ALIGN => undef
415         } unless defined($struct->{ELEMENTS});
416
417         CheckPointerTypes($struct, $pointer_default);
418
419         foreach my $x (@{$struct->{ELEMENTS}}) 
420         {
421                 my $e = ParseElement($x, $pointer_default);
422                 if ($x != $struct->{ELEMENTS}[-1] and 
423                         $e->{LEVELS}[0]->{IS_SURROUNDING}) {
424                         fatal($x, "conformant member not at end of struct");
425                 }
426                 push @elements, $e;
427         }
428
429         my $e = $elements[-1];
430         if (defined($e) and defined($e->{LEVELS}[0]->{IS_SURROUNDING}) and
431                 $e->{LEVELS}[0]->{IS_SURROUNDING}) {
432                 $surrounding = $e;
433         }
434
435         if (defined $e->{TYPE} && $e->{TYPE} eq "string"
436             &&  property_matches($e, "flag", ".*LIBNDR_FLAG_STR_CONFORMANT.*")) {
437                 $surrounding = $struct->{ELEMENTS}[-1];
438         }
439
440         my $align = undef;
441         if ($struct->{NAME}) {
442                 $align = align_type($struct->{NAME});
443         }
444                 
445         return {
446                 TYPE => "STRUCT",
447                 NAME => $struct->{NAME},
448                 SURROUNDING_ELEMENT => $surrounding,
449                 ELEMENTS => \@elements,
450                 PROPERTIES => $struct->{PROPERTIES},
451                 ORIGINAL => $struct,
452                 ALIGN => $align
453         };
454 }
455
456 sub ParseUnion($$)
457 {
458         my ($e, $pointer_default) = @_;
459         my @elements = ();
460         my $hasdefault = 0;
461         my $switch_type = has_property($e, "switch_type");
462         unless (defined($switch_type)) { $switch_type = "uint32"; }
463         if (has_property($e, "nodiscriminant")) { $switch_type = undef; }
464
465         return {
466                 TYPE => "UNION",
467                 NAME => $e->{NAME},
468                 SWITCH_TYPE => $switch_type,
469                 ELEMENTS => undef,
470                 PROPERTIES => $e->{PROPERTIES},
471                 HAS_DEFAULT => $hasdefault,
472                 ORIGINAL => $e
473         } unless defined($e->{ELEMENTS});
474
475         CheckPointerTypes($e, $pointer_default);
476
477         foreach my $x (@{$e->{ELEMENTS}}) 
478         {
479                 my $t;
480                 if ($x->{TYPE} eq "EMPTY") {
481                         $t = { TYPE => "EMPTY" };
482                 } else {
483                         $t = ParseElement($x, $pointer_default);
484                 }
485                 if (has_property($x, "default")) {
486                         $t->{CASE} = "default";
487                         $hasdefault = 1;
488                 } elsif (defined($x->{PROPERTIES}->{case})) {
489                         $t->{CASE} = "case $x->{PROPERTIES}->{case}";
490                 } else {
491                         die("Union element $x->{NAME} has neither default nor case property");
492                 }
493                 push @elements, $t;
494         }
495
496         return {
497                 TYPE => "UNION",
498                 NAME => $e->{NAME},
499                 SWITCH_TYPE => $switch_type,
500                 ELEMENTS => \@elements,
501                 PROPERTIES => $e->{PROPERTIES},
502                 HAS_DEFAULT => $hasdefault,
503                 ORIGINAL => $e
504         };
505 }
506
507 sub ParseEnum($$)
508 {
509         my ($e, $pointer_default) = @_;
510
511         return {
512                 TYPE => "ENUM",
513                 NAME => $e->{NAME},
514                 BASE_TYPE => Parse::Pidl::Typelist::enum_type_fn($e),
515                 ELEMENTS => $e->{ELEMENTS},
516                 PROPERTIES => $e->{PROPERTIES},
517                 ORIGINAL => $e
518         };
519 }
520
521 sub ParseBitmap($$)
522 {
523         my ($e, $pointer_default) = @_;
524
525         return {
526                 TYPE => "BITMAP",
527                 NAME => $e->{NAME},
528                 BASE_TYPE => Parse::Pidl::Typelist::bitmap_type_fn($e),
529                 ELEMENTS => $e->{ELEMENTS},
530                 PROPERTIES => $e->{PROPERTIES},
531                 ORIGINAL => $e
532         };
533 }
534
535 sub ParseType($$)
536 {
537         my ($d, $pointer_default) = @_;
538
539         my $data = {
540                 STRUCT => \&ParseStruct,
541                 UNION => \&ParseUnion,
542                 ENUM => \&ParseEnum,
543                 BITMAP => \&ParseBitmap,
544                 TYPEDEF => \&ParseTypedef,
545         }->{$d->{TYPE}}->($d, $pointer_default);
546
547         return $data;
548 }
549
550 sub ParseTypedef($$)
551 {
552         my ($d, $pointer_default) = @_;
553
554         if (defined($d->{DATA}->{PROPERTIES}) && !defined($d->{PROPERTIES})) {
555                 $d->{PROPERTIES} = $d->{DATA}->{PROPERTIES};
556         }
557
558         my $data = ParseType($d->{DATA}, $pointer_default);
559         $data->{ALIGN} = align_type($d->{NAME});
560
561         return {
562                 NAME => $d->{NAME},
563                 TYPE => $d->{TYPE},
564                 PROPERTIES => $d->{PROPERTIES},
565                 DATA => $data,
566                 ORIGINAL => $d
567         };
568 }
569
570 sub ParseConst($$)
571 {
572         my ($ndr,$d) = @_;
573
574         return $d;
575 }
576
577 sub ParseFunction($$$)
578 {
579         my ($ndr,$d,$opnum) = @_;
580         my @elements = ();
581         my $rettype = undef;
582         my $thisopnum = undef;
583
584         CheckPointerTypes($d, $ndr->{PROPERTIES}->{pointer_default_top});
585
586         if (not defined($d->{PROPERTIES}{noopnum})) {
587                 $thisopnum = ${$opnum};
588                 ${$opnum}++;
589         }
590
591         foreach my $x (@{$d->{ELEMENTS}}) {
592                 my $e = ParseElement($x, $ndr->{PROPERTIES}->{pointer_default});
593                 push (@{$e->{DIRECTION}}, "in") if (has_property($x, "in"));
594                 push (@{$e->{DIRECTION}}, "out") if (has_property($x, "out"));
595
596                 push (@elements, $e);
597         }
598
599         if ($d->{RETURN_TYPE} ne "void") {
600                 $rettype = expandAlias($d->{RETURN_TYPE});
601         }
602         
603         my $async = 0;
604         if (has_property($d, "async")) { $async = 1; }
605         
606         return {
607                         NAME => $d->{NAME},
608                         TYPE => "FUNCTION",
609                         OPNUM => $thisopnum,
610                         ASYNC => $async,
611                         RETURN_TYPE => $rettype,
612                         PROPERTIES => $d->{PROPERTIES},
613                         ELEMENTS => \@elements,
614                         ORIGINAL => $d
615                 };
616 }
617
618 sub CheckPointerTypes($$)
619 {
620         my ($s,$default) = @_;
621
622         return unless defined($s->{ELEMENTS});
623
624         foreach my $e (@{$s->{ELEMENTS}}) {
625                 if ($e->{POINTERS} and not defined(pointer_type($e))) {
626                         $e->{PROPERTIES}->{$default} = 1;
627                 }
628         }
629 }
630
631 sub FindNestedTypes($$)
632 {
633         sub FindNestedTypes($$);
634         my ($l, $t) = @_;
635
636         return if not defined($t->{ELEMENTS});
637         return if ($t->{TYPE} eq "ENUM");
638         return if ($t->{TYPE} eq "BITMAP");
639
640         foreach (@{$t->{ELEMENTS}}) {
641                 if (ref($_->{TYPE}) eq "HASH") {
642                         push (@$l, $_->{TYPE}) if (defined($_->{TYPE}->{NAME}));
643                         FindNestedTypes($l, $_->{TYPE});
644                 }
645         }
646 }
647
648 sub ParseInterface($)
649 {
650         my $idl = shift;
651         my @types = ();
652         my @consts = ();
653         my @functions = ();
654         my @endpoints;
655         my $opnum = 0;
656         my $version;
657
658         if (not has_property($idl, "pointer_default")) {
659                 # MIDL defaults to "ptr" in DCE compatible mode (/osf)
660                 # and "unique" in Microsoft Extensions mode (default)
661                 $idl->{PROPERTIES}->{pointer_default} = "unique";
662         }
663
664         if (not has_property($idl, "pointer_default_top")) {
665                 $idl->{PROPERTIES}->{pointer_default_top} = "ref";
666         } else {
667                 warning($idl, "pointer_default_top() is a pidl extension and should not be used");
668         }
669
670         foreach my $d (@{$idl->{DATA}}) {
671                 if ($d->{TYPE} eq "FUNCTION") {
672                         push (@functions, ParseFunction($idl, $d, \$opnum));
673                 } elsif ($d->{TYPE} eq "CONST") {
674                         push (@consts, ParseConst($idl, $d));
675                 } else {
676                         push (@types, ParseType($d, $idl->{PROPERTIES}->{pointer_default}));
677                         FindNestedTypes(\@types, $d);
678                 }
679         }
680
681         $version = "0.0";
682
683         if(defined $idl->{PROPERTIES}->{version}) { 
684                 $version = $idl->{PROPERTIES}->{version}; 
685         }
686
687         # If no endpoint is set, default to the interface name as a named pipe
688         if (!defined $idl->{PROPERTIES}->{endpoint}) {
689                 push @endpoints, "\"ncacn_np:[\\\\pipe\\\\" . $idl->{NAME} . "]\"";
690         } else {
691                 @endpoints = split / /, $idl->{PROPERTIES}->{endpoint};
692         }
693
694         return { 
695                 NAME => $idl->{NAME},
696                 UUID => lc(has_property($idl, "uuid")),
697                 VERSION => $version,
698                 TYPE => "INTERFACE",
699                 PROPERTIES => $idl->{PROPERTIES},
700                 FUNCTIONS => \@functions,
701                 CONSTS => \@consts,
702                 TYPES => \@types,
703                 ENDPOINTS => \@endpoints
704         };
705 }
706
707 # Convert a IDL tree to a NDR tree
708 # Gives a result tree describing all that's necessary for easily generating
709 # NDR parsers / generators
710 sub Parse($)
711 {
712         my $idl = shift;
713
714         return undef unless (defined($idl));
715
716         Parse::Pidl::NDR::Validate($idl);
717         
718         my @ndr = ();
719
720         foreach (@{$idl}) {
721                 ($_->{TYPE} eq "CPP_QUOTE") && push(@ndr, $_);
722                 ($_->{TYPE} eq "INTERFACE") && push(@ndr, ParseInterface($_));
723                 ($_->{TYPE} eq "IMPORT") && push(@ndr, $_);
724         }
725
726         return \@ndr;
727 }
728
729 sub GetNextLevel($$)
730 {
731         my $e = shift;
732         my $fl = shift;
733
734         my $seen = 0;
735
736         foreach my $l (@{$e->{LEVELS}}) {
737                 return $l if ($seen);
738                 ($seen = 1) if ($l == $fl);
739         }
740
741         return undef;
742 }
743
744 sub GetPrevLevel($$)
745 {
746         my ($e,$fl) = @_;
747         my $prev = undef;
748
749         foreach my $l (@{$e->{LEVELS}}) {
750                 (return $prev) if ($l == $fl);
751                 $prev = $l;
752         }
753
754         return undef;
755 }
756
757 sub ContainsString($)
758 {
759         my ($e) = @_;
760
761         foreach my $l (@{$e->{LEVELS}}) {
762                 return 1 if ($l->{TYPE} eq "ARRAY" and $l->{IS_ZERO_TERMINATED});
763         }
764
765         return 0;
766 }
767
768 sub ContainsDeferred($$)
769 {
770         my ($e,$l) = @_;
771
772         return 1 if ($l->{CONTAINS_DEFERRED});
773
774         while ($l = GetNextLevel($e,$l))
775         {
776                 return 1 if ($l->{IS_DEFERRED}); 
777                 return 1 if ($l->{CONTAINS_DEFERRED});
778         } 
779         
780         return 0;
781 }
782
783 sub el_name($)
784 {
785         my $e = shift;
786
787         if ($e->{PARENT} && $e->{PARENT}->{NAME}) {
788                 return "$e->{PARENT}->{NAME}.$e->{NAME}";
789         }
790
791         if ($e->{PARENT} && $e->{PARENT}->{PARENT}->{NAME}) {
792                 return "$e->{PARENT}->{PARENT}->{NAME}.$e->{NAME}";
793         }
794
795         if ($e->{PARENT}) {
796                 return "$e->{PARENT}->{NAME}.$e->{NAME}";
797         }
798
799         return $e->{NAME};
800 }
801
802 ###################################
803 # find a sibling var in a structure
804 sub find_sibling($$)
805 {
806         my($e,$name) = @_;
807         my($fn) = $e->{PARENT};
808
809         if ($name =~ /\*(.*)/) {
810                 $name = $1;
811         }
812
813         for my $e2 (@{$fn->{ELEMENTS}}) {
814                 return $e2 if ($e2->{NAME} eq $name);
815         }
816
817         return undef;
818 }
819
820 my %property_list = (
821         # interface
822         "helpstring"            => ["INTERFACE", "FUNCTION"],
823         "version"               => ["INTERFACE"],
824         "uuid"                  => ["INTERFACE"],
825         "endpoint"              => ["INTERFACE"],
826         "pointer_default"       => ["INTERFACE"],
827         "pointer_default_top"   => ["INTERFACE"],
828         "helper"                => ["INTERFACE"],
829         "authservice"           => ["INTERFACE"],
830
831         # dcom
832         "object"                => ["INTERFACE"],
833         "local"                 => ["INTERFACE", "FUNCTION"],
834         "iid_is"                => ["ELEMENT"],
835         "call_as"               => ["FUNCTION"],
836         "idempotent"            => ["FUNCTION"],
837
838         # function
839         "noopnum"               => ["FUNCTION"],
840         "in"                    => ["ELEMENT"],
841         "out"                   => ["ELEMENT"],
842         "async"                 => ["FUNCTION"],
843
844         # pointer
845         "ref"                   => ["ELEMENT"],
846         "ptr"                   => ["ELEMENT"],
847         "unique"                => ["ELEMENT"],
848         "ignore"                => ["ELEMENT"],
849         "relative"              => ["ELEMENT"],
850         "relative_base"         => ["TYPEDEF"],
851
852         "gensize"               => ["TYPEDEF"],
853         "value"                 => ["ELEMENT"],
854         "flag"                  => ["ELEMENT", "TYPEDEF"],
855
856         # generic
857         "public"                => ["FUNCTION", "TYPEDEF"],
858         "nopush"                => ["FUNCTION", "TYPEDEF"],
859         "nopull"                => ["FUNCTION", "TYPEDEF"],
860         "nosize"                => ["FUNCTION", "TYPEDEF"],
861         "noprint"               => ["FUNCTION", "TYPEDEF"],
862         "noejs"                 => ["FUNCTION", "TYPEDEF"],
863
864         # union
865         "switch_is"             => ["ELEMENT"],
866         "switch_type"           => ["ELEMENT", "TYPEDEF"],
867         "nodiscriminant"        => ["TYPEDEF"],
868         "case"                  => ["ELEMENT"],
869         "default"               => ["ELEMENT"],
870
871         "represent_as"          => ["ELEMENT"],
872         "transmit_as"           => ["ELEMENT"],
873
874         # subcontext
875         "subcontext"            => ["ELEMENT"],
876         "subcontext_size"       => ["ELEMENT"],
877         "compression"           => ["ELEMENT"],
878
879         # enum
880         "enum8bit"              => ["TYPEDEF"],
881         "enum16bit"             => ["TYPEDEF"],
882         "v1_enum"               => ["TYPEDEF"],
883
884         # bitmap
885         "bitmap8bit"            => ["TYPEDEF"],
886         "bitmap16bit"           => ["TYPEDEF"],
887         "bitmap32bit"           => ["TYPEDEF"],
888         "bitmap64bit"           => ["TYPEDEF"],
889
890         # array
891         "range"                 => ["ELEMENT"],
892         "size_is"               => ["ELEMENT"],
893         "string"                => ["ELEMENT"],
894         "noheader"              => ["ELEMENT"],
895         "charset"               => ["ELEMENT"],
896         "length_is"             => ["ELEMENT"],
897 );
898
899 #####################################################################
900 # check for unknown properties
901 sub ValidProperties($$)
902 {
903         my ($e,$t) = @_;
904
905         return unless defined $e->{PROPERTIES};
906
907         foreach my $key (keys %{$e->{PROPERTIES}}) {
908                 warning($e, el_name($e) . ": unknown property '$key'")
909                         unless defined($property_list{$key});
910
911                 fatal($e, el_name($e) . ": property '$key' not allowed on '$t'")
912                         unless grep($t, @{$property_list{$key}});
913         }
914 }
915
916 sub mapToScalar($)
917 {
918         sub mapToScalar($);
919         my $t = shift;
920         return $t->{NAME} if (ref($t) eq "HASH" and $t->{TYPE} eq "SCALAR");
921         my $ti = getType($t);
922
923         if (not defined ($ti)) {
924                 return undef;
925         } elsif ($ti->{TYPE} eq "TYPEDEF") {
926                 return mapToScalar($ti->{DATA});
927         } elsif ($ti->{TYPE} eq "ENUM") {
928                 return Parse::Pidl::Typelist::enum_type_fn($ti);
929         } elsif ($ti->{TYPE} eq "BITMAP") {
930                 return Parse::Pidl::Typelist::bitmap_type_fn($ti);
931         }
932
933         return undef;
934 }
935
936 #####################################################################
937 # validate an element
938 sub ValidElement($)
939 {
940         my $e = shift;
941
942         ValidProperties($e,"ELEMENT");
943
944         # Check whether switches are used correctly.
945         if (my $switch = has_property($e, "switch_is")) {
946                 my $e2 = find_sibling($e, $switch);
947                 my $type = getType($e->{TYPE});
948
949                 if (defined($type) and $type->{DATA}->{TYPE} ne "UNION") {
950                         fatal($e, el_name($e) . ": switch_is() used on non-union type $e->{TYPE} which is a $type->{DATA}->{TYPE}");
951                 }
952
953                 if (not has_property($type->{DATA}, "nodiscriminant") and defined($e2)) {
954                         my $discriminator_type = has_property($type->{DATA}, "switch_type");
955                         $discriminator_type = "uint32" unless defined ($discriminator_type);
956
957                         my $t1 = mapToScalar($discriminator_type);
958
959                         if (not defined($t1)) {
960                                 fatal($e, el_name($e) . ": unable to map discriminator type '$discriminator_type' to scalar");
961                         }
962
963                         my $t2 = mapToScalar($e2->{TYPE});
964                         if (not defined($t2)) {
965                                 fatal($e, el_name($e) . ": unable to map variable used for switch_is() to scalar");
966                         }
967
968                         if ($t1 ne $t2) {
969                                 warning($e, el_name($e) . ": switch_is() is of type $e2->{TYPE} ($t2), while discriminator type for union $type->{NAME} is $discriminator_type ($t1)");
970                         }
971                 }
972         }
973
974         if (has_property($e, "subcontext") and has_property($e, "represent_as")) {
975                 fatal($e, el_name($e) . " : subcontext() and represent_as() can not be used on the same element");
976         }
977
978         if (has_property($e, "subcontext") and has_property($e, "transmit_as")) {
979                 fatal($e, el_name($e) . " : subcontext() and transmit_as() can not be used on the same element");
980         }
981
982         if (has_property($e, "represent_as") and has_property($e, "transmit_as")) {
983                 fatal($e, el_name($e) . " : represent_as() and transmit_as() can not be used on the same element");
984         }
985
986         if (has_property($e, "represent_as") and has_property($e, "value")) {
987                 fatal($e, el_name($e) . " : represent_as() and value() can not be used on the same element");
988         }
989
990         if (has_property($e, "subcontext")) {
991                 warning($e, "subcontext() is deprecated. Use represent_as() or transmit_as() instead");
992         }
993
994         if (defined (has_property($e, "subcontext_size")) and not defined(has_property($e, "subcontext"))) {
995                 fatal($e, el_name($e) . " : subcontext_size() on non-subcontext element");
996         }
997
998         if (defined (has_property($e, "compression")) and not defined(has_property($e, "subcontext"))) {
999                 fatal($e, el_name($e) . " : compression() on non-subcontext element");
1000         }
1001
1002         if (!$e->{POINTERS} && (
1003                 has_property($e, "ptr") or
1004                 has_property($e, "unique") or
1005                 has_property($e, "relative") or
1006                 has_property($e, "ref"))) {
1007                 fatal($e, el_name($e) . " : pointer properties on non-pointer element\n");      
1008         }
1009 }
1010
1011 #####################################################################
1012 # validate an enum
1013 sub ValidEnum($)
1014 {
1015         my ($enum) = @_;
1016
1017         ValidProperties($enum, "ENUM");
1018 }
1019
1020 #####################################################################
1021 # validate a bitmap
1022 sub ValidBitmap($)
1023 {
1024         my ($bitmap) = @_;
1025
1026         ValidProperties($bitmap, "BITMAP");
1027 }
1028
1029 #####################################################################
1030 # validate a struct
1031 sub ValidStruct($)
1032 {
1033         my($struct) = shift;
1034
1035         ValidProperties($struct, "STRUCT");
1036
1037         return unless defined($struct->{ELEMENTS});
1038
1039         foreach my $e (@{$struct->{ELEMENTS}}) {
1040                 $e->{PARENT} = $struct;
1041                 ValidElement($e);
1042         }
1043 }
1044
1045 #####################################################################
1046 # parse a union
1047 sub ValidUnion($)
1048 {
1049         my($union) = shift;
1050
1051         ValidProperties($union,"UNION");
1052
1053         if (has_property($union->{PARENT}, "nodiscriminant") and has_property($union->{PARENT}, "switch_type")) {
1054                 fatal($union->{PARENT}, $union->{PARENT}->{NAME} . ": switch_type() on union without discriminant");
1055         }
1056
1057         return unless defined($union->{ELEMENTS});
1058
1059         foreach my $e (@{$union->{ELEMENTS}}) {
1060                 $e->{PARENT} = $union;
1061
1062                 if (defined($e->{PROPERTIES}->{default}) and 
1063                         defined($e->{PROPERTIES}->{case})) {
1064                         fatal($e, "Union member $e->{NAME} can not have both default and case properties!");
1065                 }
1066                 
1067                 unless (defined ($e->{PROPERTIES}->{default}) or 
1068                                 defined ($e->{PROPERTIES}->{case})) {
1069                         fatal($e, "Union member $e->{NAME} must have default or case property");
1070                 }
1071
1072                 if (has_property($e, "ref")) {
1073                         fatal($e, el_name($e) . " : embedded ref pointers are not supported yet\n");
1074                 }
1075
1076
1077                 ValidElement($e);
1078         }
1079 }
1080
1081 #####################################################################
1082 # parse a typedef
1083 sub ValidTypedef($)
1084 {
1085         my($typedef) = shift;
1086         my $data = $typedef->{DATA};
1087
1088         ValidProperties($typedef, "TYPEDEF");
1089
1090         $data->{PARENT} = $typedef;
1091
1092         ValidType($data) if (ref($data) eq "HASH");
1093 }
1094
1095 #####################################################################
1096 # validate a function
1097 sub ValidFunction($)
1098 {
1099         my($fn) = shift;
1100
1101         ValidProperties($fn,"FUNCTION");
1102
1103         foreach my $e (@{$fn->{ELEMENTS}}) {
1104                 $e->{PARENT} = $fn;
1105                 if (has_property($e, "ref") && !$e->{POINTERS}) {
1106                         fatal($e, "[ref] variables must be pointers ($fn->{NAME}/$e->{NAME})");
1107                 }
1108                 ValidElement($e);
1109         }
1110 }
1111
1112 #####################################################################
1113 # validate a type
1114 sub ValidType($)
1115 {
1116         my ($t) = @_;
1117
1118         { 
1119                 TYPEDEF => \&ValidTypedef,
1120                 STRUCT => \&ValidStruct,
1121                 UNION => \&ValidUnion,
1122                 ENUM => \&ValidEnum,
1123                 BITMAP => \&ValidBitmap
1124         }->{$t->{TYPE}}->($t);
1125 }
1126
1127 #####################################################################
1128 # parse the interface definitions
1129 sub ValidInterface($)
1130 {
1131         my($interface) = shift;
1132         my($data) = $interface->{DATA};
1133
1134         if (has_property($interface, "helper")) {
1135                 warning($interface, "helper() is pidl-specific and deprecated. Use `include' instead");
1136         }
1137
1138         ValidProperties($interface,"INTERFACE");
1139
1140         if (has_property($interface, "pointer_default")) {
1141                 if (not grep (/$interface->{PROPERTIES}->{pointer_default}/, 
1142                                         ("ref", "unique", "ptr"))) {
1143                         fatal($interface, "Unknown default pointer type `$interface->{PROPERTIES}->{pointer_default}'");
1144                 }
1145         }
1146
1147         if (has_property($interface, "object")) {
1148                 if (has_property($interface, "version") && 
1149                         $interface->{PROPERTIES}->{version} != 0) {
1150                         fatal($interface, "Object interfaces must have version 0.0 ($interface->{NAME})");
1151                 }
1152
1153                 if (!defined($interface->{BASE}) && 
1154                         not ($interface->{NAME} eq "IUnknown")) {
1155                         fatal($interface, "Object interfaces must all derive from IUnknown ($interface->{NAME})");
1156                 }
1157         }
1158                 
1159         foreach my $d (@{$data}) {
1160                 ($d->{TYPE} eq "FUNCTION") && ValidFunction($d);
1161                 ($d->{TYPE} eq "TYPEDEF" or 
1162                  $d->{TYPE} eq "STRUCT" or
1163                  $d->{TYPE} eq "UNION" or 
1164                  $d->{TYPE} eq "ENUM" or
1165                  $d->{TYPE} eq "BITMAP") && ValidType($d);
1166         }
1167
1168 }
1169
1170 #####################################################################
1171 # Validate an IDL structure
1172 sub Validate($)
1173 {
1174         my($idl) = shift;
1175
1176         foreach my $x (@{$idl}) {
1177                 ($x->{TYPE} eq "INTERFACE") && 
1178                     ValidInterface($x);
1179                 ($x->{TYPE} eq "IMPORTLIB") &&
1180                         fatal($x, "importlib() not supported");
1181         }
1182 }
1183
1184 1;