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 $external_name = shift;
  11     my $internal_name = shift;
  12     my $refargument_types = shift;
  13     my @argument_types = @$refargument_types;
  14     my $nativeapi = shift;
  15     my $winapi = shift;
  16
  17     my $module = $winapi->function_module($internal_name);
  18
  19     if($winapi->name eq "win16") {
  20         if($winapi->function_stub($internal_name)) {
  21             if($options->implemented) {
  22                 $output->write("function implemented but declared as stub in .spec file\n");
  23             }
  24             return;
  25         } elsif($winapi->function_stub($internal_name)) {
  26             if($options->implemented_win32) {
  27                 $output->write("32-bit variant of function implemented but declared as stub in .spec file\n");
  28             }
  29             return;
  30         }
  31     } elsif($winapi->function_stub($internal_name)) {
  32         if($options->implemented) {
  33             $output->write("function implemented but declared as stub in .spec file\n");
  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->write("no translation defined: " . $return_type . "\n");
  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->write("return type is forbidden: $return_type ($implemented_return_kind)\n");
  49         }
  50     }
  51
  52     my $segmented = 0;
  53     if(defined($implemented_return_kind) && $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         } elsif($calling_convention =~ /^__asm$/) {
  70             $implemented_calling_convention = "asm";
  71         } else {
  72             $implemented_calling_convention = "cdecl";
  73         }
  74     } elsif($winapi->name eq "win32") {
  75         if($calling_convention =~ /^__cdecl$/) {
  76             $implemented_calling_convention = "cdecl";
  77         } elsif($calling_convention =~ /^VFWAPIV|WINAPIV$/) {
  78             $implemented_calling_convention = "varargs";
  79         } elsif($calling_convention =~ /^__stdcall|VFWAPI|WINAPI|CALLBACK$/) {
  80             if(defined($implemented_return_kind) && $implemented_return_kind =~ /^longlong$/) {
  81                 $implemented_calling_convention = "stdcall"; # FIXME: Check entry flags
  82             } else {
  83                 $implemented_calling_convention = "stdcall";
  84             }
  85         } elsif($calling_convention =~ /^__asm$/) {
  86             $implemented_calling_convention = "asm";
  87         } else {
  88             $implemented_calling_convention = "cdecl";
  89         }
  90     }
  91
  92     my $declared_calling_convention = $winapi->function_calling_convention($internal_name);
  93     my @declared_argument_kinds = split(/\s+/, $winapi->function_arguments($internal_name));
  94
  95     if($declared_calling_convention =~ /^register|interrupt$/) {
  96         push @declared_argument_kinds, "ptr";
  97     }
  98
  99     if($declared_calling_convention =~ /^register|interupt$/ &&
 100          (($winapi->name eq "win32" && $implemented_calling_convention eq "stdcall") ||
 101          (($winapi->name eq "win16" && $implemented_calling_convention =~ /^pascal/))))
 102     {
 103         # correct
 104     } elsif($implemented_calling_convention ne $declared_calling_convention &&
 105        $implemented_calling_convention ne "asm" &&
 106        !($declared_calling_convention =~ /^pascal/ && $forbidden_return_type) &&
 107        !($implemented_calling_convention =~ /^cdecl|varargs$/ && $declared_calling_convention =~ /^cdecl|varargs$/))
 108     {
 109         if($options->calling_convention && (
 110             ($options->calling_convention_win16 && $winapi->name eq "win16") ||
 111             ($options->calling_convention_win32 && $winapi->name eq "win32")) &&
 112             !$nativeapi->is_function($internal_name))
 113         {
 114             $output->write("calling convention mismatch: $implemented_calling_convention != $declared_calling_convention\n");
 115         }
 116     }
 117
 118     if($declared_calling_convention eq "varargs") {
 119         if($#argument_types != -1 && $argument_types[$#argument_types] eq "...") {
 120             pop @argument_types;
 121         } else {
 122             $output->write("function not implemented as vararg\n");
 123         }
 124     } elsif($#argument_types != -1 && $argument_types[$#argument_types] eq "...") {
 125         $output->write("function not declared as vararg\n");
 126     }
 127
 128     if($#argument_types != -1 && $argument_types[$#argument_types] eq "CONTEXT *" &&
 129        $internal_name !~ /^(Get|Set)ThreadContext$/) # FIXME: Kludge
 130     {
 131         $#argument_types--;
 132     }
 133
 134     if($internal_name =~ /^NTDLL__ftol|NTDLL__CIpow$/) { # FIXME: Kludge
 135         # ignore
 136     } else {
 137         my $n = 0;
 138         my @argument_kinds = map {
 139             my $type = $_;
 140             my $kind = "unknown";
 141             $winapi->type_used_in_module($type,$module);
 142             if(!defined($kind = $winapi->translate_argument($type))) {
 143                 $output->write("no translation defined: " . $type . "\n");
 144             } elsif(!$winapi->is_allowed_kind($kind) ||
 145                     !$winapi->allowed_type_in_module($type, $module)) {
 146                 if($options->report_argument_forbidden($type)) {
 147                     $output->write("forbidden argument " . ($n + 1) . " type " . $type . " (" . $kind . ")\n");
 148                 }
 149             }
 150
 151             # FIXME: Kludge
 152             if(defined($kind) && $kind eq "longlong") {
 153                 $n+=2;
 154                 ("long", "long");
 155             } else {
 156                 $n++;
 157                 $kind;
 158             }
 159         } @argument_types;
 160
 161         for my $n (0..$#argument_kinds) {
 162             if(!defined($argument_kinds[$n]) || !defined($declared_argument_kinds[$n])) { next; }
 163
 164             if($argument_kinds[$n] =~ /^segptr|segstr$/ ||
 165                $declared_argument_kinds[$n] =~ /^segptr|segstr$/)
 166             {
 167                 $segmented = 1;
 168             }
 169
 170             # FIXME: Kludge
 171             if(!defined($argument_types[$n])) {
 172                 $argument_types[$n] = "";
 173             }
 174
 175             if(!$winapi->is_allowed_kind($argument_kinds[$n]) ||
 176                !$winapi->allowed_type_in_module($argument_types[$n], $module))
 177             {
 178                 if($options->report_argument_forbidden($argument_types[$n])) {
 179                     $output->write("argument " . ($n + 1) . " type is forbidden: " .
 180                                    "$argument_types[$n] ($argument_kinds[$n])\n");
 181                 }
 182             } elsif($argument_kinds[$n] ne $declared_argument_kinds[$n]) {
 183                 if($options->report_argument_kind($argument_kinds[$n]) ||
 184                    $options->report_argument_kind($declared_argument_kinds[$n]))
 185                 {
 186                     $output->write("argument " . ($n + 1) . " type mismatch: " .
 187                              $argument_types[$n] . " ($argument_kinds[$n]) != " .
 188                              $declared_argument_kinds[$n] . "\n");
 189                 }
 190             }
 191         }
 192
 193         if($#argument_kinds != $#declared_argument_kinds &&
 194            $implemented_calling_convention ne "asm")
 195         {
 196             if($options->argument_count) {
 197                 $output->write("argument count differs: " .
 198                     ($#argument_types + 1) . " != " .
 199                     ($#declared_argument_kinds + 1) . "\n");
 200             }
 201         }
 202
 203     }
 204
 205     if($segmented && $options->shared_segmented && $winapi->is_shared_function($internal_name)) {
 206         $output->write("function using segmented pointers shared between Win16 och Win32\n");
 207     }
 208 }
 209
 210 sub check_statements {
 211     my $options = shift;
 212     my $output = shift;
 213     my $winapi = shift;
 214     my $functions = shift;
 215     my $function = shift;
 216
 217     my $module = $function->module;
 218     my $internal_name = $function->internal_name;
 219
 220     my $first_debug_message = 1;
 221     local $_ = $function->statements;
 222     while(defined($_)) {
 223         if(s/(\w+)\s*(?:\(\s*(\w+)\s*\))?\s*\(\s*((?:\"[^\"]*\"|\([^\)]*\)|[^\)])*?)\s*\)//) {
 224             my $called_name = $1;
 225             my $channel = $2;
 226             my $called_arguments = $3;
 227             if($called_name =~ /^if|for|while|switch|sizeof$/) {
 228                 # Nothing
 229             } elsif($called_name =~ /^ERR|FIXME|MSG|TRACE|WARN$/) {
 230                 if($first_debug_message && $called_name =~ /^FIXME|TRACE$/) {
 231                     $first_debug_message = 0;
 232                     if($called_arguments =~ /^\"\((.*?)\)(.*?)\"\s*,\s*(.*?)$/) {
 233                         my $formating = $1;
 234                         my $extra = $2;
 235                         my $arguments = $3;
 236
 237                         my $format;
 238                         my $argument;
 239                         my $n = 0;
 240                         while($formating && ($formating =~ s/^([^,]*),?//, $format = $1, $format =~ s/^\s*(.*?)\s*$/$1/) &&
 241                               $arguments && ($arguments =~ s/^([^,]*),?//, $argument = $1, $argument =~ s/^\s*(.*?)\s*$/$1/))
 242                         {
 243                             my $type = @{$function->argument_types}[$n];
 244                             my $name = @{$function->argument_names}[$n];
 245
 246                             $n++;
 247
 248                             if(!defined($type)) { last; }
 249
 250                             $format =~ s/^\w+\s*[:=]?\s*//;
 251                             $format =~ s/\s*\{[^\{\}]*\}$//;
 252                             $format =~ s/\s*\[[^\[\]]*\]$//;
 253                             $format =~ s/^\'(.*?)\'$/$1/;
 254                             $format =~ s/^\\\"(.*?)\\\"$/$1/;
 255
 256                             if($argument !~ /$name/) {
 257                                 $output->write("$called_name: argument $n is wrong ($name != '$argument')\n");
 258                             } elsif(!$winapi->is_allowed_type_format($module, $type, $format)) {
 259                                 $output->write("$called_name: argument $n ($type $name) has illegal format ($format)\n");
 260                             }
 261                         }
 262
 263                         my $count = $#{$function->argument_types} + 1;
 264                         if($n != $count) {
 265                             $output->write("$called_name: argument count mismatch ($n != $count)\n");
 266                         }
 267                     }
 268                 }
 269             } else {
 270                 $$functions{$internal_name}->function_called($called_name);
 271                 if(!defined($$functions{$called_name})) {
 272                     $$functions{$called_name} = 'winapi_function'->new;
 273                 }
 274                 $$functions{$called_name}->function_called_by($internal_name);
 275             }
 276         } else {
 277             undef $_;
 278         }
 279     }
 280 }
 281
 282 sub check_file {
 283     my $options = shift;
 284     my $output = shift;
 285     my $file = shift;
 286     my $functions = shift;
 287
 288     if($options->cross_call) {
 289         my @names = sort(keys(%$functions));
 290         for my $name (@names) {
 291             my @called_names = $$functions{$name}->called_function_names;
 292             my @called_by_names = $$functions{$name}->called_by_function_names;
 293             my $module = $$functions{$name}->module;
 294
 295             if($options->cross_call_win32_win16) {
 296                 my $module16 = $$functions{$name}->module16;
 297                 my $module32 = $$functions{$name}->module32;
 298
 299                 if($#called_names >= 0 && (defined($module16) || defined($module32)) ) {
 300                     for my $called_name (@called_names) {
 301                         my $called_module16 = $$functions{$called_name}->module16;
 302                         my $called_module32 = $$functions{$called_name}->module32;
 303                         if(defined($module32) &&
 304                            defined($called_module16) && !defined($called_module32) &&
 305                            $name ne $called_name)
 306                         {
 307                             $output->write("$file: $module: $name: illegal call to $called_name (Win32 -> Win16)\n");
 308                         }
 309                     }
 310                 }
 311             }
 312
 313             if($options->cross_call_unicode_ascii) {
 314                 if($name =~ /W$/) {
 315                     for my $called_name (@called_names) {
 316                         if($called_name =~ /A$/) {
 317                             $output->write("$file: $module: $name: illegal call to $called_name (Unicode -> ASCII)\n");
 318                         }
 319                     }
 320                 }
 321             }
 322         }
 323     }
 324 }
 325
 326 1;
 327