tools/winapi/winapi_local.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_local;
  20
  21 use strict;
  22 use warnings 'all';
  23
  24 use nativeapi qw($nativeapi);
  25 use options qw($options);
  26 use output qw($output);
  27 use winapi qw($win16api $win32api @winapis);
  28
  29 sub _check_function($$$$$$) {
  30     my $return_type = shift;
  31     my $calling_convention = shift;
  32     my $external_name = shift;
  33     my $internal_name = shift;
  34     my $refargument_types = shift;
  35     my @argument_types = @$refargument_types;
  36     my $winapi = shift;
  37
  38     my $module = $winapi->function_internal_module($internal_name);
  39
  40     if($winapi->name eq "win16") {
  41         if($winapi->is_function_stub_in_module($module, $internal_name)) {
  42             if($options->implemented) {
  43                 $output->write("function implemented but declared as stub in .spec file\n");
  44             }
  45             return;
  46         } elsif($winapi->is_function_stub_in_module($module, $internal_name)) {
  47             if($options->implemented_win32) {
  48                 $output->write("32-bit variant of function implemented but declared as stub in .spec file\n");
  49             }
  50             return;
  51         }
  52     } elsif($winapi->is_function_stub_in_module($module, $internal_name)) {
  53         if($options->implemented) {
  54             $output->write("function implemented but declared as stub in .spec file\n");
  55         }
  56         return;
  57     }
  58
  59     my $forbidden_return_type = 0;
  60     my $implemented_return_kind;
  61     $winapi->type_used_in_module($return_type,$module);
  62     if(!defined($implemented_return_kind = $winapi->translate_argument($return_type))) {
  63         $winapi->declare_argument($return_type, "unknown");
  64         if($return_type ne "") {
  65             $output->write("no win*.api translation defined: " . $return_type . "\n");
  66         }
  67     } elsif(!$winapi->is_allowed_kind($implemented_return_kind) ||
  68             !$winapi->is_allowed_type_in_module($return_type, $module))
  69     {
  70         $forbidden_return_type = 1;
  71         $winapi->allow_kind($implemented_return_kind);
  72         $winapi->allow_type_in_module($return_type, $module);
  73         if($options->report_argument_forbidden($return_type)) {
  74             $output->write("return type is forbidden: $return_type ($implemented_return_kind)\n");
  75         }
  76     }
  77
  78     my $segmented = 0;
  79     if(defined($implemented_return_kind) && $implemented_return_kind =~ /^seg[sp]tr$/) {
  80         $segmented = 1;
  81     }
  82
  83     my $implemented_calling_convention;
  84     if($winapi->name eq "win16") {
  85         if($calling_convention eq "__cdecl") {
  86             $implemented_calling_convention = "cdecl";
  87         } elsif($calling_convention =~ /^(?:VFWAPIV|WINAPIV)$/) {
  88             $implemented_calling_convention = "varargs";
  89         } elsif($calling_convention =~ /^(?:__stdcall|__RPC_STUB|__RPC_USER|NET_API_FUNCTION|RPC_ENTRY|SEC_ENTRY|VFWAPI|WINGDIPAPI|WMIAPI|WINAPI|CALLBACK)$/) {
  90             if(defined($implemented_return_kind) && $implemented_return_kind =~ /^(?:s_word|word|void)$/) {
  91                 $implemented_calling_convention = "pascal16";
  92             } else {
  93                 $implemented_calling_convention = "pascal";
  94             }
  95         } elsif($calling_convention eq "__asm") {
  96             $implemented_calling_convention = "asm";
  97         } else {
  98             $implemented_calling_convention = "cdecl";
  99         }
 100     } elsif($winapi->name eq "win32") {
 101         if($calling_convention eq "__cdecl") {
 102             $implemented_calling_convention = "cdecl";
 103         } elsif($calling_convention =~ /^(?:VFWAPIV|WINAPIV)$/) {
 104             $implemented_calling_convention = "varargs";
 105         } elsif($calling_convention =~ /^(?:__stdcall|__RPC_STUB|__RPC_USER|APIENTRY|NET_API_FUNCTION|RPC_ENTRY|SEC_ENTRY|VFWAPI|WINGDIPAPI|WMIAPI|WINAPI|CALLBACK)$/) {
 106             if(defined($implemented_return_kind) && $implemented_return_kind eq "longlong") {
 107                 $implemented_calling_convention = "stdcall"; # FIXME: Check entry flags
 108             } else {
 109                 $implemented_calling_convention = "stdcall";
 110             }
 111         } elsif($calling_convention eq "__asm") {
 112             $implemented_calling_convention = "asm";
 113         } else {
 114             $implemented_calling_convention = "cdecl";
 115         }
 116     }
 117
 118     my $declared_calling_convention = $winapi->function_internal_calling_convention($internal_name) || "";
 119     my @declared_argument_kinds = split(/\s+/, $winapi->function_internal_arguments($internal_name));
 120
 121     my $declared_register = ($declared_calling_convention =~ / -register\b/);
 122     my $declared_i386 = ($declared_calling_convention =~ /(?:^pascal| -i386)\b/);
 123     $declared_calling_convention =~ s/ .*$//;
 124
 125     if(!$declared_register &&
 126        $implemented_calling_convention ne $declared_calling_convention &&
 127        $implemented_calling_convention ne "asm" &&
 128        !($declared_calling_convention =~ /^pascal/ && $forbidden_return_type) &&
 129        !($implemented_calling_convention =~ /^(?:cdecl|varargs)$/ && $declared_calling_convention =~ /^(?:cdecl|varargs)$/))
 130     {
 131         if($options->calling_convention && (
 132             ($options->calling_convention_win16 && $winapi->name eq "win16") ||
 133             ($options->calling_convention_win32 && $winapi->name eq "win32")) &&
 134             !$nativeapi->is_function($internal_name))
 135         {
 136             $output->write("calling convention mismatch: $implemented_calling_convention != $declared_calling_convention\n");
 137         }
 138     }
 139
 140     if($declared_calling_convention eq "varargs") {
 141         if ($#argument_types != -1 &&
 142             (($winapi->name eq "win32" && $argument_types[$#argument_types] eq "...") ||
 143             ($winapi->name eq "win16" && $argument_types[$#argument_types] eq "VA_LIST16")))
 144         {
 145             pop @argument_types;
 146         } else {
 147             $output->write("function not implemented as varargs\n");
 148         }
 149     } elsif ($#argument_types != -1 &&
 150         (($winapi->name eq "win32" && $argument_types[$#argument_types] eq "...") ||
 151         ($winapi->name eq "win16" && $argument_types[$#argument_types] eq "VA_LIST16")))
 152     {
 153         if($#argument_types == 0) {
 154             pop @argument_types;
 155         } else {
 156             $output->write("function not declared as varargs\n");
 157         }
 158     }
 159
 160     if($internal_name =~ /^(?:NTDLL__ftol|NTDLL__CIpow)$/) { # FIXME: Kludge
 161         # ignore
 162     } else {
 163         my $n = 0;
 164         my @argument_kinds = map {
 165             my $type = $_;
 166             my $kind = "unknown";
 167             $winapi->type_used_in_module($type,$module);
 168             if($type eq "CONTEXT *") {
 169                 $kind = "context";
 170             } elsif($type eq "CONTEXT86 *") {
 171                 $kind = "context86";
 172             } elsif(!defined($kind = $winapi->translate_argument($type))) {
 173                 $winapi->declare_argument($type, "unknown");
 174                 $output->write("no win*.api translation defined: " . $type . "\n");
 175             } elsif(!$winapi->is_allowed_kind($kind) ||
 176                     !$winapi->is_allowed_type_in_module($type, $module))
 177             {
 178                 $winapi->allow_kind($kind);
 179                 $winapi->allow_type_in_module($type, $module);
 180                 if($options->report_argument_forbidden($type)) {
 181                     $output->write("argument " . ($n + 1) . " type is forbidden: " . $type . " (" . $kind . ")\n");
 182                 }
 183             }
 184
 185             # FIXME: Kludge
 186             if(defined($kind) && $kind eq "struct16") {
 187                 $n+=2;
 188                 ("double", "double");
 189             } elsif(defined($kind) && $kind eq "longlong") {
 190                 $n+=1;
 191                 "longlong";
 192             } else {
 193                 $n++;
 194                 $kind;
 195             }
 196         } @argument_types;
 197
 198         if ($declared_register)
 199         {
 200             if (!$declared_i386 &&
 201                 $argument_kinds[$#argument_kinds] ne "context") {
 202                 $output->write("function declared as register, but CONTEXT * is not last argument\n");
 203             } elsif ($declared_i386 &&
 204                      $argument_kinds[$#argument_kinds] ne "context86") {
 205                 $output->write("function declared as register, but CONTEXT86 * is not last argument\n");
 206             }
 207         }
 208
 209         for my $n (0..$#argument_kinds) {
 210             if(!defined($argument_kinds[$n]) || !defined($declared_argument_kinds[$n])) { next; }
 211
 212             if($argument_kinds[$n] =~ /^seg[ps]tr$/ ||
 213                $declared_argument_kinds[$n] =~ /^seg[ps]tr$/)
 214             {
 215                 $segmented = 1;
 216             }
 217
 218             # FIXME: Kludge
 219             if(!defined($argument_types[$n])) {
 220                 $argument_types[$n] = "";
 221             }
 222
 223             if($argument_kinds[$n] =~ /^context(?:86)?$/) {
 224                 # Nothing
 225             } elsif(!$winapi->is_allowed_kind($argument_kinds[$n]) ||
 226                !$winapi->is_allowed_type_in_module($argument_types[$n], $module))
 227             {
 228                 $winapi->allow_kind($argument_kinds[$n]);
 229                 $winapi->allow_type_in_module($argument_types[$n],, $module);
 230                 if($options->report_argument_forbidden($argument_types[$n])) {
 231                     $output->write("argument " . ($n + 1) . " type is forbidden: " .
 232                                    "$argument_types[$n] ($argument_kinds[$n])\n");
 233                 }
 234             } elsif($argument_kinds[$n] ne $declared_argument_kinds[$n] &&
 235                    !($argument_kinds[$n] eq "longlong" && $declared_argument_kinds[$n] eq "double")) {
 236                 if($options->report_argument_kind($argument_kinds[$n]) ||
 237                    $options->report_argument_kind($declared_argument_kinds[$n]))
 238                 {
 239                     $output->write("argument " . ($n + 1) . " type mismatch: " .
 240                              $argument_types[$n] . " ($argument_kinds[$n]) != " .
 241                              $declared_argument_kinds[$n] . "\n");
 242                 }
 243             }
 244         }
 245
 246         if ($options->argument_count &&
 247             $implemented_calling_convention ne "asm")
 248         {
 249             if ($#argument_kinds != $#declared_argument_kinds and
 250                 $#argument_types != $#declared_argument_kinds) {
 251                 $output->write("argument count differs: " .
 252                     ($#argument_kinds + 1) . " != " .
 253                     ($#declared_argument_kinds + 1) . "\n");
 254             } elsif ($#argument_kinds != $#declared_argument_kinds or
 255                      $#argument_types != $#declared_argument_kinds) {
 256                 $output->write("argument count differs: " .
 257                     ($#argument_kinds + 1) . "/" . ($#argument_types + 1) .
 258                      " != " . ($#declared_argument_kinds + 1) .
 259                      " (long vs. long long problem?)\n");
 260             }
 261         }
 262
 263     }
 264
 265     if($segmented && $options->shared_segmented && $winapi->is_shared_internal_function($internal_name)) {
 266         $output->write("function using segmented pointers shared between Win16 and Win32\n");
 267     }
 268 }
 269
 270 sub check_function($) {
 271     my $function = shift;
 272
 273     my $return_type = $function->return_type;
 274     my $calling_convention = $function->calling_convention;
 275     my $calling_convention16 = $function->calling_convention16;
 276     my $calling_convention32 = $function->calling_convention32;
 277     my $internal_name = $function->internal_name;
 278     my $external_name16 = $function->external_name16;
 279     my $external_name32 = $function->external_name32;
 280     my $module16 = $function->module16;
 281     my $module32 = $function->module32;
 282     my $refargument_types = $function->argument_types;
 283
 284     if(!defined($refargument_types)) {
 285         return;
 286     }
 287
 288     if($options->win16 && $options->report_module($module16)) {
 289         _check_function($return_type,
 290                         $calling_convention, $external_name16,
 291                         $internal_name, $refargument_types,
 292                         $win16api);
 293     }
 294
 295     if($options->win32 && $options->report_module($module32)) {
 296         _check_function($return_type,
 297                         $calling_convention, $external_name32,
 298                         $internal_name, $refargument_types,
 299                         $win32api);
 300     }
 301 }
 302
 303 sub _check_statements($$$) {
 304     my $winapi = shift;
 305     my $functions = shift;
 306     my $function = shift;
 307
 308     my $module = $function->module;
 309     my $internal_name = $function->internal_name;
 310
 311     my $first_debug_message = 1;
 312     local $_ = $function->statements;
 313     while(defined($_)) {
 314         if(s/(\w+)\s*(?:\(\s*(\w+)\s*\))?\s*\(\s*((?:\"[^\"]*\"|\([^\)]*\)|[^\)])*?)\s*\)//) {
 315             my $called_name = $1;
 316             my $channel = $2;
 317             my $called_arguments = $3;
 318             if($called_name =~ /^(?:if|for|while|switch|sizeof)$/) {
 319                 # Nothing
 320             } elsif($called_name =~ /^(?:ERR|FIXME|MSG|TRACE|WARN)$/) {
 321                 if($first_debug_message && $called_name =~ /^(?:FIXME|TRACE)$/) {
 322                     $first_debug_message = 0;
 323                     if($called_arguments =~ /^\"\((.*?)\)(.*?)\"\s*,\s*(.*?)$/) {
 324                         my $formatting = $1;
 325                         my $extra = $2;
 326                         my $arguments = $3;
 327
 328                         my $format;
 329                         my $argument;
 330                         my $n = 0;
 331                         while($formatting && ($formatting =~ s/^([^,]*),?//, $format = $1, $format =~ s/^\s*(.*?)\s*$/$1/) &&
 332                               $arguments && ($arguments =~ s/^([^,]*),?//, $argument = $1, $argument =~ s/^\s*(.*?)\s*$/$1/))
 333                         {
 334                             my $type = @{$function->argument_types}[$n];
 335                             my $name = @{$function->argument_names}[$n];
 336
 337                             $n++;
 338
 339                             if(!defined($type)) { last; }
 340
 341                             $format =~ s/^\w+\s*[:=]?\s*//;
 342                             $format =~ s/\s*\{[^\{\}]*\}$//;
 343                             $format =~ s/\s*\[[^\[\]]*\]$//;
 344                             $format =~ s/^\'(.*?)\'$/$1/;
 345                             $format =~ s/^\\\"(.*?)\\\"$/$1/;
 346
 347                             if($options->debug_messages) {
 348                                 if($argument !~ /$name/) {
 349                                     $output->write("$called_name: argument $n is wrong ($name != '$argument')\n");
 350                                 } elsif(!$winapi->is_allowed_type_format($module, $type, $format)) {
 351                                     $output->write("$called_name: argument $n ($type $name) has illegal format ($format)\n");
 352                                 }
 353                             }
 354                         }
 355
 356                         if($options->debug_messages) {
 357                             my $count = $#{$function->argument_types} + 1;
 358                             if($n != $count) {
 359                                 $output->write("$called_name: argument count mismatch ($n != $count)\n");
 360                             }
 361                         }
 362                     }
 363                 }
 364             } elsif($options->cross_call) {
 365                 # $output->write("$internal_name: called $called_name\n");
 366                 $$functions{$internal_name}->function_called($called_name);
 367                 if(!defined($$functions{$called_name})) {
 368                     my $called_function = 'winapi_function'->new;
 369
 370                     $called_function->internal_name($called_name);
 371
 372                     $$functions{$called_name} = $called_function;
 373                 }
 374                 $$functions{$called_name}->function_called_by($internal_name);
 375             }
 376         } else {
 377             undef $_;
 378         }
 379     }
 380 }
 381
 382 sub check_statements($$) {
 383     my $functions = shift;
 384     my $function = shift;
 385
 386     my $module16 = $function->module16;
 387     my $module32 = $function->module32;
 388
 389     if($options->win16 && $options->report_module($module16)) {
 390         _check_statements($win16api, $functions, $function);
 391     }
 392
 393     if($options->win32 && $options->report_module($module32)) {
 394         _check_statements($win32api, $functions, $function);
 395     }
 396 }
 397
 398 sub check_file($$) {
 399     my $file = shift;
 400     my $functions = shift;
 401
 402     if($options->cross_call) {
 403         my @names = sort(keys(%$functions));
 404         for my $name (@names) {
 405             my $function = $$functions{$name};
 406
 407             my @called_names = $function->called_function_names;
 408             my @called_by_names = $function->called_by_function_names;
 409             my $module = $function->module;
 410
 411             if($options->cross_call_win32_win16) {
 412                 my $module16 = $function->module16;
 413                 my $module32 = $function->module32;
 414
 415                 if($#called_names >= 0 && (defined($module16) || defined($module32)) ) {
 416                     for my $called_name (@called_names) {
 417                         my $called_function = $$functions{$called_name};
 418
 419                         my $called_module16 = $called_function->module16;
 420                         my $called_module32 = $called_function->module32;
 421                         if(defined($module32) &&
 422                            defined($called_module16) && !defined($called_module32) &&
 423                            $name ne $called_name)
 424                         {
 425                             $output->write("$file: $module: $name: illegal call to $called_name (Win32 -> Win16)\n");
 426                         }
 427                     }
 428                 }
 429             }
 430
 431             if($options->cross_call_unicode_ascii) {
 432                 if($name =~ /(?<!A)W$/) {
 433                     for my $called_name (@called_names) {
 434                         if($called_name =~ /A$/) {
 435                             $output->write("$file: $module: $name: illegal call to $called_name (Unicode -> ASCII)\n");
 436                         }
 437                     }
 438                 }
 439             }
 440         }
 441     }
 442 }
 443
 444 1;