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 12Parse::Pidl::NDR - NDR parsing information generator 13 14=head1 DESCRIPTION 15 16Return a table describing the order in which the parts of an element 17should be parsed 18Possible level types: 19 - POINTER 20 - ARRAY 21 - SUBCONTEXT 22 - SWITCH 23 - DATA 24 25=head1 AUTHOR 26 27Jelmer Vernooij <jelmer@samba.org> 28 29=cut 30 31package Parse::Pidl::NDR; 32 33require Exporter; 34use vars qw($VERSION); 35$VERSION = '0.01'; 36@ISA = qw(Exporter); 37@EXPORT = qw(GetPrevLevel GetNextLevel ContainsDeferred ContainsPipe ContainsString); 38@EXPORT_OK = qw(GetElementLevelTable ParseElement ReturnTypeElement ValidElement align_type mapToScalar ParseType can_contain_deferred is_charset_array); 39 40use strict; 41use Parse::Pidl qw(warning fatal); 42use Parse::Pidl::Typelist qw(hasType getType typeIs expandAlias mapScalarType is_fixed_size_scalar); 43use Parse::Pidl::Util qw(has_property property_matches); 44 45# Alignment of the built-in scalar types 46my $scalar_alignment = { 47 'void' => 0, 48 'char' => 1, 49 'int8' => 1, 50 'uint8' => 1, 51 'int16' => 2, 52 'uint16' => 2, 53 'int1632' => 3, 54 'uint1632' => 3, 55 'int32' => 4, 56 'uint32' => 4, 57 'int3264' => 5, 58 'uint3264' => 5, 59 'hyper' => 8, 60 'double' => 8, 61 'pointer' => 8, 62 'dlong' => 4, 63 'udlong' => 4, 64 'udlongr' => 4, 65 'DATA_BLOB' => 4, 66 'string' => 4, 67 'string_array' => 4, #??? 68 'time_t' => 4, 69 'uid_t' => 8, 70 'gid_t' => 8, 71 'NTTIME' => 4, 72 'NTTIME_1sec' => 4, 73 'NTTIME_hyper' => 8, 74 'WERROR' => 4, 75 'NTSTATUS' => 4, 76 'COMRESULT' => 4, 77 'dns_string' => 4, 78 'nbt_string' => 4, 79 'wrepl_nbt_name' => 4, 80 'ipv4address' => 4, 81 'ipv6address' => 4, #16? 82 'dnsp_name' => 1, 83 'dnsp_string' => 1 84}; 85 86sub GetElementLevelTable($$$) 87{ 88 my ($e, $pointer_default, $ms_union) = @_; 89 90 my $order = []; 91 my $is_deferred = 0; 92 my @bracket_array = (); 93 my @length_is = (); 94 my @size_is = (); 95 my $pointer_idx = 0; 96 97 if (has_property($e, "size_is")) { 98 @size_is = split /,/, has_property($e, "size_is"); 99 } 100 101 if (has_property($e, "length_is")) { 102 @length_is = split /,/, has_property($e, "length_is"); 103 } 104 105 if (defined($e->{ARRAY_LEN})) { 106 @bracket_array = @{$e->{ARRAY_LEN}}; 107 } 108 109 if (has_property($e, "out")) { 110 my $needptrs = 1; 111 112 if (has_property($e, "string") and not has_property($e, "in")) { $needptrs++; } 113 if ($#bracket_array >= 0) { $needptrs = 0; } 114 115 warning($e, "[out] argument `$e->{NAME}' not a pointer") if ($needptrs > $e->{POINTERS}); 116 } 117 118 my $allow_pipe = ($e->{PARENT}->{TYPE} eq "FUNCTION"); 119 my $is_pipe = typeIs($e->{TYPE}, "PIPE"); 120 121 if ($is_pipe) { 122 if (not $allow_pipe) { 123 fatal($e, "argument `$e->{NAME}' is a pipe and not allowed on $e->{PARENT}->{TYPE}"); 124 } 125 126 if ($e->{POINTERS} > 1) { 127 fatal($e, "$e->{POINTERS} are not allowed on pipe element $e->{NAME}"); 128 } 129 130 if ($e->{POINTERS} < 0) { 131 fatal($e, "pipe element $e->{NAME} needs pointer"); 132 } 133 134 if ($e->{POINTERS} == 1 and pointer_type($e) ne "ref") { 135 fatal($e, "pointer should be 'ref' on pipe element $e->{NAME}"); 136 } 137 138 if (scalar(@size_is) > 0) { 139 fatal($e, "size_is() on pipe element"); 140 } 141 142 if (scalar(@length_is) > 0) { 143 fatal($e, "length_is() on pipe element"); 144 } 145 146 if (scalar(@bracket_array) > 0) { 147 fatal($e, "brackets on pipe element"); 148 } 149 150 if (defined(has_property($e, "subcontext"))) { 151 fatal($e, "subcontext on pipe element"); 152 } 153 154 if (has_property($e, "switch_is")) { 155 fatal($e, "switch_is on pipe element"); 156 } 157 158 if (can_contain_deferred($e->{TYPE})) { 159 fatal($e, "$e->{TYPE} can_contain_deferred - not allowed on pipe element"); 160 } 161 } 162 163 # Parse the [][][][] style array stuff 164 for my $i (0 .. $#bracket_array) { 165 my $d = $bracket_array[$#bracket_array - $i]; 166 my $size = $d; 167 my $length = $d; 168 my $is_surrounding = 0; 169 my $is_varying = 0; 170 my $is_conformant = 0; 171 my $is_string = 0; 172 my $is_fixed = 0; 173 my $is_inline = 0; 174 my $is_to_null = 0; 175 176 if ($d eq "*") { 177 $is_conformant = 1; 178 if ($size = shift @size_is) { 179 if ($e->{POINTERS} < 1 and has_property($e, "string")) { 180 $is_string = 1; 181 delete($e->{PROPERTIES}->{string}); 182 } 183 } elsif ((scalar(@size_is) == 0) and has_property($e, "string")) { 184 $is_string = 1; 185 delete($e->{PROPERTIES}->{string}); 186 } else { 187 fatal($e, "Must specify size_is() for conformant array!") 188 } 189 190 if (($length = shift @length_is) or $is_string) { 191 $is_varying = 1; 192 } else { 193 $length = $size; 194 } 195 196 if ($e == $e->{PARENT}->{ELEMENTS}[-1] 197 and $e->{PARENT}->{TYPE} ne "FUNCTION") { 198 $is_surrounding = 1; 199 } 200 } 201 202 $is_fixed = 1 if (not $is_conformant and Parse::Pidl::Util::is_constant($size)); 203 $is_inline = 1 if (not $is_conformant and not Parse::Pidl::Util::is_constant($size)); 204 205 if ($i == 0 and $is_fixed and has_property($e, "string")) { 206 $is_fixed = 0; 207 $is_varying = 1; 208 $is_string = 1; 209 delete($e->{PROPERTIES}->{string}); 210 } 211 212 if (has_property($e, "to_null")) { 213 $is_to_null = 1; 214 } 215 216 push (@$order, { 217 TYPE => "ARRAY", 218 SIZE_IS => $size, 219 LENGTH_IS => $length, 220 IS_DEFERRED => $is_deferred, 221 IS_SURROUNDING => $is_surrounding, 222 IS_ZERO_TERMINATED => $is_string, 223 IS_VARYING => $is_varying, 224 IS_CONFORMANT => $is_conformant, 225 IS_FIXED => $is_fixed, 226 IS_INLINE => $is_inline, 227 IS_TO_NULL => $is_to_null 228 }); 229 } 230 231 # Next, all the pointers 232 foreach my $i (1..$e->{POINTERS}) { 233 my $level = "EMBEDDED"; 234 # Top level "ref" pointers do not have a referrent identifier 235 $level = "TOP" if ($i == 1 and $e->{PARENT}->{TYPE} eq "FUNCTION"); 236 237 my $pt; 238 # 239 # Only the first level gets the pointer type from the 240 # pointer property, the others get them from 241 # the pointer_default() interface property 242 # 243 # see http://msdn2.microsoft.com/en-us/library/aa378984(VS.85).aspx 244 # (Here they talk about the rightmost pointer, but testing shows 245 # they mean the leftmost pointer.) 246 # 247 # --metze 248 # 249 $pt = pointer_type($e); 250 if ($i > 1) { 251 $is_deferred = 1 if ($pt ne "ref" and $e->{PARENT}->{TYPE} eq "FUNCTION"); 252 $pt = $pointer_default; 253 } 254 255 push (@$order, { 256 TYPE => "POINTER", 257 POINTER_TYPE => $pt, 258 POINTER_INDEX => $pointer_idx, 259 IS_DEFERRED => "$is_deferred", 260 LEVEL => $level 261 }); 262 263 warning($e, "top-level \[out\] pointer `$e->{NAME}' is not a \[ref\] pointer") 264 if ($i == 1 and $pt ne "ref" and 265 $e->{PARENT}->{TYPE} eq "FUNCTION" and 266 not has_property($e, "in")); 267 268 $pointer_idx++; 269 270 # everything that follows will be deferred 271 $is_deferred = 1 if ($level ne "TOP"); 272 273 my $array_size = shift @size_is; 274 my $array_length; 275 my $is_varying; 276 my $is_conformant; 277 my $is_string = 0; 278 if ($array_size) { 279 $is_conformant = 1; 280 if ($array_length = shift @length_is) { 281 $is_varying = 1; 282 } else { 283 $array_length = $array_size; 284 $is_varying =0; 285 } 286 } 287 288 if (scalar(@size_is) == 0 and has_property($e, "string") and 289 $i == $e->{POINTERS}) { 290 $is_string = 1; 291 $is_varying = $is_conformant = has_property($e, "noheader")?0:1; 292 delete($e->{PROPERTIES}->{string}); 293 } 294 295 if ($array_size or $is_string) { 296 push (@$order, { 297 TYPE => "ARRAY", 298 SIZE_IS => $array_size, 299 LENGTH_IS => $array_length, 300 IS_DEFERRED => $is_deferred, 301 IS_SURROUNDING => 0, 302 IS_ZERO_TERMINATED => $is_string, 303 IS_VARYING => $is_varying, 304 IS_CONFORMANT => $is_conformant, 305 IS_FIXED => 0, 306 IS_INLINE => 0 307 }); 308 309 $is_deferred = 0; 310 } 311 } 312 313 if ($is_pipe) { 314 push (@$order, { 315 TYPE => "PIPE", 316 IS_DEFERRED => 0, 317 CONTAINS_DEFERRED => 0, 318 }); 319 320 my $i = 0; 321 foreach (@$order) { $_->{LEVEL_INDEX} = $i; $i+=1; } 322 323 return $order; 324 } 325 326 if (defined(has_property($e, "subcontext"))) { 327 my $hdr_size = has_property($e, "subcontext"); 328 my $subsize = has_property($e, "subcontext_size"); 329 if (not defined($subsize)) { 330 $subsize = -1; 331 } 332 333 push (@$order, { 334 TYPE => "SUBCONTEXT", 335 HEADER_SIZE => $hdr_size, 336 SUBCONTEXT_SIZE => $subsize, 337 IS_DEFERRED => $is_deferred, 338 COMPRESSION => has_property($e, "compression"), 339 }); 340 } 341 342 if (my $switch = has_property($e, "switch_is")) { 343 push (@$order, { 344 TYPE => "SWITCH", 345 SWITCH_IS => $switch, 346 IS_DEFERRED => $is_deferred 347 }); 348 } 349 350 if (scalar(@size_is) > 0) { 351 fatal($e, "size_is() on non-array element"); 352 } 353 354 if (scalar(@length_is) > 0) { 355 fatal($e, "length_is() on non-array element"); 356 } 357 358 if (has_property($e, "string")) { 359 fatal($e, "string() attribute on non-array element"); 360 } 361 362 push (@$order, { 363 TYPE => "DATA", 364 DATA_TYPE => $e->{TYPE}, 365 IS_DEFERRED => $is_deferred, 366 CONTAINS_DEFERRED => can_contain_deferred($e->{TYPE}), 367 IS_SURROUNDING => 0 #FIXME 368 }); 369 370 my $i = 0; 371 foreach (@$order) { $_->{LEVEL_INDEX} = $i; $i+=1; } 372 373 return $order; 374} 375 376sub GetTypedefLevelTable($$$$) 377{ 378 my ($e, $data, $pointer_default, $ms_union) = @_; 379 380 my $order = []; 381 382 push (@$order, { 383 TYPE => "TYPEDEF" 384 }); 385 386 my $i = 0; 387 foreach (@$order) { $_->{LEVEL_INDEX} = $i; $i+=1; } 388 389 return $order; 390} 391 392##################################################################### 393# see if a type contains any deferred data 394sub can_contain_deferred($) 395{ 396 sub can_contain_deferred($); 397 my ($type) = @_; 398 399 return 1 unless (hasType($type)); # assume the worst 400 401 $type = getType($type); 402 403 return 0 if (Parse::Pidl::Typelist::is_scalar($type)); 404 405 return can_contain_deferred($type->{DATA}) if ($type->{TYPE} eq "TYPEDEF"); 406 407 return 0 unless defined($type->{ELEMENTS}); 408 409 foreach (@{$type->{ELEMENTS}}) { 410 return 1 if ($_->{POINTERS}); 411 return 1 if (can_contain_deferred ($_->{TYPE})); 412 } 413 414 return 0; 415} 416 417sub pointer_type($) 418{ 419 my $e = shift; 420 421 return undef unless $e->{POINTERS}; 422 423 return "ref" if (has_property($e, "ref")); 424 return "full" if (has_property($e, "ptr")); 425 return "sptr" if (has_property($e, "sptr")); 426 return "unique" if (has_property($e, "unique")); 427 return "relative" if (has_property($e, "relative")); 428 return "relative_short" if (has_property($e, "relative_short")); 429 return "ignore" if (has_property($e, "ignore")); 430 431 return undef; 432} 433 434##################################################################### 435# work out the correct alignment for a structure or union 436sub find_largest_alignment($) 437{ 438 my $s = shift; 439 440 my $align = 1; 441 for my $e (@{$s->{ELEMENTS}}) { 442 my $a = 1; 443 444 if ($e->{POINTERS}) { 445 # this is a hack for NDR64 446 # the NDR layer translates this into 447 # an alignment of 4 for NDR and 8 for NDR64 448 $a = 5; 449 } elsif (has_property($e, "subcontext")) { 450 $a = 1; 451 } elsif (has_property($e, "transmit_as")) { 452 $a = align_type($e->{PROPERTIES}->{transmit_as}); 453 } else { 454 $a = align_type($e->{TYPE}); 455 } 456 457 $align = $a if ($align < $a); 458 } 459 460 return $align; 461} 462 463##################################################################### 464# align a type 465sub align_type($) 466{ 467 sub align_type($); 468 my ($e) = @_; 469 470 if (ref($e) eq "HASH" and $e->{TYPE} eq "SCALAR") { 471 return $scalar_alignment->{$e->{NAME}}; 472 } 473 474 return 0 if ($e eq "EMPTY"); 475 476 unless (hasType($e)) { 477 # it must be an external type - all we can do is guess 478 # warning($e, "assuming alignment of unknown type '$e' is 4"); 479 return 4; 480 } 481 482 my $dt = getType($e); 483 484 if ($dt->{TYPE} eq "TYPEDEF") { 485 return align_type($dt->{DATA}); 486 } elsif ($dt->{TYPE} eq "CONFORMANCE") { 487 return $dt->{DATA}->{ALIGN}; 488 } elsif ($dt->{TYPE} eq "ENUM") { 489 return align_type(Parse::Pidl::Typelist::enum_type_fn($dt)); 490 } elsif ($dt->{TYPE} eq "BITMAP") { 491 return align_type(Parse::Pidl::Typelist::bitmap_type_fn($dt)); 492 } elsif (($dt->{TYPE} eq "STRUCT") or ($dt->{TYPE} eq "UNION")) { 493 # Struct/union without body: assume 4 494 return 4 unless (defined($dt->{ELEMENTS})); 495 return find_largest_alignment($dt); 496 } elsif (($dt->{TYPE} eq "PIPE")) { 497 return 5; 498 } 499 500 die("Unknown data type type $dt->{TYPE}"); 501} 502 503sub ParseElement($$$) 504{ 505 my ($e, $pointer_default, $ms_union) = @_; 506 507 $e->{TYPE} = expandAlias($e->{TYPE}); 508 509 if (ref($e->{TYPE}) eq "HASH") { 510 $e->{TYPE} = ParseType($e->{TYPE}, $pointer_default, $ms_union); 511 } 512 513 return { 514 NAME => $e->{NAME}, 515 TYPE => $e->{TYPE}, 516 PROPERTIES => $e->{PROPERTIES}, 517 LEVELS => GetElementLevelTable($e, $pointer_default, $ms_union), 518 REPRESENTATION_TYPE => ($e->{PROPERTIES}->{represent_as} or $e->{TYPE}), 519 ALIGN => align_type($e->{TYPE}), 520 ORIGINAL => $e 521 }; 522} 523 524sub ParseStruct($$$) 525{ 526 my ($struct, $pointer_default, $ms_union) = @_; 527 my @elements = (); 528 my $surrounding = undef; 529 530 return { 531 TYPE => "STRUCT", 532 NAME => $struct->{NAME}, 533 SURROUNDING_ELEMENT => undef, 534 ELEMENTS => undef, 535 PROPERTIES => $struct->{PROPERTIES}, 536 ORIGINAL => $struct, 537 ALIGN => undef 538 } unless defined($struct->{ELEMENTS}); 539 540 CheckPointerTypes($struct, $pointer_default); 541 542 foreach my $x (@{$struct->{ELEMENTS}}) 543 { 544 my $e = ParseElement($x, $pointer_default, $ms_union); 545 if ($x != $struct->{ELEMENTS}[-1] and 546 $e->{LEVELS}[0]->{IS_SURROUNDING}) { 547 fatal($x, "conformant member not at end of struct"); 548 } 549 push @elements, $e; 550 } 551 552 my $e = $elements[-1]; 553 if (defined($e) and defined($e->{LEVELS}[0]->{IS_SURROUNDING}) and 554 $e->{LEVELS}[0]->{IS_SURROUNDING}) { 555 $surrounding = $e; 556 } 557 558 if (defined $e->{TYPE} && $e->{TYPE} eq "string" 559 && property_matches($e, "flag", ".*LIBNDR_FLAG_STR_CONFORMANT.*")) { 560 $surrounding = $struct->{ELEMENTS}[-1]; 561 } 562 563 my $align = undef; 564 if ($struct->{NAME}) { 565 $align = align_type($struct->{NAME}); 566 } 567 568 return { 569 TYPE => "STRUCT", 570 NAME => $struct->{NAME}, 571 SURROUNDING_ELEMENT => $surrounding, 572 ELEMENTS => \@elements, 573 PROPERTIES => $struct->{PROPERTIES}, 574 ORIGINAL => $struct, 575 ALIGN => $align 576 }; 577} 578 579sub ParseUnion($$) 580{ 581 my ($e, $pointer_default, $ms_union) = @_; 582 my @elements = (); 583 my $is_ms_union = $ms_union; 584 $is_ms_union = 1 if has_property($e, "ms_union"); 585 my $hasdefault = 0; 586 my $switch_type = has_property($e, "switch_type"); 587 unless (defined($switch_type)) { $switch_type = "uint32"; } 588 if (has_property($e, "nodiscriminant")) { $switch_type = undef; } 589 590 return { 591 TYPE => "UNION", 592 NAME => $e->{NAME}, 593 SWITCH_TYPE => $switch_type, 594 ELEMENTS => undef, 595 PROPERTIES => $e->{PROPERTIES}, 596 HAS_DEFAULT => $hasdefault, 597 IS_MS_UNION => $is_ms_union, 598 ORIGINAL => $e, 599 ALIGN => undef 600 } unless defined($e->{ELEMENTS}); 601 602 CheckPointerTypes($e, $pointer_default); 603 604 foreach my $x (@{$e->{ELEMENTS}}) 605 { 606 my $t; 607 if ($x->{TYPE} eq "EMPTY") { 608 $t = { TYPE => "EMPTY" }; 609 } else { 610 $t = ParseElement($x, $pointer_default, $ms_union); 611 } 612 if (has_property($x, "default")) { 613 $t->{CASE} = "default"; 614 $hasdefault = 1; 615 } elsif (defined($x->{PROPERTIES}->{case})) { 616 $t->{CASE} = "case $x->{PROPERTIES}->{case}"; 617 } else { 618 die("Union element $x->{NAME} has neither default nor case property"); 619 } 620 push @elements, $t; 621 } 622 623 my $align = undef; 624 if ($e->{NAME}) { 625 $align = align_type($e->{NAME}); 626 } 627 628 return { 629 TYPE => "UNION", 630 NAME => $e->{NAME}, 631 SWITCH_TYPE => $switch_type, 632 ELEMENTS => \@elements, 633 PROPERTIES => $e->{PROPERTIES}, 634 HAS_DEFAULT => $hasdefault, 635 IS_MS_UNION => $is_ms_union, 636 ORIGINAL => $e, 637 ALIGN => $align 638 }; 639} 640 641sub ParseEnum($$) 642{ 643 my ($e, $pointer_default, $ms_union) = @_; 644 645 return { 646 TYPE => "ENUM", 647 NAME => $e->{NAME}, 648 BASE_TYPE => Parse::Pidl::Typelist::enum_type_fn($e), 649 ELEMENTS => $e->{ELEMENTS}, 650 PROPERTIES => $e->{PROPERTIES}, 651 ORIGINAL => $e 652 }; 653} 654 655sub ParseBitmap($$$) 656{ 657 my ($e, $pointer_default, $ms_union) = @_; 658 659 return { 660 TYPE => "BITMAP", 661 NAME => $e->{NAME}, 662 BASE_TYPE => Parse::Pidl::Typelist::bitmap_type_fn($e), 663 ELEMENTS => $e->{ELEMENTS}, 664 PROPERTIES => $e->{PROPERTIES}, 665 ORIGINAL => $e 666 }; 667} 668 669sub ParsePipe($$$) 670{ 671 my ($pipe, $pointer_default, $ms_union) = @_; 672 673 my $pname = $pipe->{NAME}; 674 $pname = $pipe->{PARENT}->{NAME} unless defined $pname; 675 676 if (not defined($pipe->{PROPERTIES}) 677 and defined($pipe->{PARENT}->{PROPERTIES})) { 678 $pipe->{PROPERTIES} = $pipe->{PARENT}->{PROPERTIES}; 679 } 680 681 if (ref($pipe->{DATA}) eq "HASH") { 682 if (not defined($pipe->{DATA}->{PROPERTIES}) 683 and defined($pipe->{PROPERTIES})) { 684 $pipe->{DATA}->{PROPERTIES} = $pipe->{PROPERTIES}; 685 } 686 } 687 688 my $struct = ParseStruct($pipe->{DATA}, $pointer_default, $ms_union); 689 $struct->{ALIGN} = 5; 690 $struct->{NAME} = "$pname\_chunk"; 691 692 # 'count' is element [0] and 'array' [1] 693 my $e = $struct->{ELEMENTS}[1]; 694 # level [0] is of type "ARRAY" 695 my $l = $e->{LEVELS}[1]; 696 697 # here we check that pipe elements have a fixed size type 698 while (defined($l)) { 699 my $cl = $l; 700 $l = GetNextLevel($e, $cl); 701 if ($cl->{TYPE} ne "DATA") { 702 fatal($pipe, el_name($pipe) . ": pipe contains non DATA level"); 703 } 704 705 # for now we only support scalars 706 next if is_fixed_size_scalar($cl->{DATA_TYPE}); 707 708 fatal($pipe, el_name($pipe) . ": pipe contains non fixed size type[$cl->{DATA_TYPE}]"); 709 } 710 711 return { 712 TYPE => "PIPE", 713 NAME => $pipe->{NAME}, 714 DATA => $struct, 715 PROPERTIES => $pipe->{PROPERTIES}, 716 ORIGINAL => $pipe, 717 }; 718} 719 720sub ParseType($$$) 721{ 722 my ($d, $pointer_default, $ms_union) = @_; 723 724 my $data = { 725 STRUCT => \&ParseStruct, 726 UNION => \&ParseUnion, 727 ENUM => \&ParseEnum, 728 BITMAP => \&ParseBitmap, 729 TYPEDEF => \&ParseTypedef, 730 PIPE => \&ParsePipe, 731 }->{$d->{TYPE}}->($d, $pointer_default, $ms_union); 732 733 return $data; 734} 735 736sub ParseTypedef($$) 737{ 738 my ($d, $pointer_default, $ms_union) = @_; 739 740 my $data; 741 742 if (ref($d->{DATA}) eq "HASH") { 743 if (defined($d->{DATA}->{PROPERTIES}) 744 and not defined($d->{PROPERTIES})) { 745 $d->{PROPERTIES} = $d->{DATA}->{PROPERTIES}; 746 } 747 748 $data = ParseType($d->{DATA}, $pointer_default, $ms_union); 749 $data->{ALIGN} = align_type($d->{NAME}); 750 } else { 751 $data = getType($d->{DATA}); 752 } 753 754 return { 755 NAME => $d->{NAME}, 756 TYPE => $d->{TYPE}, 757 PROPERTIES => $d->{PROPERTIES}, 758 LEVELS => GetTypedefLevelTable($d, $data, $pointer_default, $ms_union), 759 DATA => $data, 760 ORIGINAL => $d 761 }; 762} 763 764sub ParseConst($$) 765{ 766 my ($ndr,$d) = @_; 767 768 return $d; 769} 770 771sub ParseFunction($$$$) 772{ 773 my ($ndr,$d,$opnum,$ms_union) = @_; 774 my @elements = (); 775 my $rettype = undef; 776 my $thisopnum = undef; 777 778 CheckPointerTypes($d, "ref"); 779 780 if (not defined($d->{PROPERTIES}{noopnum})) { 781 $thisopnum = ${$opnum}; 782 ${$opnum}++; 783 } 784 785 foreach my $x (@{$d->{ELEMENTS}}) { 786 my $e = ParseElement($x, $ndr->{PROPERTIES}->{pointer_default}, $ms_union); 787 push (@{$e->{DIRECTION}}, "in") if (has_property($x, "in")); 788 push (@{$e->{DIRECTION}}, "out") if (has_property($x, "out")); 789 790 push (@elements, $e); 791 } 792 793 if ($d->{RETURN_TYPE} ne "void") { 794 $rettype = expandAlias($d->{RETURN_TYPE}); 795 } 796 797 return { 798 NAME => $d->{NAME}, 799 TYPE => "FUNCTION", 800 OPNUM => $thisopnum, 801 RETURN_TYPE => $rettype, 802 PROPERTIES => $d->{PROPERTIES}, 803 ELEMENTS => \@elements, 804 ORIGINAL => $d 805 }; 806} 807 808sub ReturnTypeElement($) 809{ 810 my ($fn) = @_; 811 812 return undef unless defined($fn->{RETURN_TYPE}); 813 814 my $e = { 815 "NAME" => "result", 816 "TYPE" => $fn->{RETURN_TYPE}, 817 "PROPERTIES" => undef, 818 "POINTERS" => 0, 819 "ARRAY_LEN" => [], 820 "FILE" => $fn->{FILE}, 821 "LINE" => $fn->{LINE}, 822 }; 823 824 return ParseElement($e, 0, 0); 825} 826 827sub CheckPointerTypes($$) 828{ 829 my ($s,$default) = @_; 830 831 return unless defined($s->{ELEMENTS}); 832 833 foreach my $e (@{$s->{ELEMENTS}}) { 834 if ($e->{POINTERS} and not defined(pointer_type($e))) { 835 $e->{PROPERTIES}->{$default} = '1'; 836 } 837 } 838} 839 840sub FindNestedTypes($$) 841{ 842 sub FindNestedTypes($$); 843 my ($l, $t) = @_; 844 845 return unless defined($t->{ELEMENTS}); 846 return if ($t->{TYPE} eq "ENUM"); 847 return if ($t->{TYPE} eq "BITMAP"); 848 849 foreach (@{$t->{ELEMENTS}}) { 850 if (ref($_->{TYPE}) eq "HASH") { 851 push (@$l, $_->{TYPE}) if (defined($_->{TYPE}->{NAME})); 852 FindNestedTypes($l, $_->{TYPE}); 853 } 854 } 855} 856 857sub ParseInterface($) 858{ 859 my $idl = shift; 860 my @types = (); 861 my @consts = (); 862 my @functions = (); 863 my @endpoints; 864 my $opnum = 0; 865 my $version; 866 my $ms_union = 0; 867 $ms_union = 1 if has_property($idl, "ms_union"); 868 869 if (not has_property($idl, "pointer_default")) { 870 # MIDL defaults to "ptr" in DCE compatible mode (/osf) 871 # and "unique" in Microsoft Extensions mode (default) 872 $idl->{PROPERTIES}->{pointer_default} = "unique"; 873 } 874 875 foreach my $d (@{$idl->{DATA}}) { 876 if ($d->{TYPE} eq "FUNCTION") { 877 push (@functions, ParseFunction($idl, $d, \$opnum, $ms_union)); 878 } elsif ($d->{TYPE} eq "CONST") { 879 push (@consts, ParseConst($idl, $d)); 880 } else { 881 push (@types, ParseType($d, $idl->{PROPERTIES}->{pointer_default}, $ms_union)); 882 FindNestedTypes(\@types, $d); 883 } 884 } 885 886 $version = "0.0"; 887 888 if(defined $idl->{PROPERTIES}->{version}) { 889 my @if_version = split(/\./, $idl->{PROPERTIES}->{version}); 890 if ($if_version[0] == $idl->{PROPERTIES}->{version}) { 891 $version = $idl->{PROPERTIES}->{version}; 892 } else { 893 $version = $if_version[1] << 16 | $if_version[0]; 894 } 895 } 896 897 # If no endpoint is set, default to the interface name as a named pipe 898 if (!defined $idl->{PROPERTIES}->{endpoint}) { 899 push @endpoints, "\"ncacn_np:[\\\\pipe\\\\" . $idl->{NAME} . "]\""; 900 } else { 901 @endpoints = split /,/, $idl->{PROPERTIES}->{endpoint}; 902 } 903 904 return { 905 NAME => $idl->{NAME}, 906 UUID => lc(has_property($idl, "uuid")), 907 VERSION => $version, 908 TYPE => "INTERFACE", 909 PROPERTIES => $idl->{PROPERTIES}, 910 FUNCTIONS => \@functions, 911 CONSTS => \@consts, 912 TYPES => \@types, 913 ENDPOINTS => \@endpoints, 914 ORIGINAL => $idl 915 }; 916} 917 918# Convert a IDL tree to a NDR tree 919# Gives a result tree describing all that's necessary for easily generating 920# NDR parsers / generators 921sub Parse($) 922{ 923 my $idl = shift; 924 925 return undef unless (defined($idl)); 926 927 Parse::Pidl::NDR::Validate($idl); 928 929 my @ndr = (); 930 931 foreach (@{$idl}) { 932 ($_->{TYPE} eq "CPP_QUOTE") && push(@ndr, $_); 933 ($_->{TYPE} eq "INTERFACE") && push(@ndr, ParseInterface($_)); 934 ($_->{TYPE} eq "IMPORT") && push(@ndr, $_); 935 } 936 937 return \@ndr; 938} 939 940sub GetNextLevel($$) 941{ 942 my $e = shift; 943 my $fl = shift; 944 945 my $seen = 0; 946 947 foreach my $l (@{$e->{LEVELS}}) { 948 return $l if ($seen); 949 ($seen = 1) if ($l == $fl); 950 } 951 952 return undef; 953} 954 955sub GetPrevLevel($$) 956{ 957 my ($e,$fl) = @_; 958 my $prev = undef; 959 960 foreach my $l (@{$e->{LEVELS}}) { 961 (return $prev) if ($l == $fl); 962 $prev = $l; 963 } 964 965 return undef; 966} 967 968sub ContainsString($) 969{ 970 my ($e) = @_; 971 972 if (property_matches($e, "flag", ".*STR_NULLTERM.*")) { 973 return 1; 974 } 975 if (exists($e->{LEVELS}) and $e->{LEVELS}->[0]->{TYPE} eq "ARRAY" and 976 ($e->{LEVELS}->[0]->{IS_FIXED} or $e->{LEVELS}->[0]->{IS_INLINE}) and 977 has_property($e, "charset")) 978 { 979 return 1; 980 } 981 982 foreach my $l (@{$e->{LEVELS}}) { 983 return 1 if ($l->{TYPE} eq "ARRAY" and $l->{IS_ZERO_TERMINATED}); 984 } 985 if (property_matches($e, "charset", ".*DOS.*")) { 986 return 1; 987 } 988 989 return 0; 990} 991 992sub ContainsDeferred($$) 993{ 994 my ($e,$l) = @_; 995 996 return 1 if ($l->{CONTAINS_DEFERRED}); 997 998 while ($l = GetNextLevel($e,$l)) 999 { 1000 return 1 if ($l->{IS_DEFERRED}); 1001 return 1 if ($l->{CONTAINS_DEFERRED}); 1002 } 1003 1004 return 0; 1005} 1006 1007sub ContainsPipe($$) 1008{ 1009 my ($e,$l) = @_; 1010 1011 return 1 if ($l->{TYPE} eq "PIPE"); 1012 1013 while ($l = GetNextLevel($e,$l)) 1014 { 1015 return 1 if ($l->{TYPE} eq "PIPE"); 1016 } 1017 1018 return 0; 1019} 1020 1021sub el_name($) 1022{ 1023 my $e = shift; 1024 my $name = "<ANONYMOUS>"; 1025 1026 $name = $e->{NAME} if defined($e->{NAME}); 1027 1028 if (defined($e->{PARENT}) and defined($e->{PARENT}->{NAME})) { 1029 return "$e->{PARENT}->{NAME}.$name"; 1030 } 1031 1032 if (defined($e->{PARENT}) and 1033 defined($e->{PARENT}->{PARENT}) and 1034 defined($e->{PARENT}->{PARENT}->{NAME})) { 1035 return "$e->{PARENT}->{PARENT}->{NAME}.$name"; 1036 } 1037 1038 return $name; 1039} 1040 1041################################### 1042# find a sibling var in a structure 1043sub find_sibling($$) 1044{ 1045 my($e,$name) = @_; 1046 my($fn) = $e->{PARENT}; 1047 1048 if ($name =~ /\*(.*)/) { 1049 $name = $1; 1050 } 1051 1052 for my $e2 (@{$fn->{ELEMENTS}}) { 1053 return $e2 if ($e2->{NAME} eq $name); 1054 } 1055 1056 return undef; 1057} 1058 1059my %property_list = ( 1060 # interface 1061 "helpstring" => ["INTERFACE", "FUNCTION"], 1062 "version" => ["INTERFACE"], 1063 "uuid" => ["INTERFACE"], 1064 "endpoint" => ["INTERFACE"], 1065 "pointer_default" => ["INTERFACE"], 1066 "helper" => ["INTERFACE"], 1067 "pyhelper" => ["INTERFACE"], 1068 "authservice" => ["INTERFACE"], 1069 "restricted" => ["INTERFACE"], 1070 "no_srv_register" => ["INTERFACE"], 1071 1072 # dcom 1073 "object" => ["INTERFACE"], 1074 "local" => ["INTERFACE", "FUNCTION"], 1075 "iid_is" => ["ELEMENT"], 1076 "call_as" => ["FUNCTION"], 1077 "idempotent" => ["FUNCTION"], 1078 1079 # function 1080 "noopnum" => ["FUNCTION"], 1081 "in" => ["ELEMENT"], 1082 "out" => ["ELEMENT"], 1083 1084 # pointer 1085 "ref" => ["ELEMENT", "TYPEDEF"], 1086 "ptr" => ["ELEMENT", "TYPEDEF"], 1087 "unique" => ["ELEMENT", "TYPEDEF"], 1088 "ignore" => ["ELEMENT"], 1089 "relative" => ["ELEMENT", "TYPEDEF"], 1090 "relative_short" => ["ELEMENT", "TYPEDEF"], 1091 "null_is_ffffffff" => ["ELEMENT"], 1092 "relative_base" => ["TYPEDEF", "STRUCT", "UNION"], 1093 1094 "gensize" => ["TYPEDEF", "STRUCT", "UNION"], 1095 "value" => ["ELEMENT"], 1096 "flag" => ["ELEMENT", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP", "PIPE"], 1097 1098 # generic 1099 "public" => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP", "PIPE"], 1100 "nopush" => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP", "PIPE"], 1101 "nopull" => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP", "PIPE"], 1102 "nosize" => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP"], 1103 "noprint" => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP", "ELEMENT", "PIPE"], 1104 "nopython" => ["FUNCTION", "TYPEDEF", "STRUCT", "UNION", "ENUM", "BITMAP"], 1105 "todo" => ["FUNCTION"], 1106 "skip" => ["ELEMENT"], 1107 "skip_noinit" => ["ELEMENT"], 1108 1109 # union 1110 "switch_is" => ["ELEMENT"], 1111 "switch_type" => ["ELEMENT", "UNION"], 1112 "nodiscriminant" => ["UNION"], 1113 "ms_union" => ["INTERFACE", "UNION"], 1114 "case" => ["ELEMENT"], 1115 "default" => ["ELEMENT"], 1116 1117 "represent_as" => ["ELEMENT"], 1118 "transmit_as" => ["ELEMENT"], 1119 1120 # subcontext 1121 "subcontext" => ["ELEMENT"], 1122 "subcontext_size" => ["ELEMENT"], 1123 "compression" => ["ELEMENT"], 1124 1125 # enum 1126 "enum8bit" => ["ENUM"], 1127 "enum16bit" => ["ENUM"], 1128 "v1_enum" => ["ENUM"], 1129 1130 # bitmap 1131 "bitmap8bit" => ["BITMAP"], 1132 "bitmap16bit" => ["BITMAP"], 1133 "bitmap32bit" => ["BITMAP"], 1134 "bitmap64bit" => ["BITMAP"], 1135 1136 # array 1137 "range" => ["ELEMENT", "PIPE"], 1138 "size_is" => ["ELEMENT"], 1139 "string" => ["ELEMENT"], 1140 "noheader" => ["ELEMENT"], 1141 "charset" => ["ELEMENT"], 1142 "length_is" => ["ELEMENT"], 1143 "to_null" => ["ELEMENT"], 1144); 1145 1146##################################################################### 1147# check for unknown properties 1148sub ValidProperties($$) 1149{ 1150 my ($e,$t) = @_; 1151 1152 return unless defined $e->{PROPERTIES}; 1153 1154 foreach my $key (keys %{$e->{PROPERTIES}}) { 1155 warning($e, el_name($e) . ": unknown property '$key'") 1156 unless defined($property_list{$key}); 1157 1158 fatal($e, el_name($e) . ": property '$key' not allowed on '$t'") 1159 unless grep(/^$t$/, @{$property_list{$key}}); 1160 } 1161} 1162 1163sub mapToScalar($) 1164{ 1165 sub mapToScalar($); 1166 my $t = shift; 1167 return $t->{NAME} if (ref($t) eq "HASH" and $t->{TYPE} eq "SCALAR"); 1168 my $ti = getType($t); 1169 1170 if (not defined ($ti)) { 1171 return undef; 1172 } elsif ($ti->{TYPE} eq "TYPEDEF") { 1173 return mapToScalar($ti->{DATA}); 1174 } elsif ($ti->{TYPE} eq "ENUM") { 1175 return Parse::Pidl::Typelist::enum_type_fn($ti); 1176 } elsif ($ti->{TYPE} eq "BITMAP") { 1177 return Parse::Pidl::Typelist::bitmap_type_fn($ti); 1178 } 1179 1180 return undef; 1181} 1182 1183##################################################################### 1184# validate an element 1185sub ValidElement($) 1186{ 1187 my $e = shift; 1188 1189 ValidProperties($e,"ELEMENT"); 1190 1191 # Check whether switches are used correctly. 1192 if (my $switch = has_property($e, "switch_is")) { 1193 my $e2 = find_sibling($e, $switch); 1194 my $type = getType($e->{TYPE}); 1195 1196 if (defined($type) and $type->{DATA}->{TYPE} ne "UNION") { 1197 fatal($e, el_name($e) . ": switch_is() used on non-union type $e->{TYPE} which is a $type->{DATA}->{TYPE}"); 1198 } 1199 1200 if (not has_property($type->{DATA}, "nodiscriminant") and defined($e2)) { 1201 my $discriminator_type = has_property($type->{DATA}, "switch_type"); 1202 $discriminator_type = "uint32" unless defined ($discriminator_type); 1203 1204 my $t1 = mapScalarType(mapToScalar($discriminator_type)); 1205 1206 if (not defined($t1)) { 1207 fatal($e, el_name($e) . ": unable to map discriminator type '$discriminator_type' to scalar"); 1208 } 1209 1210 my $t2 = mapScalarType(mapToScalar($e2->{TYPE})); 1211 if (not defined($t2)) { 1212 fatal($e, el_name($e) . ": unable to map variable used for switch_is() to scalar"); 1213 } 1214 1215 if ($t1 ne $t2) { 1216 warning($e, el_name($e) . ": switch_is() is of type $e2->{TYPE} ($t2), while discriminator type for union $type->{NAME} is $discriminator_type ($t1)"); 1217 } 1218 } 1219 } 1220 1221 if (has_property($e, "subcontext") and has_property($e, "represent_as")) { 1222 fatal($e, el_name($e) . " : subcontext() and represent_as() can not be used on the same element"); 1223 } 1224 1225 if (has_property($e, "subcontext") and has_property($e, "transmit_as")) { 1226 fatal($e, el_name($e) . " : subcontext() and transmit_as() can not be used on the same element"); 1227 } 1228 1229 if (has_property($e, "represent_as") and has_property($e, "transmit_as")) { 1230 fatal($e, el_name($e) . " : represent_as() and transmit_as() can not be used on the same element"); 1231 } 1232 1233 if (has_property($e, "represent_as") and has_property($e, "value")) { 1234 fatal($e, el_name($e) . " : represent_as() and value() can not be used on the same element"); 1235 } 1236 1237 if (has_property($e, "subcontext")) { 1238 warning($e, "subcontext() is deprecated. Use represent_as() or transmit_as() instead"); 1239 } 1240 1241 if (defined (has_property($e, "subcontext_size")) and not defined(has_property($e, "subcontext"))) { 1242 fatal($e, el_name($e) . " : subcontext_size() on non-subcontext element"); 1243 } 1244 1245 if (defined (has_property($e, "compression")) and not defined(has_property($e, "subcontext"))) { 1246 fatal($e, el_name($e) . " : compression() on non-subcontext element"); 1247 } 1248 1249 if (!$e->{POINTERS} && ( 1250 has_property($e, "ptr") or 1251 has_property($e, "unique") or 1252 has_property($e, "relative") or 1253 has_property($e, "relative_short") or 1254 has_property($e, "ref"))) { 1255 fatal($e, el_name($e) . " : pointer properties on non-pointer element\n"); 1256 } 1257} 1258 1259##################################################################### 1260# validate an enum 1261sub ValidEnum($) 1262{ 1263 my ($enum) = @_; 1264 1265 ValidProperties($enum, "ENUM"); 1266} 1267 1268##################################################################### 1269# validate a bitmap 1270sub ValidBitmap($) 1271{ 1272 my ($bitmap) = @_; 1273 1274 ValidProperties($bitmap, "BITMAP"); 1275} 1276 1277##################################################################### 1278# validate a struct 1279sub ValidStruct($) 1280{ 1281 my($struct) = shift; 1282 1283 ValidProperties($struct, "STRUCT"); 1284 1285 return unless defined($struct->{ELEMENTS}); 1286 1287 foreach my $e (@{$struct->{ELEMENTS}}) { 1288 $e->{PARENT} = $struct; 1289 ValidElement($e); 1290 } 1291} 1292 1293##################################################################### 1294# parse a union 1295sub ValidUnion($) 1296{ 1297 my($union) = shift; 1298 1299 ValidProperties($union,"UNION"); 1300 1301 if (has_property($union->{PARENT}, "nodiscriminant") and 1302 has_property($union->{PARENT}, "switch_type")) { 1303 fatal($union->{PARENT}, $union->{PARENT}->{NAME} . ": switch_type(" . $union->{PARENT}->{PROPERTIES}->{switch_type} . ") on union without discriminant"); 1304 } 1305 1306 return unless defined($union->{ELEMENTS}); 1307 1308 foreach my $e (@{$union->{ELEMENTS}}) { 1309 $e->{PARENT} = $union; 1310 1311 if (defined($e->{PROPERTIES}->{default}) and 1312 defined($e->{PROPERTIES}->{case})) { 1313 fatal($e, "Union member $e->{NAME} can not have both default and case properties!"); 1314 } 1315 1316 unless (defined ($e->{PROPERTIES}->{default}) or 1317 defined ($e->{PROPERTIES}->{case})) { 1318 fatal($e, "Union member $e->{NAME} must have default or case property"); 1319 } 1320 1321 if (has_property($e, "ref")) { 1322 fatal($e, el_name($e) . ": embedded ref pointers are not supported yet\n"); 1323 } 1324 1325 1326 ValidElement($e); 1327 } 1328} 1329 1330##################################################################### 1331# validate a pipe 1332sub ValidPipe($) 1333{ 1334 my ($pipe) = @_; 1335 my $struct = $pipe->{DATA}; 1336 1337 ValidProperties($pipe, "PIPE"); 1338 1339 $struct->{PARENT} = $pipe; 1340 1341 $struct->{FILE} = $pipe->{FILE} unless defined($struct->{FILE}); 1342 $struct->{LINE} = $pipe->{LINE} unless defined($struct->{LINE}); 1343 1344 ValidType($struct); 1345} 1346 1347##################################################################### 1348# parse a typedef 1349sub ValidTypedef($) 1350{ 1351 my($typedef) = shift; 1352 my $data = $typedef->{DATA}; 1353 1354 ValidProperties($typedef, "TYPEDEF"); 1355 1356 return unless (ref($data) eq "HASH"); 1357 1358 $data->{PARENT} = $typedef; 1359 1360 $data->{FILE} = $typedef->{FILE} unless defined($data->{FILE}); 1361 $data->{LINE} = $typedef->{LINE} unless defined($data->{LINE}); 1362 1363 ValidType($data); 1364} 1365 1366##################################################################### 1367# validate a function 1368sub ValidFunction($) 1369{ 1370 my($fn) = shift; 1371 1372 ValidProperties($fn,"FUNCTION"); 1373 1374 foreach my $e (@{$fn->{ELEMENTS}}) { 1375 $e->{PARENT} = $fn; 1376 if (has_property($e, "ref") && !$e->{POINTERS}) { 1377 fatal($e, "[ref] variables must be pointers ($fn->{NAME}/$e->{NAME})"); 1378 } 1379 ValidElement($e); 1380 } 1381} 1382 1383##################################################################### 1384# validate a type 1385sub ValidType($) 1386{ 1387 my ($t) = @_; 1388 1389 { 1390 TYPEDEF => \&ValidTypedef, 1391 STRUCT => \&ValidStruct, 1392 UNION => \&ValidUnion, 1393 ENUM => \&ValidEnum, 1394 BITMAP => \&ValidBitmap, 1395 PIPE => \&ValidPipe 1396 }->{$t->{TYPE}}->($t); 1397} 1398 1399##################################################################### 1400# parse the interface definitions 1401sub ValidInterface($) 1402{ 1403 my($interface) = shift; 1404 my($data) = $interface->{DATA}; 1405 1406 if (has_property($interface, "helper")) { 1407 warning($interface, "helper() is pidl-specific and deprecated. Use `include' instead"); 1408 } 1409 1410 ValidProperties($interface,"INTERFACE"); 1411 1412 if (has_property($interface, "pointer_default")) { 1413 if (not grep (/$interface->{PROPERTIES}->{pointer_default}/, 1414 ("ref", "unique", "ptr"))) { 1415 fatal($interface, "Unknown default pointer type `$interface->{PROPERTIES}->{pointer_default}'"); 1416 } 1417 } 1418 1419 if (has_property($interface, "object")) { 1420 if (has_property($interface, "version") && 1421 $interface->{PROPERTIES}->{version} != 0) { 1422 fatal($interface, "Object interfaces must have version 0.0 ($interface->{NAME})"); 1423 } 1424 1425 if (!defined($interface->{BASE}) && 1426 not ($interface->{NAME} eq "IUnknown")) { 1427 fatal($interface, "Object interfaces must all derive from IUnknown ($interface->{NAME})"); 1428 } 1429 } 1430 1431 foreach my $d (@{$data}) { 1432 ($d->{TYPE} eq "FUNCTION") && ValidFunction($d); 1433 ($d->{TYPE} eq "TYPEDEF" or 1434 $d->{TYPE} eq "STRUCT" or 1435 $d->{TYPE} eq "UNION" or 1436 $d->{TYPE} eq "ENUM" or 1437 $d->{TYPE} eq "BITMAP" or 1438 $d->{TYPE} eq "PIPE") && ValidType($d); 1439 } 1440 1441} 1442 1443##################################################################### 1444# Validate an IDL structure 1445sub Validate($) 1446{ 1447 my($idl) = shift; 1448 1449 foreach my $x (@{$idl}) { 1450 ($x->{TYPE} eq "INTERFACE") && 1451 ValidInterface($x); 1452 ($x->{TYPE} eq "IMPORTLIB") && 1453 fatal($x, "importlib() not supported"); 1454 } 1455} 1456 1457sub is_charset_array($$) 1458{ 1459 my ($e,$l) = @_; 1460 1461 return 0 if ($l->{TYPE} ne "ARRAY"); 1462 1463 my $nl = GetNextLevel($e,$l); 1464 1465 return 0 unless ($nl->{TYPE} eq "DATA"); 1466 1467 return has_property($e, "charset"); 1468} 1469 1470 1471 14721; 1473