Sweden-Number/tools/winapi_check/winapi.pm

676 lines
15 KiB
Perl

package winapi;
use strict;
sub new {
my $proto = shift;
my $class = ref($proto) || $proto;
my $self = {};
bless ($self, $class);
my $options = \${$self->{OPTIONS}};
my $output = \${$self->{OUTPUT}};
my $name = \${$self->{NAME}};
$$options = shift;
$$output = shift;
$$name = shift;
my $path = shift;
my @files = map {
s/^.\/(.*)$/$1/;
$_;
} split(/\n/, `find $path -name \\*.api`);
foreach my $file (@files) {
my $module = $file;
$module =~ s/.*?\/([^\/]*?)\.api$/$1/;
$self->parse_api_file($file,$module);
}
return $self;
}
sub parse_api_file {
my $self = shift;
my $options = \${$self->{OPTIONS}};
my $output = \${$self->{OUTPUT}};
my $allowed_kind = \%{$self->{ALLOWED_KIND}};
my $allowed_modules = \%{$self->{ALLOWED_MODULES}};
my $allowed_modules_limited = \%{$self->{ALLOWED_MODULES_LIMITED}};
my $allowed_modules_unlimited = \%{$self->{ALLOWED_MODULES_UNLIMITED}};
my $translate_argument = \%{$self->{TRANSLATE_ARGUMENT}};
my $type_format = \%{$self->{TYPE_FORMAT}};
my $file = shift;
my $module = shift;
my $kind;
my $format;
my $extension = 0;
my $forbidden = 0;
if($$options->progress) {
$$output->progress("$file");
}
open(IN, "< $file") || die "$file: $!\n";
$/ = "\n";
while(<IN>) {
s/^\s*?(.*?)\s*$/$1/; # remove whitespace at begin and end of line
s/^(.*?)\s*#.*$/$1/; # remove comments
/^$/ && next; # skip empty lines
if(s/^%(\S+)\s*//) {
$kind = $1;
$format = undef;
$forbidden = 0;
$extension = 0;
$$allowed_kind{$kind} = 1;
if(/^--forbidden/) {
$forbidden = 1;
} elsif(/^--extension/) {
$extension = 1;
} elsif(/^--format=(\".*?\"|\S*)/) {
$format = $1;
$format =~ s/^\"(.*?)\"$/$1/;
}
if(!defined($format)) {
if($kind eq "long") {
$format = "%d|%u|%x|%X|";
$format .= "%hd|%hu|%hx|%hX|";
$format .= "%ld|%lu|%lx|%lX|";
$format .= "%04x|%04X|0x%04x|0x%04X|";
$format .= "%08x|%08X|0x%08x|0x%08X|";
$format .= "%08lx|%08lX|0x%08lx|0x%08lX";
} elsif($kind eq "longlong") {
$format = "%lld";
} elsif($kind eq "ptr") {
$format = "%p";
} elsif($kind eq "segptr") {
$format = "%p";
} elsif($kind eq "str") {
$format = "%p|%s";
} elsif($kind eq "wstr") {
$format = "%p|%s";
} elsif($kind eq "word") {
$format = "%d|%u|%x|%X|";
$format .= "%hd|%hu|%hx|%hX|";
$format .= "%04x|%04X|0x%04x|0x%04X";
} else {
$format = "<unknown>";
}
}
} elsif(defined($kind)) {
my $type = $_;
if(!$forbidden) {
if(defined($module)) {
if($$allowed_modules_unlimited{$type}) {
$$output->write("$file: type ($type) already specificed as an unlimited type\n");
} elsif(!$$allowed_modules{$type}{$module}) {
$$allowed_modules{$type}{$module} = 1;
$$allowed_modules_limited{$type} = 1;
} else {
$$output->write("$file: type ($type) already specificed\n");
}
} else {
$$allowed_modules_unlimited{$type} = 1;
}
} else {
$$allowed_modules_limited{$type} = 1;
}
if(defined($$translate_argument{$type}) && $$translate_argument{$type} ne $kind) {
$$output->write("$file: type ($type) respecified as different kind ($kind != $$translate_argument{$type})\n");
} else {
$$translate_argument{$type} = $kind;
}
$$type_format{$module}{$type} = $format;
} else {
$$output->write("$file: file must begin with %<type> statement\n");
exit 1;
}
}
close(IN);
}
sub get_spec_file_type {
my $proto = shift;
my $class = ref($proto) || $proto;
my $file = shift;
my $module;
my $type;
open(IN, "< $file") || die "$file: $!\n";
local $/ = "\n";
while(<IN>) {
s/^\s*(.*?)\s*$/$1/;
s/^(.*?)\s*#.*$/$1/;
/^$/ && next;
if(/^name\s*(\S*)/) { $module = $1; }
if(/^type\s*(\w+)/) { $type = $1; }
if(defined($module) && defined($type)) { last; }
}
close(IN);
return ($type, $module);
}
sub read_spec_files {
my $proto = shift;
my $class = ref($proto) || $proto;
my $modules = shift;
my $wine_dir = shift;
my $current_dir = shift;
my $files = shift;
my $win16api = shift;
my $win32api = shift;
foreach my $file (@$files) {
(my $type, my $module) = 'winapi'->get_spec_file_type("$wine_dir/$file");
$modules->spec_file_module($file, $module);
if($type eq "win16") {
$win16api->parse_spec_file("$wine_dir/$file");
} elsif($type eq "win32") {
$win32api->parse_spec_file("$wine_dir/$file");
}
}
}
sub read_all_spec_files {
my $proto = shift;
my $class = ref($proto) || $proto;
my $modules = shift;
my $wine_dir = shift;
my $current_dir = shift;
my $file_type = shift;
my $win16api = shift;
my $win32api = shift;
my @files = map {
s/^$wine_dir\/(.*)$/$1/;
if(&$file_type($_) eq "library") {
$_;
} else {
();
}
} split(/\n/, `find $wine_dir -name \\*.spec`);
'winapi'->read_spec_files($modules, $wine_dir, $current_dir, \@files, $win16api, $win32api);
}
sub parse_spec_file {
my $self = shift;
my $options = \${$self->{OPTIONS}};
my $output = \${$self->{OUTPUT}};
my $function_arguments = \%{$self->{FUNCTION_ARGUMENTS}};
my $function_calling_convention = \%{$self->{FUNCTION_CALLING_CONVENTION}};
my $function_external_name = \%{$self->{FUNCTION_EXTERNAL_NAME}};
my $function_stub = \%{$self->{FUNCTION_STUB}};
my $function_module = \%{$self->{FUNCTION_MODULE}};
my $modules = \%{$self->{MODULES}};
my $module_files = \%{$self->{MODULE_FILES}};
my $file = shift;
my %ordinals;
my $type;
my $module;
my $module_file;
if($$options->progress) {
$$output->progress("$file");
}
open(IN, "< $file") || die "$file: $!\n";
$/ = "\n";
my $header = 1;
my $lookahead = 0;
while($lookahead || defined($_ = <IN>)) {
$lookahead = 0;
s/^\s*(.*?)\s*$/$1/;
s/^(.*?)\s*#.*$/$1/;
/^$/ && next;
if($header) {
if(/^name\s*(\S*)/) { $module = $1; }
if(/^file\s*(\S*)/) { $module_file = $1; }
if(/^type\s*(\w+)/) { $type = $1; }
if(/^\d+|@/) { $header = 0; $lookahead = 1; }
next;
}
my $ordinal;
if(/^(\d+|@)\s+(pascal|pascal16|stdcall|cdecl|register|interrupt|varargs)\s+(\S+)\s*\(\s*(.*?)\s*\)\s*(\S+)$/) {
my $calling_convention = $2;
my $external_name = $3;
my $arguments = $4;
my $internal_name = $5;
$ordinal = $1;
# FIXME: Internal name existing more than once not handled properly
$$function_external_name{$internal_name} = $external_name;
$$function_arguments{$internal_name} = $arguments;
$$function_calling_convention{$internal_name} = $calling_convention;
if(!$$function_module{$internal_name}) {
$$function_module{$internal_name} = "$module";
} elsif($$function_module{$internal_name} !~ /$module/) {
$$function_module{$internal_name} .= " & $module";
}
if(0 && $$options->spec_mismatch) {
if($external_name eq "@") {
if($internal_name !~ /^\U$module\E_$ordinal$/) {
$$output->write("$file: $external_name: the internal name ($internal_name) mismatch\n");
}
} else {
my $name = $external_name;
my $name1 = $name;
$name1 =~ s/^Zw/Nt/;
my $name2 = $name;
$name2 =~ s/^(?:_|Rtl|k32|K32)//;
my $name3 = $name;
$name3 =~ s/^INT_Int[0-9a-f]{2}Handler$/BUILTIN_DefaultIntHandler/;
my $name4 = $name;
$name4 =~ s/^(VxDCall)\d$/$1/;
# FIXME: This special case is becuase of a very ugly kludge that should be fixed IMHO
my $name5 = $name;
$name5 =~ s/^(.*?16)_(.*?)$/$1_fn$2/;
if(uc($internal_name) ne uc($external_name) &&
$internal_name !~ /(\Q$name\E|\Q$name1\E|\Q$name2\E|\Q$name3\E|\Q$name4\E|\Q$name5\E)/)
{
$$output->write("$file: $external_name: internal name ($internal_name) mismatch\n");
}
}
}
} elsif(/^(\d+|@)\s+stub\s+(\S+)$/) {
my $external_name = $2;
$ordinal = $1;
my $internal_name;
if($type eq "win16") {
$internal_name = $external_name . "16";
} else {
$internal_name = $external_name;
}
# FIXME: Internal name existing more than once not handled properly
$$function_stub{$internal_name} = 1;
if(!$$function_module{$internal_name}) {
$$function_module{$internal_name} = "$module";
} elsif($$function_module{$internal_name} !~ /$module/) {
$$function_module{$internal_name} .= " & $module";
}
} elsif(/^(\d+|@)\s+(equate|long|word|extern|forward)/) {
# ignore
} else {
my $next_line = <IN>;
if(!defined($next_line) || $next_line =~ /^\s*\d|@/) {
die "$file: $.: syntax error: '$_'\n";
} else {
$_ .= $next_line;
$lookahead = 1;
}
}
if(defined($ordinal)) {
if($ordinal ne "@" && $ordinals{$ordinal}) {
$$output->write("$file: ordinal redefined: $_\n");
}
$ordinals{$ordinal}++;
}
}
close(IN);
$$modules{$module}++;
if(defined($module_file)) {
$$module_files{$module} = $module_file;
} else {
$$module_files{$module} = "$module.drv";
}
}
sub name {
my $self = shift;
my $name = \${$self->{NAME}};
return $$name;
}
sub is_allowed_kind {
my $self = shift;
my $allowed_kind = \%{$self->{ALLOWED_KIND}};
my $kind = shift;
if(defined($kind)) {
return $$allowed_kind{$kind};
} else {
return 0;
}
}
sub is_limited_type {
my $self = shift;
my $allowed_modules_limited = \%{$self->{ALLOWED_MODULES_LIMITED}};
my $type = shift;
return $$allowed_modules_limited{$type};
}
sub allowed_type_in_module {
my $self = shift;
my $allowed_modules = \%{$self->{ALLOWED_MODULES}};
my $allowed_modules_limited = \%{$self->{ALLOWED_MODULES_LIMITED}};
my $type = shift;
my @modules = split(/ \& /, shift);
if(!$$allowed_modules_limited{$type}) { return 1; }
foreach my $module (@modules) {
if($$allowed_modules{$type}{$module}) { return 1; }
}
return 0;
}
sub type_used_in_module {
my $self = shift;
my $used_modules = \%{$self->{USED_MODULES}};
my $type = shift;
my @modules = split(/ \& /, shift);
foreach my $module (@modules) {
$$used_modules{$type}{$module} = 1;
}
return ();
}
sub types_not_used {
my $self = shift;
my $used_modules = \%{$self->{USED_MODULES}};
my $allowed_modules = \%{$self->{ALLOWED_MODULES}};
my $not_used;
foreach my $type (sort(keys(%$allowed_modules))) {
foreach my $module (sort(keys(%{$$allowed_modules{$type}}))) {
if(!$$used_modules{$type}{$module}) {
$$not_used{$module}{$type} = 1;
}
}
}
return $not_used;
}
sub types_unlimited_used_in_modules {
my $self = shift;
my $output = \${$self->{OUTPUT}};
my $used_modules = \%{$self->{USED_MODULES}};
my $allowed_modules = \%{$self->{ALLOWED_MODULES}};
my $allowed_modules_unlimited = \%{$self->{ALLOWED_MODULES_UNLIMITED}};
my $used_types;
foreach my $type (sort(keys(%$allowed_modules_unlimited))) {
my $count = 0;
my @modules = ();
foreach my $module (sort(keys(%{$$used_modules{$type}}))) {
$count++;
push @modules, $module;
}
if($count) {
foreach my $module (@modules) {
$$used_types{$type}{$module} = 1;
}
}
}
return $used_types;
}
sub translate_argument {
my $self = shift;
my $translate_argument = \%{$self->{TRANSLATE_ARGUMENT}};
my $argument = shift;
return $$translate_argument{$argument};
}
sub all_declared_types {
my $self = shift;
my $translate_argument = \%{$self->{TRANSLATE_ARGUMENT}};
return sort(keys(%$translate_argument));
}
sub found_type {
my $self = shift;
my $type_found = \%{$self->{TYPE_FOUND}};
my $name = shift;
$$type_found{$name}++;
}
sub type_found {
my $self = shift;
my $type_found= \%{$self->{TYPE_FOUND}};
my $name = shift;
return $$type_found{$name};
}
sub is_allowed_type_format {
my $self = shift;
my $type_format = \%{$self->{TYPE_FORMAT}};
my $module = shift;
my $type = shift;
my $format = shift;
my $formats;
if(defined($module) && defined($type)) {
local $_;
foreach (split(/ & /, $module)) {
if(defined($formats)) {
$formats .= "|";
} else {
$formats = "";
}
if(defined($$type_format{$_}{$type})) {
$formats .= $$type_format{$_}{$type};
}
}
}
if(defined($formats)) {
local $_;
foreach (split(/\|/, $formats)) {
if($_ eq $format) {
return 1;
}
}
}
return 0;
}
sub all_modules {
my $self = shift;
my $modules = \%{$self->{MODULES}};
return sort(keys(%$modules));
}
sub is_module {
my $self = shift;
my $modules = \%{$self->{MODULES}};
my $name = shift;
return $$modules{$name};
}
sub module_file {
my $self = shift;
my $module = shift;
my $module_files = \%{$self->{MODULE_FILES}};
return $$module_files{$module};
}
sub all_functions {
my $self = shift;
my $function_calling_convention = \%{$self->{FUNCTION_CALLING_CONVENTION}};
return sort(keys(%$function_calling_convention));
}
sub all_functions_in_module {
my $self = shift;
my $function_calling_convention = \%{$self->{FUNCTION_CALLING_CONVENTION}};
my $function_module = \%{$self->{FUNCTION_MODULE}};
my $module = shift;
my @names;
foreach my $name (keys(%$function_calling_convention)) {
if($$function_module{$name} eq $module) {
push @names, $name;
}
}
return sort(@names);
}
sub all_functions_stub {
my $self = shift;
my $function_stub = \%{$self->{FUNCTION_STUB}};
return sort(keys(%$function_stub));
}
sub all_functions_found {
my $self = shift;
my $function_found = \%{$self->{FUNCTION_FOUND}};
return sort(keys(%$function_found));
}
sub function_calling_convention {
my $self = shift;
my $function_calling_convention = \%{$self->{FUNCTION_CALLING_CONVENTION}};
my $name = shift;
return $$function_calling_convention{$name};
}
sub function_external_name {
my $self = shift;
my $function_external_name = \%{$self->{FUNCTION_EXTERNAL_NAME}};
my $name = shift;
return $$function_external_name{$name};
}
sub is_function {
my $self = shift;
my $function_calling_convention = \%{$self->{FUNCTION_CALLING_CONVENTION}};
my $name = shift;
return $$function_calling_convention{$name};
}
sub is_shared_function {
my $self = shift;
my $function_shared = \%{$self->{FUNCTION_SHARED}};
my $name = shift;
return $$function_shared{$name};
}
sub found_shared_function {
my $self = shift;
my $function_shared = \%{$self->{FUNCTION_SHARED}};
my $name = shift;
$$function_shared{$name} = 1;
}
sub function_arguments {
my $self = shift;
my $function_arguments = \%{$self->{FUNCTION_ARGUMENTS}};
my $name = shift;
return $$function_arguments{$name};
}
sub function_module {
my $self = shift;
my $function_module = \%{$self->{FUNCTION_MODULE}};
my $name = shift;
return $$function_module{$name};
}
sub function_stub {
my $self = shift;
my $function_stub = \%{$self->{FUNCTION_STUB}};
my $name = shift;
return $$function_stub{$name};
}
sub found_function {
my $self = shift;
my $function_found = \%{$self->{FUNCTION_FOUND}};
my $name = shift;
$$function_found{$name}++;
}
sub function_found {
my $self = shift;
my $function_found = \%{$self->{FUNCTION_FOUND}};
my $name = shift;
return $$function_found{$name};
}
1;