tools/winapi_check/winapi_local.pm

   1 package winapi_local;
   2
   3 use strict;
   4
   5 sub check_function {
   6     my $options = shift;
   7     my $output = shift;
   8     my $return_type = shift;
   9     my $calling_convention = shift;
  10     my $name = shift;
  11     my $refargument_types = shift;
  12     my @argument_types = @$refargument_types;
  13     my $winapi = shift;
  14
  15     my $module = $winapi->function_module($name);
  16
  17     if($winapi->name eq "win16") {
  18         my $name16 = $name;
  19         $name16 =~ s/16$//;
  20         if($name16 ne $name && $winapi->function_stub($name16)) {
  21             if($options->implemented) {
  22                 &$output("function implemented but declared as stub in .spec file");
  23             }
  24             return;
  25         } elsif($winapi->function_stub($name)) {
  26             if($options->implemented_win32) {
  27                 &$output("32-bit variant of function implemented but declared as stub in .spec file");
  28             }
  29             return;
  30         }
  31     } elsif($winapi->function_stub($name)) {
  32         if($options->implemented) {
  33             &$output("function implemented but declared as stub in .spec file");
  34         }
  35         return;
  36     }
  37
  38     my $forbidden_return_type = 0;
  39     my $implemented_return_kind;
  40     $winapi->type_used_in_module($return_type,$module);
  41     if(!defined($implemented_return_kind = $winapi->translate_argument($return_type))) {
  42         if($return_type ne "") {
  43             &$output("no translation defined: " . $return_type);
  44         }
  45     } elsif(!$winapi->is_allowed_kind($implemented_return_kind) || !$winapi->allowed_type_in_module($return_type,$module)) {
  46         $forbidden_return_type = 1;
  47         if($options->report_argument_forbidden($return_type)) {
  48             &$output("forbidden return type: $return_type ($implemented_return_kind)");
  49         }
  50     }
  51
  52     my $segmented = 0;
  53     if($implemented_return_kind =~ /^segptr|segstr$/) {
  54         $segmented = 1;
  55     }
  56
  57     my $implemented_calling_convention;
  58     if($winapi->name eq "win16") {
  59         if($calling_convention =~ /^__cdecl$/) {
  60             $implemented_calling_convention = "cdecl";
  61         } elsif($calling_convention =~ /^VFWAPIV|WINAPIV$/) {
  62             $implemented_calling_convention = "varargs";
  63         } elsif($calling_convention = ~ /^__stdcall|VFWAPI|WINAPI|CALLBACK$/) {
  64             if($implemented_return_kind =~ /^s_word|word|void$/) {
  65                 $implemented_calling_convention = "pascal16";
  66             } else {
  67                 $implemented_calling_convention = "pascal";
  68             }
  69         }
  70     } elsif($winapi->name eq "win32") {
  71         if($calling_convention =~ /^__cdecl$/) {
  72             $implemented_calling_convention = "cdecl";
  73         } elsif($calling_convention =~ /^VFWAPIV|WINAPIV$/) {
  74             $implemented_calling_convention = "varargs";
  75         } elsif($calling_convention =~ /^__stdcall|VFWAPI|WINAPI|CALLBACK$/) {
  76             $implemented_calling_convention = "stdcall";
  77         } else {
  78             $implemented_calling_convention = "<default>";
  79         }
  80     }
  81
  82     my $declared_calling_convention = $winapi->function_calling_convention($name);
  83     my @declared_argument_kinds = split(/\s+/, $winapi->function_arguments($name));
  84
  85     if($declared_calling_convention =~ /^register|interrupt$/) {
  86         push @declared_argument_kinds, "ptr";
  87     }
  88
  89     if($declared_calling_convention =~ /^register|interupt$/ &&
  90          (($winapi->name eq "win32" && $implemented_calling_convention eq "stdcall") ||
  91          (($winapi->name eq "win16" && $implemented_calling_convention =~ /^pascal/))))
  92     {
  93         # correct
  94     } elsif($implemented_calling_convention ne $declared_calling_convention &&
  95        !($declared_calling_convention =~ /^pascal/ && $forbidden_return_type) &&
  96        !($implemented_calling_convention =~ /^cdecl|varargs$/ && $declared_calling_convention =~ /^cdecl|varargs$/))
  97     {
  98         if($options->calling_convention) {
  99             &$output("calling convention mismatch: $implemented_calling_convention != $declared_calling_convention");
 100         }
 101     }
 102
 103     if($declared_calling_convention eq "varargs") {
 104         if($#argument_types != -1 && $argument_types[$#argument_types] eq "...") {
 105             pop @argument_types;
 106         } else {
 107             &$output("function not implemented as vararg");
 108         }
 109     } elsif($#argument_types != -1 && $argument_types[$#argument_types] eq "...") {
 110         &$output("function not declared as vararg");
 111     }
 112
 113     if($#argument_types != -1 && $argument_types[$#argument_types] eq "CONTEXT *" &&
 114        $name !~ /^(Get|Set)ThreadContext$/)
 115     {
 116         $#argument_types--;
 117     }
 118
 119     if($name =~ /^CRTDLL__ftol|CRTDLL__CIpow$/) {
 120         # ignore
 121     } else {
 122         my $n = 0;
 123         my @argument_kinds = map {
 124             my $type = $_;
 125             my $kind = "unknown";
 126             $winapi->type_used_in_module($type,$module);
 127             if(!defined($kind = $winapi->translate_argument($type))) {
 128                 &$output("no translation defined: " . $type);
 129             } elsif(!$winapi->is_allowed_kind($kind) ||
 130                     !$winapi->allowed_type_in_module($type, $module)) {
 131                 if($options->report_argument_forbidden($type)) {
 132                     &$output("forbidden argument " . ($n + 1) . " type " . $type . " (" . $kind . ")");
 133                 }
 134             }
 135             if(defined($kind) && $kind eq "longlong") {
 136                 $n+=2;
 137                 ("long", "long");
 138             } else {
 139                 $n++;
 140                 $kind;
 141             }
 142         } @argument_types;
 143
 144         for my $n (0..$#argument_kinds) {
 145             if(!defined($argument_kinds[$n]) || !defined($declared_argument_kinds[$n])) { next; }
 146
 147             if($argument_kinds[$n] =~ /^segptr|segstr$/ ||
 148                $declared_argument_kinds[$n] =~ /^segptr|segstr$/)
 149             {
 150                 $segmented = 1;
 151             }
 152
 153             if($argument_kinds[$n] ne $declared_argument_kinds[$n]) {
 154                 if($options->report_argument_kind($argument_kinds[$n]) ||
 155                    $options->report_argument_kind($declared_argument_kinds[$n]))
 156                 {
 157                     &$output("argument " . ($n + 1) . " type mismatch: " .
 158                              $argument_types[$n] . " ($argument_kinds[$n]) != " . $declared_argument_kinds[$n]);
 159                 }
 160             }
 161         }
 162         if($#argument_kinds != $#declared_argument_kinds) {
 163             if($options->argument_count) {
 164                 &$output("argument count differs: " . ($#argument_types + 1) . " != " . ($#declared_argument_kinds + 1));
 165             }
 166         }
 167
 168     }
 169
 170     if($segmented && $options->shared_segmented && $winapi->is_shared_function($name)) {
 171         &$output("function using segmented pointers shared between Win16 och Win32");
 172     }
 173 }
 174
 175 sub check_file {
 176     my $options = shift;
 177     my $output = shift;
 178     my $file = shift;
 179     my $functions = shift;
 180
 181     if($options->cross_call) {
 182         my @names = sort(keys(%$functions));
 183         for my $name (@names) {
 184             my @called_names = $$functions{$name}->called_function_names;
 185             my @called_by_names = $$functions{$name}->called_by_function_names;
 186             my $module = $$functions{$name}->module;
 187             my $module16 = $$functions{$name}->module16;
 188             my $module32 = $$functions{$name}->module32;
 189
 190             if($#called_names >= 0 && (defined($module16) || defined($module32)) ) {
 191                 for my $called_name (@called_names) {
 192                     my $called_module16 = $$functions{$called_name}->module16;
 193                     my $called_module32 = $$functions{$called_name}->module32;
 194                     if(defined($module32) &&
 195                        defined($called_module16) && !defined($called_module32) &&
 196                        $name ne $called_name)
 197                     {
 198                         $output->write("$file: $module: $name: illegal call to $called_name (Win16)\n");
 199                     }
 200                 }
 201             }
 202         }
 203     }
 204 }
 205
 206 1;
 207