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