tools/winapi/winapi.pm

   1 #
   2 # Copyright 1999, 2000, 2001 Patrik Stridvall
   3 #
   4 # This library is free software; you can redistribute it and/or
   5 # modify it under the terms of the GNU Lesser General Public
   6 # License as published by the Free Software Foundation; either
   7 # version 2.1 of the License, or (at your option) any later version.
   8 #
   9 # This library is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 # Lesser General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU Lesser General Public
  15 # License along with this library; if not, write to the Free Software
  16 # Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
  17 #
  18
  19 package winapi;
  20
  21 use strict;
  22
  23 use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
  24 require Exporter;
  25
  26 @ISA = qw(Exporter);
  27 @EXPORT = qw();
  28 @EXPORT_OK = qw($win16api $win32api @winapis);
  29
  30 use vars qw($win16api $win32api @winapis);
  31
  32 use config qw($current_dir $wine_dir $winapi_dir);
  33 use options qw($options);
  34 use output qw($output);
  35
  36 use vars qw($modules);
  37
  38 sub found_shared_internal_function($$);
  39 sub function_external_calling_convention_in_module($$$);
  40 sub function_internal_module($$);
  41 sub is_function_stub_in_module($$$);
  42 sub new($$$);
  43 sub parse_api_file($$);
  44 sub parse_spec_file($$);
  45
  46 sub import(@) {
  47     $Exporter::ExportLevel++;
  48     Exporter::import(@_);
  49     $Exporter::ExportLevel--;
  50
  51     if (defined($modules) && defined($win16api) && defined($win32api)) {
  52         return;
  53     }
  54
  55     require modules;
  56     import modules qw($modules);
  57
  58     my @spec_files16 = $modules->allowed_spec_files16;
  59     $win16api = 'winapi'->new("win16", \@spec_files16);
  60
  61     my @spec_files32 = $modules->allowed_spec_files32;
  62     $win32api = 'winapi'->new("win32", \@spec_files32);
  63
  64     @winapis = ($win16api, $win32api);
  65
  66     for my $internal_name ($win32api->all_internal_functions) {
  67         my $module16 = $win16api->function_internal_module($internal_name);
  68         my $module32 = $win16api->function_internal_module($internal_name);
  69         if(defined($module16) &&
  70            !$win16api->is_function_stub_in_module($module16, $internal_name) &&
  71            !$win32api->is_function_stub_in_module($module32, $internal_name))
  72         {
  73             $win16api->found_shared_internal_function($internal_name);
  74             $win32api->found_shared_internal_function($internal_name);
  75         }
  76     }
  77 }
  78
  79
  80 sub new($$$) {
  81     my $proto = shift;
  82     my $class = ref($proto) || $proto;
  83     my $self  = {};
  84     bless ($self, $class);
  85
  86     my $name = \${$self->{NAME}};
  87     my $function_forward = \%{$self->{FUNCTION_FORWARD}};
  88     my $function_internal_name = \%{$self->{FUNCTION_INTERNAL_NAME}};
  89     my $function_module = \%{$self->{FUNCTION_MODULE}};
  90
  91     $$name = shift;
  92     my $refspec_files = shift;
  93
  94     foreach my $file (@$refspec_files) {
  95         $self->parse_spec_file("$wine_dir/$file");
  96     }
  97
  98     $self->parse_api_file("$$name.api");
  99
 100     foreach my $module (sort(keys(%$function_forward))) {
 101         foreach my $external_name (sort(keys(%{$$function_forward{$module}}))) {
 102             (my $forward_module, my $forward_external_name) = @{$$function_forward{$module}{$external_name}};
 103             my $forward_internal_name = $$function_internal_name{$forward_external_name};
 104             if(defined($forward_internal_name)) {
 105                 $$function_module{$forward_internal_name} .= " & $module";
 106             }
 107         }
 108     }
 109
 110     return $self;
 111 }
 112
 113 sub win16api() {
 114     return $win16api;
 115 }
 116
 117 sub win32api() {
 118     return $win32api;
 119 }
 120
 121 sub parse_api_file($$) {
 122     my $self = shift;
 123
 124     my $allowed_kind = \%{$self->{ALLOWED_KIND}};
 125     my $allowed_modules = \%{$self->{ALLOWED_MODULES}};
 126     my $allowed_modules_limited = \%{$self->{ALLOWED_MODULES_LIMITED}};
 127     my $allowed_modules_unlimited = \%{$self->{ALLOWED_MODULES_UNLIMITED}};
 128     my $translate_argument = \%{$self->{TRANSLATE_ARGUMENT}};
 129     my $type_format = \%{$self->{TYPE_FORMAT}};
 130
 131     my $file = shift;
 132
 133     my $module;
 134     my $kind;
 135     my $format;
 136     my $forbidden = 0;
 137
 138     $output->lazy_progress("$file");
 139
 140     open(IN, "< $winapi_dir/$file") || die "$winapi_dir/$file: $!\n";
 141     $/ = "\n";
 142     my $linenum=0;
 143     while(<IN>) {
 144         $linenum++;
 145         s/^\s*?(.*?)\s*$/$1/; # remove whitespace at begin and end of line
 146         s/^(.*?)\s*#.*$/$1/;  # remove comments
 147         /^$/ && next;         # skip empty lines
 148
 149         if(/^%%(\S+)$/) {
 150             $module = $1;
 151             $module =~ s/\.dll$//; # FIXME: Kludge
 152         } elsif(!$modules->is_allowed_module($module)) {
 153             # Nothing
 154         } elsif(s/^%(\S+)\s*//) {
 155             $kind = $1;
 156             $format = undef;
 157             $forbidden = 0;
 158
 159             $$allowed_kind{$kind} = 1;
 160             if(/^--forbidden/) {
 161                 $forbidden = 1;
 162             } elsif(/^--format=(\".*?\"|\S*)/) {
 163                 $format = $1;
 164                 $format =~ s/^\"(.*?)\"$/$1/;
 165             }
 166
 167             if(!defined($format)) {
 168                 if($kind eq "long") {
 169                     $format  = "%d|%u|%x|%X|";
 170                     $format .= "%hd|%hu|%hx|%hX|";
 171                     $format .= "%ld|%lu|%lx|%lX|";
 172                     $format .= "%04x|%04X|0x%04x|0x%04X|";
 173                     $format .= "%08x|%08X|0x%08x|0x%08X|";
 174                     $format .= "%08lx|%08lX|0x%08lx|0x%08lX";
 175                 } elsif($kind eq "longlong") {
 176                     $format = "%lld";
 177                 } elsif($kind eq "ptr") {
 178                     $format = "%p";
 179                 } elsif($kind eq "segptr") {
 180                     $format = "%p";
 181                 } elsif($kind eq "str") {
 182                     $format = "%p|%s";
 183                 } elsif($kind eq "wstr") {
 184                     $format = "%p|%s";
 185                 } elsif($kind eq "word") {
 186                     $format  = "%d|%u|%x|%X|";
 187                     $format .= "%hd|%hu|%hx|%hX|";
 188                     $format .= "%04x|%04X|0x%04x|0x%04X";
 189                 } else {
 190                     $format = "<unknown>";
 191                 }
 192             }
 193         } elsif(defined($kind)) {
 194             my $type = $_;
 195             if ($type =~ /\blong\b/)
 196             {
 197                 $output->write("$file:$linenum: type ($type) is not Win64 compatible\n");
 198             }
 199             if(!$forbidden) {
 200                 if(defined($module)) {
 201                     if($$allowed_modules_unlimited{$type}) {
 202                         $output->write("$file:$linenum: type ($type) already specified as an unlimited type\n");
 203                     } elsif(!$$allowed_modules{$type}{$module}) {
 204                         $$allowed_modules{$type}{$module} = 1;
 205                         $$allowed_modules_limited{$type} = 1;
 206                     } else {
 207                         $output->write("$file:$linenum: type ($type) already specified\n");
 208                     }
 209                 } else {
 210                     $$allowed_modules_unlimited{$type} = 1;
 211                 }
 212             } else {
 213                 $$allowed_modules_limited{$type} = 1;
 214             }
 215             if(defined($$translate_argument{$type}) && $$translate_argument{$type} ne $kind) {
 216                 $output->write("$file:$linenum: type ($type) respecified as different kind ($kind != $$translate_argument{$type})\n");
 217             } else {
 218                 $$translate_argument{$type} = $kind;
 219             }
 220
 221             $$type_format{$module}{$type} = $format;
 222         } else {
 223             $output->write("$file:$linenum: file must begin with %<type> statement\n");
 224             exit 1;
 225         }
 226     }
 227     close(IN);
 228 }
 229
 230 sub parse_spec_file($$) {
 231     my $self = shift;
 232
 233     my $function_internal_arguments = \%{$self->{FUNCTION_INTERNAL_ARGUMENTS}};
 234     my $function_external_arguments = \%{$self->{FUNCTION_EXTERNAL_ARGUMENTS}};
 235     my $function_internal_ordinal = \%{$self->{FUNCTION_INTERNAL_ORDINAL}};
 236     my $function_external_ordinal = \%{$self->{FUNCTION_EXTERNAL_ORDINAL}};
 237     my $function_internal_calling_convention = \%{$self->{FUNCTION_INTERNAL_CALLING_CONVENTION}};
 238     my $function_external_calling_convention = \%{$self->{FUNCTION_EXTERNAL_CALLING_CONVENTION}};
 239     my $function_internal_name = \%{$self->{FUNCTION_INTERNAL_NAME}};
 240     my $function_external_name = \%{$self->{FUNCTION_EXTERNAL_NAME}};
 241     my $function_forward = \%{$self->{FUNCTION_FORWARD}};
 242     my $function_internal_module = \%{$self->{FUNCTION_INTERNAL_MODULE}};
 243     my $function_external_module = \%{$self->{FUNCTION_EXTERNAL_MODULE}};
 244     my $function_wine_extension = \%{$self->{FUNCTION_WINE_EXTENSION}};
 245     my $modules = \%{$self->{MODULES}};
 246     my $module_files = \%{$self->{MODULE_FILES}};
 247     my $module_external_calling_convention = \%{$self->{MODULE_EXTERNAL_CALLING_CONVENTION}};
 248
 249     my $file = shift;
 250     $file =~ s%^\./%%;
 251
 252     my %ordinals;
 253     my $module;
 254     my $wine_extension = 0;
 255
 256     $output->lazy_progress("$file");
 257
 258     $module = $file;
 259     $module =~ s/^.*?([^\/]*)\.spec$/$1/;
 260
 261     open(IN, "< $file") || die "$file: $!\n";
 262     $/ = "\n";
 263     my $header = 1;
 264     my $lookahead = 0;
 265     while($lookahead || defined($_ = <IN>)) {
 266         $lookahead = 0;
 267         s/^\s*(.*?)\s*$/$1/;
 268         if(s/^(.*?)\s*\#\s*(.*)\s*$/$1/) {
 269             my $comment = $2;
 270             if ($comment =~ /^Wine/i) { # FIXME: Kludge
 271                 $wine_extension = 1;
 272             }
 273         }
 274         /^$/ && next;
 275
 276         if($header)  {
 277             if(/^\d+|@/) { $header = 0; $lookahead = 1; }
 278             next;
 279         }
 280
 281         my $ordinal;
 282         my $ARCHES="alpha|arm|i386|powerpc|sparc|win32|win64|x86_64";
 283         if(/^(\d+|@)\s+
 284            (cdecl|pascal|stdcall|varargs|thiscall)\s+
 285            ((?:(?:-arch=(?:$ARCHES)(?:,(?:$ARCHES))*|-noname|-norelay|-ordinal|-i386|-ret16|-ret64|-register|-interrupt|-private)\s+)*)(\S+)\s*\(\s*(.*?)\s*\)\s*(\S*)$/x)
 286         {
 287             my $calling_convention = $2;
 288             my $flags = $3;
 289             my $external_name = $4;
 290             my $arguments = $5;
 291             my $internal_name = $6;
 292
 293             $ordinal = $1;
 294
 295             $flags =~ s/\s+/ /g;
 296
 297             if (!$internal_name)
 298             {
 299                 $internal_name = ($flags =~ /-register/ ? "__regs_" : "") . $external_name;
 300             }
 301
 302             if($flags =~ /-noname/) {
 303                 # $external_name = "@";
 304             }
 305
 306             if($flags =~ /(?:-register|-interrupt)/) {
 307                 if($arguments) { $arguments .= " "; }
 308                 $arguments .= "ptr";
 309                 $calling_convention .= " -register";
 310             }
 311             if($flags =~ /(?:-i386)/) {
 312                 $calling_convention .= " -i386";
 313             }
 314
 315             if ($internal_name =~ /^(.*?)\.(.*?)$/) {
 316                 my $forward_module = lc($1);
 317                 my $forward_name = $2;
 318                 $calling_convention = "forward";
 319                 $$function_forward{$module}{$external_name} = [$forward_module, $forward_name];
 320             }
 321
 322             if($external_name ne "@") {
 323                 $$module_external_calling_convention{$module}{$external_name} = $calling_convention;
 324             } else {
 325                 $$module_external_calling_convention{$module}{"\@$ordinal"} = $calling_convention;
 326             }
 327             if(!$$function_internal_name{$external_name}) {
 328                 $$function_internal_name{$external_name} = $internal_name;
 329             } else {
 330                 $$function_internal_name{$external_name} .= " & $internal_name";
 331             }
 332             if(!$$function_external_name{$internal_name}) {
 333                 $$function_external_name{$internal_name} = $external_name;
 334             } else {
 335                 $$function_external_name{$internal_name} .= " & $external_name";
 336             }
 337             $$function_internal_arguments{$internal_name} = $arguments;
 338             $$function_external_arguments{$external_name} = $arguments;
 339             if(!$$function_internal_ordinal{$internal_name}) {
 340                 $$function_internal_ordinal{$internal_name} = $ordinal;
 341             } else {
 342                 $$function_internal_ordinal{$internal_name} .= " & $ordinal";
 343             }
 344             if(!$$function_external_ordinal{$external_name}) {
 345                 $$function_external_ordinal{$external_name} = $ordinal;
 346             } else {
 347                 $$function_external_ordinal{$external_name} .= " & $ordinal";
 348             }
 349             $$function_internal_calling_convention{$internal_name} = $calling_convention;
 350             $$function_external_calling_convention{$external_name} = $calling_convention;
 351             if(!$$function_internal_module{$internal_name}) {
 352                 $$function_internal_module{$internal_name} = "$module";
 353             } else {
 354                 $$function_internal_module{$internal_name} .= " & $module";
 355             }
 356             if(!$$function_external_module{$external_name}) {
 357                 $$function_external_module{$external_name} = "$module";
 358             } else {
 359                 $$function_external_module{$external_name} .= " & $module";
 360             }
 361             $$function_wine_extension{$module}{$external_name} = $wine_extension;
 362
 363             if(0 && $options->spec_mismatch) {
 364                 if($external_name eq "@") {
 365                     if($internal_name !~ /^\U$module\E_$ordinal$/) {
 366                         $output->write("$file: $external_name: the internal name ($internal_name) mismatch\n");
 367                     }
 368                 } else {
 369                     my $name = $external_name;
 370
 371                     my $name1 = $name;
 372                     $name1 =~ s/^Zw/Nt/;
 373
 374                     my $name2 = $name;
 375                     $name2 =~ s/^(?:_|Rtl|k32|K32)//;
 376
 377                     my $name3 = $name;
 378                     $name3 =~ s/^INT_Int[0-9a-f]{2}Handler$/BUILTIN_DefaultIntHandler/;
 379
 380                     my $name4 = $name;
 381                     $name4 =~ s/^(VxDCall)\d$/$1/;
 382
 383                     # FIXME: This special case is because of a very ugly kludge that should be fixed IMHO
 384                     my $name5 = $name;
 385                     $name5 =~ s/^(.*?16)_(.*?)$/$1_fn$2/;
 386
 387                     if(uc($internal_name) ne uc($external_name) &&
 388                        $internal_name !~ /(\Q$name\E|\Q$name1\E|\Q$name2\E|\Q$name3\E|\Q$name4\E|\Q$name5\E)/)
 389                     {
 390                         $output->write("$file: $external_name: internal name ($internal_name) mismatch\n");
 391                     }
 392                 }
 393             }
 394         } elsif(/^(\d+|@)\s+stub(?:\s+(-arch=(?:$ARCHES)(?:,(?:$ARCHES))*|-noname|-norelay|-ordinal|-i386|-ret16|-ret64|-private))*\s+(\S+?)\s*(\(\s*(.*?)\s*\))?$/) {
 395             $ordinal = $1;
 396
 397             my $flags = $2;
 398             my $external_name = $3;
 399
 400             $flags = "" if !defined($flags);
 401
 402             if($flags =~ /-noname/) {
 403                 # $external_name = "@";
 404             }
 405
 406             my $internal_name = $external_name;
 407
 408             if ($external_name ne "@") {
 409                 $$module_external_calling_convention{$module}{$external_name} = "stub";
 410             } else {
 411                 $$module_external_calling_convention{$module}{"\@$ordinal"} = "stub";
 412             }
 413             if(!$$function_internal_name{$external_name}) {
 414                 $$function_internal_name{$external_name} = $internal_name;
 415             } else {
 416                 $$function_internal_name{$external_name} .= " & $internal_name";
 417             }
 418             if(!$$function_external_name{$internal_name}) {
 419                 $$function_external_name{$internal_name} = $external_name;
 420             } else {
 421                 $$function_external_name{$internal_name} .= " & $external_name";
 422             }
 423             if(!$$function_internal_ordinal{$internal_name}) {
 424                 $$function_internal_ordinal{$internal_name} = $ordinal;
 425             } else {
 426                 $$function_internal_ordinal{$internal_name} .= " & $ordinal";
 427             }
 428             if(!$$function_external_ordinal{$external_name}) {
 429                 $$function_external_ordinal{$external_name} = $ordinal;
 430             } else {
 431                 $$function_external_ordinal{$external_name} .= " & $ordinal";
 432             }
 433             if(!$$function_internal_module{$internal_name}) {
 434                 $$function_internal_module{$internal_name} = "$module";
 435             } else { # if($$function_internal_module{$internal_name} !~ /$module/) {
 436                 $$function_internal_module{$internal_name} .= " & $module";
 437             }
 438             if(!$$function_external_module{$external_name}) {
 439                 $$function_external_module{$external_name} = "$module";
 440             } else { # if($$function_external_module{$external_name} !~ /$module/) {
 441                 $$function_external_module{$external_name} .= " & $module";
 442             }
 443         } elsif(/^(\d+|@)\s+extern(?:\s+(?:-arch=(?:$ARCHES)(?:,(?:$ARCHES))*|-noname|-norelay|-ordinal|-i386|-ret16|-ret64))*\s+(\S+)\s*(\S*)$/) {
 444             $ordinal = $1;
 445
 446             my $external_name = $2;
 447             my $internal_name = $3;
 448
 449             $internal_name = $external_name if !$internal_name;
 450
 451             if ($external_name ne "@") {
 452                 $$module_external_calling_convention{$module}{$external_name} = "extern";
 453             } else {
 454                 $$module_external_calling_convention{$module}{"\@$ordinal"} = "extern";
 455             }
 456         } elsif(/^(?:\d+|@)\s+(?:equate|variable)/) {
 457             # ignore
 458         } else {
 459             my $next_line = <IN>;
 460             if(!defined($next_line) || $next_line =~ /^\s*\d|@/) {
 461                 die "$file: $.: syntax error: '$_'\n";
 462             } else {
 463                 $_ .= $next_line;
 464                 $lookahead = 1;
 465             }
 466         }
 467
 468         if(defined($ordinal)) {
 469             if($ordinal ne "@" && $ordinals{$ordinal}) {
 470                 $output->write("$file: ordinal redefined: $_\n");
 471             }
 472             $ordinals{$ordinal}++;
 473         }
 474     }
 475     close(IN);
 476
 477     $$modules{$module}++;
 478
 479     $$module_files{$module} = $file;
 480 }
 481
 482 sub name($) {
 483     my $self = shift;
 484     my $name = \${$self->{NAME}};
 485
 486     return $$name;
 487 }
 488
 489 sub is_allowed_kind($$) {
 490     my $self = shift;
 491     my $allowed_kind = \%{$self->{ALLOWED_KIND}};
 492
 493     my $kind = shift;
 494     if(defined($kind)) {
 495         return $$allowed_kind{$kind};
 496     } else {
 497         return 0;
 498     }
 499
 500 }
 501
 502 sub allow_kind($$) {
 503     my $self = shift;
 504     my $allowed_kind = \%{$self->{ALLOWED_KIND}};
 505
 506     my $kind = shift;
 507
 508     $$allowed_kind{$kind}++;
 509 }
 510
 511 sub is_limited_type($$) {
 512     my $self = shift;
 513     my $allowed_modules_limited = \%{$self->{ALLOWED_MODULES_LIMITED}};
 514
 515     my $type = shift;
 516
 517     return $$allowed_modules_limited{$type};
 518 }
 519
 520 sub is_allowed_type_in_module($$) {
 521     my $self = shift;
 522     my $allowed_modules = \%{$self->{ALLOWED_MODULES}};
 523     my $allowed_modules_limited = \%{$self->{ALLOWED_MODULES_LIMITED}};
 524
 525     my $type = shift;
 526     my @modules = split(/ \& /, shift);
 527
 528     if(!$$allowed_modules_limited{$type}) { return 1; }
 529
 530     foreach my $module (@modules) {
 531         if($$allowed_modules{$type}{$module}) { return 1; }
 532     }
 533
 534     return 0;
 535 }
 536
 537 sub allow_type_in_module($$) {
 538     my $self = shift;
 539     my $allowed_modules = \%{$self->{ALLOWED_MODULES}};
 540
 541     my $type = shift;
 542     my @modules = split(/ \& /, shift);
 543
 544     foreach my $module (@modules) {
 545         $$allowed_modules{$type}{$module}++;
 546     }
 547 }
 548
 549 sub type_used_in_module($$) {
 550     my $self = shift;
 551     my $used_modules = \%{$self->{USED_MODULES}};
 552
 553     my $type = shift;
 554     my @modules = split(/ \& /, shift);
 555
 556     foreach my $module (@modules) {
 557         $$used_modules{$type}{$module} = 1;
 558     }
 559
 560     return ();
 561 }
 562
 563 sub types_not_used($) {
 564     my $self = shift;
 565     my $used_modules = \%{$self->{USED_MODULES}};
 566     my $allowed_modules = \%{$self->{ALLOWED_MODULES}};
 567
 568     my $not_used;
 569     foreach my $type (sort(keys(%$allowed_modules))) {
 570         foreach my $module (sort(keys(%{$$allowed_modules{$type}}))) {
 571             if(!$$used_modules{$type}{$module}) {
 572                 $$not_used{$module}{$type} = 1;
 573             }
 574         }
 575     }
 576     return $not_used;
 577 }
 578
 579 sub types_unlimited_used_in_modules($) {
 580     my $self = shift;
 581
 582     my $used_modules = \%{$self->{USED_MODULES}};
 583     my $allowed_modules = \%{$self->{ALLOWED_MODULES}};
 584     my $allowed_modules_unlimited = \%{$self->{ALLOWED_MODULES_UNLIMITED}};
 585
 586     my $used_types;
 587     foreach my $type (sort(keys(%$allowed_modules_unlimited))) {
 588         my $count = 0;
 589         my @modules = ();
 590         foreach my $module (sort(keys(%{$$used_modules{$type}}))) {
 591             $count++;
 592             push @modules, $module;
 593         }
 594         if($count) {
 595             foreach my $module (@modules) {
 596               $$used_types{$type}{$module} = 1;
 597             }
 598         }
 599     }
 600     return $used_types;
 601 }
 602
 603 sub translate_argument($$) {
 604     my $self = shift;
 605     my $translate_argument = \%{$self->{TRANSLATE_ARGUMENT}};
 606
 607     my $type = shift;
 608
 609     return $$translate_argument{$type};
 610 }
 611
 612 sub declare_argument($$$) {
 613     my $self = shift;
 614     my $translate_argument = \%{$self->{TRANSLATE_ARGUMENT}};
 615
 616     my $type = shift;
 617     my $kind = shift;
 618
 619     $$translate_argument{$type} = $kind;
 620 }
 621
 622 sub all_declared_types($) {
 623     my $self = shift;
 624     my $translate_argument = \%{$self->{TRANSLATE_ARGUMENT}};
 625
 626     return sort(keys(%$translate_argument));
 627 }
 628
 629 sub is_allowed_type_format($$$$) {
 630     my $self = shift;
 631     my $type_format = \%{$self->{TYPE_FORMAT}};
 632
 633     my $module = shift;
 634     my $type = shift;
 635     my $format = shift;
 636
 637     my $formats;
 638
 639     if(defined($module) && defined($type)) {
 640         local $_;
 641         foreach (split(/ & /, $module)) {
 642             if(defined($formats)) {
 643                 $formats .= "|";
 644             } else {
 645                 $formats = "";
 646             }
 647             if(defined($$type_format{$_}{$type})) {
 648                 $formats .= $$type_format{$_}{$type};
 649             }
 650         }
 651     }
 652
 653     if(defined($formats)) {
 654         local $_;
 655         foreach (split(/\|/, $formats)) {
 656             if($_ eq $format) {
 657                 return 1;
 658             }
 659         }
 660     }
 661
 662     return 0;
 663 }
 664
 665 sub all_modules($) {
 666     my $self = shift;
 667     my $modules = \%{$self->{MODULES}};
 668
 669     return sort(keys(%$modules));
 670 }
 671
 672 sub is_module($$) {
 673     my $self = shift;
 674     my $modules = \%{$self->{MODULES}};
 675
 676     my $name = shift;
 677
 678     return $$modules{$name};
 679 }
 680
 681 sub module_file($$) {
 682     my $self = shift;
 683
 684     my $module = shift;
 685
 686     my $module_files = \%{$self->{MODULE_FILES}};
 687
 688     return $$module_files{$module};
 689 }
 690
 691 sub all_internal_functions($) {
 692     my $self = shift;
 693     my $function_internal_calling_convention = \%{$self->{FUNCTION_INTERNAL_CALLING_CONVENTION}};
 694
 695     return sort(keys(%$function_internal_calling_convention));
 696 }
 697
 698 sub all_internal_functions_in_module($$) {
 699     my $self = shift;
 700     my $function_internal_calling_convention = \%{$self->{FUNCTION_INTERNAL_CALLING_CONVENTION}};
 701     my $function_internal_module = \%{$self->{FUNCTION_INTERNAL_MODULE}};
 702
 703     my $module = shift;
 704
 705     my @names;
 706     foreach my $name (keys(%$function_internal_calling_convention)) {
 707         if($$function_internal_module{$name} eq $module) {
 708             push @names, $name;
 709         }
 710     }
 711
 712     return sort(@names);
 713 }
 714
 715 sub all_external_functions($) {
 716     my $self = shift;
 717     my $function_external_name = \%{$self->{FUNCTION_EXTERNAL_NAME}};
 718
 719     return sort(keys(%$function_external_name));
 720 }
 721
 722 sub all_external_functions_in_module($$) {
 723     my $self = shift;
 724     my $function_external_name = \%{$self->{FUNCTION_EXTERNAL_NAME}};
 725     my $function_external_module = \%{$self->{FUNCTION_EXTERNAL_MODULE}};
 726
 727     my $module = shift;
 728
 729     my @names;
 730     foreach my $name (keys(%$function_external_name)) {
 731         if($$function_external_module{$name} eq $module) {
 732             push @names, $name;
 733         }
 734     }
 735
 736     return sort(@names);
 737 }
 738
 739 sub all_functions_in_module($$) {
 740     my $self = shift;
 741     my $module_external_calling_convention = \%{$self->{MODULE_EXTERNAL_CALLING_CONVENTION}};
 742
 743     my $module = shift;
 744
 745     return sort(keys(%{$$module_external_calling_convention{$module}}));
 746 }
 747
 748 sub all_broken_forwards($) {
 749     my $self = shift;
 750     my $function_forward = \%{$self->{FUNCTION_FORWARD}};
 751
 752     my @broken_forwards = ();
 753     foreach my $module (sort(keys(%$function_forward))) {
 754         foreach my $external_name (sort(keys(%{$$function_forward{$module}}))) {
 755             (my $forward_module, my $forward_external_name) = @{$$function_forward{$module}{$external_name}};
 756
 757             my $forward_external_calling_convention =
 758                 $self->function_external_calling_convention_in_module($forward_module, $forward_external_name);
 759
 760             if(!defined($forward_external_calling_convention)) {
 761                 push @broken_forwards, [$module, $external_name, $forward_module, $forward_external_name];
 762             }
 763         }
 764     }
 765     return @broken_forwards;
 766 }
 767
 768
 769 sub function_internal_ordinal($$) {
 770     my $self = shift;
 771     my $function_internal_ordinal = \%{$self->{FUNCTION_INTERNAL_ORDINAL}};
 772
 773     my $name = shift;
 774
 775     return $$function_internal_ordinal{$name};
 776 }
 777
 778 sub function_external_ordinal($$) {
 779     my $self = shift;
 780     my $function_external_ordinal = \%{$self->{FUNCTION_EXTERNAL_ORDINAL}};
 781
 782     my $name = shift;
 783
 784     return $$function_external_ordinal{$name};
 785 }
 786
 787 sub function_internal_calling_convention($$) {
 788     my $self = shift;
 789     my $function_internal_calling_convention = \%{$self->{FUNCTION_INTERNAL_CALLING_CONVENTION}};
 790
 791     my $name = shift;
 792
 793     return $$function_internal_calling_convention{$name};
 794 }
 795
 796 sub function_external_calling_convention($$) {
 797     my $self = shift;
 798     my $function_external_calling_convention = \%{$self->{FUNCTION_EXTERNAL_CALLING_CONVENTION}};
 799
 800     my $name = shift;
 801
 802     return $$function_external_calling_convention{$name};
 803 }
 804
 805 sub function_external_calling_convention_in_module($$$) {
 806     my $self = shift;
 807     my $module_external_calling_convention = \%{$self->{MODULE_EXTERNAL_CALLING_CONVENTION}};
 808
 809     my $module = shift;
 810     my $name = shift;
 811
 812     return $$module_external_calling_convention{$module}{$name};
 813 }
 814
 815 sub function_internal_name($$) {
 816     my $self = shift;
 817     my $function_internal_name = \%{$self->{FUNCTION_INTERNAL_NAME}};
 818
 819     my $name = shift;
 820
 821     return $$function_internal_name{$name};
 822 }
 823
 824 sub function_external_name($$) {
 825     my $self = shift;
 826     my $function_external_name = \%{$self->{FUNCTION_EXTERNAL_NAME}};
 827
 828     my $name = shift;
 829
 830     return $$function_external_name{$name};
 831 }
 832
 833 sub function_forward_final_destination($$$) {
 834     my $self = shift;
 835
 836     my $function_forward = \%{$self->{FUNCTION_FORWARD}};
 837
 838     my $module = shift;
 839     my $name = shift;
 840
 841     my $forward_module = $module;
 842     my $forward_name = $name;
 843     while(defined(my $forward = $$function_forward{$forward_module}{$forward_name})) {
 844         ($forward_module, $forward_name) = @$forward;
 845     }
 846
 847     return ($forward_module, $forward_name);
 848 }
 849
 850 sub is_function($$) {
 851     my $self = shift;
 852     my $function_internal_calling_convention = \%{$self->{FUNCTION_INTERNAL_CALLING_CONVENTION}};
 853
 854     my $name = shift;
 855
 856     return $$function_internal_calling_convention{$name};
 857 }
 858
 859 sub all_shared_internal_functions($$) {
 860     my $self = shift;
 861     my $function_shared = \%{$self->{FUNCTION_SHARED}};
 862
 863     return sort(keys(%$function_shared));
 864 }
 865
 866 sub is_shared_internal_function($$) {
 867     my $self = shift;
 868     my $function_shared = \%{$self->{FUNCTION_SHARED}};
 869
 870     my $name = shift;
 871
 872     return $$function_shared{$name};
 873 }
 874
 875 sub found_shared_internal_function($$) {
 876     my $self = shift;
 877     my $function_shared = \%{$self->{FUNCTION_SHARED}};
 878
 879     my $name = shift;
 880
 881     $$function_shared{$name} = 1;
 882 }
 883
 884 sub function_internal_arguments($$) {
 885     my $self = shift;
 886     my $function_internal_arguments = \%{$self->{FUNCTION_INTERNAL_ARGUMENTS}};
 887
 888     my $name = shift;
 889
 890     return $$function_internal_arguments{$name};
 891 }
 892
 893 sub function_external_arguments($$) {
 894     my $self = shift;
 895     my $function_external_arguments = \%{$self->{FUNCTION_EXTERNAL_ARGUMENTS}};
 896
 897     my $name = shift;
 898
 899     return $$function_external_arguments{$name};
 900 }
 901
 902 sub function_internal_module($$) {
 903     my $self = shift;
 904     my $function_internal_module = \%{$self->{FUNCTION_INTERNAL_MODULE}};
 905
 906     my $name = shift;
 907
 908     return $$function_internal_module{$name};
 909 }
 910
 911 sub function_external_module($$) {
 912     my $self = shift;
 913     my $function_external_module = \%{$self->{FUNCTION_EXTERNAL_MODULE}};
 914
 915     my $name = shift;
 916
 917     return $$function_external_module{$name};
 918 }
 919
 920 sub function_wine_extension($$$) {
 921     my $self = shift;
 922     my $function_wine_extension = \%{$self->{FUNCTION_WINE_EXTENSION}};
 923
 924     my $module = shift;
 925     my $name = shift;
 926
 927     return $$function_wine_extension{$module}{$name};
 928 }
 929
 930 sub is_function_stub($$$) {
 931     my $self = shift;
 932     my $module_external_calling_convention = \%{$self->{MODULE_EXTERNAL_CALLING_CONVENTION}};
 933
 934     my $module = shift;
 935     my $name = shift;
 936
 937     if($$module_external_calling_convention{$module}{$name} eq "stub") {
 938         return 1;
 939     }
 940     return 0;
 941 }
 942
 943 sub is_function_stub_in_module($$$) {
 944     my $self = shift;
 945     my $module_external_calling_convention = \%{$self->{MODULE_EXTERNAL_CALLING_CONVENTION}};
 946
 947     my $module = shift;
 948     my $name = shift;
 949
 950     if(!defined($$module_external_calling_convention{$module}{$name})) {
 951         return 0;
 952     }
 953     return $$module_external_calling_convention{$module}{$name} eq "stub";
 954 }
 955
 956 ########################################################################
 957 # class methods
 958 #
 959
 960 sub _get_all_module_internal_ordinal($$) {
 961     my $winapi = shift;
 962     my $internal_name = shift;
 963
 964     my @entries = ();
 965
 966     my @name = (); {
 967         my $name = $winapi->function_external_name($internal_name);
 968         if(defined($name)) {
 969             @name = split(/ & /, $name);
 970         }
 971     }
 972
 973     my @module = (); {
 974         my $module = $winapi->function_internal_module($internal_name);
 975         if(defined($module)) {
 976             @module = split(/ & /, $module);
 977         }
 978     }
 979
 980     my @ordinal = (); {
 981         my $ordinal = $winapi->function_internal_ordinal($internal_name);
 982         if(defined($ordinal)) {
 983             @ordinal = split(/ & /, $ordinal);
 984         }
 985     }
 986
 987     my $name;
 988     my $module;
 989     my $ordinal;
 990     while(defined($name = shift @name) &&
 991           defined($module = shift @module) &&
 992           defined($ordinal = shift @ordinal))
 993     {
 994         push @entries, [$name, $module, $ordinal];
 995     }
 996
 997     return @entries;
 998 }
 999
1000 sub get_all_module_internal_ordinal16($) {
1001     return _get_all_module_internal_ordinal($win16api, $_[0]);
1002 }
1003
1004 sub get_all_module_internal_ordinal32($) {
1005     return _get_all_module_internal_ordinal($win32api, $_[0]);
1006 }
1007
1008 sub get_all_module_internal_ordinal($) {
1009     my @entries = ();
1010     foreach my $winapi (@winapis) {
1011         push @entries, _get_all_module_internal_ordinal($winapi, $_[0]);
1012     }
1013
1014     return @entries;
1015 }
1016
1017 sub _get_all_module_external_ordinal($$) {
1018     my $winapi = shift;
1019     my $external_name = shift;
1020
1021     my @entries = ();
1022
1023     my @name = (); {
1024         my $name = $winapi->function_internal_name($external_name);
1025         if(defined($name)) {
1026             @name = split(/ & /, $name);
1027         }
1028     }
1029
1030     my @module = (); {
1031         my $module = $winapi->function_external_module($external_name);
1032         if(defined($module)) {
1033             @module = split(/ & /, $module);
1034         }
1035     }
1036
1037     my @ordinal = (); {
1038         my $ordinal = $winapi->function_external_ordinal($external_name);
1039         if(defined($ordinal)) {
1040             @ordinal = split(/ & /, $ordinal);
1041         }
1042     }
1043
1044     my $name;
1045     my $module;
1046     my $ordinal;
1047     while(defined($name = shift @name) &&
1048           defined($module = shift @module) &&
1049           defined($ordinal = shift @ordinal))
1050     {
1051         push @entries, [$name, $module, $ordinal];
1052     }
1053
1054     return @entries;
1055 }
1056
1057 sub get_all_module_external_ordinal16($) {
1058     return _get_all_module_external_ordinal($win16api, $_[0]);
1059 }
1060
1061 sub get_all_module_external_ordinal32($) {
1062     return _get_all_module_external_ordinal($win32api, $_[0]);
1063 }
1064
1065 sub get_all_module_external_ordinal($) {
1066     my @entries = ();
1067     foreach my $winapi (@winapis) {
1068         push @entries, _get_all_module_external_ordinal($winapi, $_[0]);
1069     }
1070
1071     return @entries;
1072 }
1073
1074 1;