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