← Back to branch summary

~zulcss/samba/server-dailies-3.4

« back to all changes in this revision

Viewing changes to pidl/lib/Parse/Pidl/NDR.pm

  • Committer: Chuck Short
  • Date: 2010-09-28 20:38:39 UTC
  • Revision ID: zulcss@ubuntu.com-20100928203839-pgjulytsi9ue63x1
Initial version

Show diffs side-by-side

added added

removed removed

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