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