tools/winapi_check/winapi.pm

   1 package winapi;
   2
   3 use strict;
   4
   5 sub new {
   6     my $proto = shift;
   7     my $class = ref($proto) || $proto;
   8     my $self  = {};
   9     bless ($self, $class);
  10
  11     my $options = \${$self->{OPTIONS}};
  12     my $output = \${$self->{OUTPUT}};
  13     my $name = \${$self->{NAME}};
  14
  15     $$options = shift;
  16     $$output = shift;
  17     $$name = shift;
  18     my $path = shift;
  19
  20     my @files = map {
  21         s/^.\/(.*)$/$1/;
  22         $_;
  23     } split(/\n/, `find $path -name \\*.api`);
  24
  25     foreach my $file (@files) {
  26         my $module = $file;
  27         $module =~ s/.*?\/([^\/]*?)\.api$/$1/;
  28         $self->parse_api_file($file,$module);
  29     }
  30
  31     return $self;
  32 }
  33
  34 sub parse_api_file {
  35     my $self = shift;
  36     my $output = \${$self->{OUTPUT}};
  37     my $allowed_kind = \%{$self->{ALLOWED_KIND}};
  38     my $allowed_modules = \%{$self->{ALLOWED_MODULES}};
  39     my $allowed_modules_limited = \%{$self->{ALLOWED_MODULES_LIMITED}};
  40     my $allowed_modules_unlimited = \%{$self->{ALLOWED_MODULES_UNLIMITED}};
  41     my $translate_argument = \%{$self->{TRANSLATE_ARGUMENT}};
  42
  43     my $file = shift;
  44     my $module = shift;
  45
  46     my $kind;
  47     my $extension = 0;
  48     my $forbidden = 0;
  49
  50     $$output->progress("$file");
  51
  52     open(IN, "< $file") || die "$file: $!\n";
  53     $/ = "\n";
  54     while(<IN>) {
  55         s/^\s*?(.*?)\s*$/$1/; # remove whitespace at begin and end of line
  56         s/^(.*?)\s*#.*$/$1/;  # remove comments
  57         /^$/ && next;         # skip empty lines
  58
  59         if(s/^%(\S+)\s*//) {
  60             $kind = $1;
  61             $forbidden = 0;
  62             $extension = 0;
  63
  64             $$allowed_kind{$kind} = 1;
  65             if(/^--forbidden/) {
  66                 $forbidden = 1;
  67             } elsif(/^--extension/) {
  68                 $extension = 1;
  69             }
  70         } elsif(defined($kind)) {
  71             my $type = $_;
  72             if(!$forbidden) {
  73                 if(defined($module)) {
  74                     if($$allowed_modules_unlimited{$type}) {
  75                         $$output->write("$file: type ($type) already specificed as an unlimited type\n");
  76                     } elsif(!$$allowed_modules{$type}{$module}) {
  77                         $$allowed_modules{$type}{$module} = 1;
  78                         $$allowed_modules_limited{$type} = 1;
  79                     } else {
  80                         $$output->write("$file: type ($type) already specificed\n");
  81                     }
  82                 } else {
  83                     $$allowed_modules_unlimited{$type} = 1;
  84                 }
  85             } else {
  86                 $$allowed_modules_limited{$type} = 1;
  87             }
  88             if(defined($$translate_argument{$type}) && $$translate_argument{$type} ne $kind) {
  89                 $$output->write("$file: type ($type) respecified as different kind ($kind != $$translate_argument{$type})\n");
  90             } else {
  91                 $$translate_argument{$type} = $kind;
  92             }
  93         } else {
  94             $$output->write("$file: file must begin with %<type> statement\n");
  95             exit 1;
  96         }
  97     }
  98     close(IN);
  99 }
 100
 101 sub get_spec_file_type {
 102     my $proto = shift;
 103     my $class = ref($proto) || $proto;
 104
 105     my $file = shift;
 106
 107     my $type;
 108
 109     open(IN, "< $file") || die "$file: $!\n";
 110     $/ = "\n";
 111     while(<IN>) {
 112         if(/^type\s*(\w+)/) {
 113             $type = $1;
 114             last;
 115         }
 116     }
 117     close(IN);
 118
 119     return $type;
 120 }
 121
 122 sub read_spec_files {
 123     my $proto = shift;
 124     my $class = ref($proto) || $proto;
 125
 126     my $path = shift;
 127     my $win16api = shift;
 128     my $win32api = shift;
 129
 130     my @files = map {
 131         s/^.\/(.*)$/$1/;
 132         $_;
 133     } split(/\n/, `find $path -name \\*.spec`);
 134
 135     foreach my $file (@files) {
 136         my $type = 'winapi'->get_spec_file_type($file);
 137         if($type eq "win16") {
 138             $win16api->parse_spec_file($file);
 139         } elsif($type eq "win32") {
 140             $win32api->parse_spec_file($file);
 141         }
 142     }
 143 }
 144
 145 sub parse_spec_file {
 146     my $self = shift;
 147
 148     my $options = \${$self->{OPTIONS}};
 149     my $output = \${$self->{OUTPUT}};
 150     my $function_arguments = \%{$self->{FUNCTION_ARGUMENTS}};
 151     my $function_calling_convention = \%{$self->{FUNCTION_CALLING_CONVENTION}};
 152     my $function_stub = \%{$self->{FUNCTION_STUB}};
 153     my $function_module = \%{$self->{FUNCTION_MODULE}};
 154
 155     my $file = shift;
 156
 157     my %ordinals;
 158     my $type;
 159     my $module;
 160
 161     $$output->progress("$file");
 162
 163     open(IN, "< $file") || die "$file: $!\n";
 164     $/ = "\n";
 165     my $header = 1;
 166     my $lookahead = 0;
 167     while($lookahead || defined($_ = <IN>)) {
 168         $lookahead = 0;
 169         s/^\s*(.*?)\s*$/$1/;
 170         s/^(.*?)\s*#.*$/$1/;
 171         /^$/ && next;
 172
 173         if($header)  {
 174             if(/^name\s*(\S*)/) { $module = $1; }
 175             if(/^type\s*(\w+)/) { $type = $1; }
 176             if(/^\d+|@/) { $header = 0 };
 177             next;
 178         }
 179
 180         my $ordinal;
 181         if(/^(\d+|@)\s+(pascal|pascal16|stdcall|cdecl|register|interrupt|varargs)\s+(\S+)\s*\(\s*(.*?)\s*\)\s*(\S+)$/) {
 182             my $calling_convention = $2;
 183             my $external_name = $3;
 184             my $arguments = $4;
 185             my $internal_name = $5;
 186
 187             $ordinal = $1;
 188
 189             # FIXME: Internal name existing more than once not handled properly
 190             $$function_arguments{$internal_name} = $arguments;
 191             $$function_calling_convention{$internal_name} = $calling_convention;
 192             if(!$$function_module{$internal_name}) {
 193                 $$function_module{$internal_name} = "$module";
 194             } elsif($$function_module{$internal_name} !~ /$module/) {
 195                 $$function_module{$internal_name} .= " & $module";
 196             }
 197
 198             if($$options->spec_mismatch) {
 199                 if($external_name eq "@") {
 200                     if($internal_name !~ /^\U$module\E_$ordinal$/) {
 201                         $$output->write("$file: $external_name: the internal name ($internal_name) mismatch\n");
 202                     }
 203                 } else {
 204                     my $name = $external_name;
 205
 206                     my $name1 = $name;
 207                     $name1 =~ s/^Zw/Nt/;
 208
 209                     my $name2 = $name;
 210                     $name2 =~ s/^(?:_|Rtl|k32|K32)//;
 211
 212                     my $name3 = $name;
 213                     $name3 =~ s/^INT_Int[0-9a-f]{2}Handler$/BUILTIN_DefaultIntHandler/;
 214
 215                     my $name4 = $name;
 216                     $name4 =~ s/^(VxDCall)\d$/$1/;
 217
 218                     # FIXME: This special case is becuase of a very ugly kludge that should be fixed IMHO
 219                     my $name5 = $name;
 220                     $name5 =~ s/^(.*?16)_(.*?)$/$1_fn$2/;
 221
 222                     if(uc($internal_name) ne uc($external_name) &&
 223                        $internal_name !~ /(\Q$name\E|\Q$name1\E|\Q$name2\E|\Q$name3\E|\Q$name4\E|\Q$name5\E)/)
 224                     {
 225                         $$output->write("$file: $external_name: internal name ($internal_name) mismatch\n");
 226                     }
 227                 }
 228             }
 229         } elsif(/^(\d+|@)\s+stub\s+(\S+)$/) {
 230             my $external_name = $2;
 231
 232             $ordinal = $1;
 233
 234             my $internal_name;
 235             if($type eq "win16") {
 236                 $internal_name = $external_name . "16";
 237             } else {
 238                 $internal_name = $external_name;
 239             }
 240
 241             # FIXME: Internal name existing more than once not handled properly
 242             $$function_stub{$internal_name} = 1;
 243             if(!$$function_module{$internal_name}) {
 244                 $$function_module{$internal_name} = "$module";
 245             } elsif($$function_module{$internal_name} !~ /$module/) {
 246                 $$function_module{$internal_name} .= " & $module";
 247             }
 248         } elsif(/^(\d+|@)\s+(equate|long|word|extern|forward)/) {
 249             # ignore
 250         } else {
 251             my $next_line = <IN>;
 252             if($next_line =~ /^\d|@/) {
 253                 die "$file: $.: syntax error: '$_'\n";
 254             } else {
 255                 $_ .= $next_line;
 256                 $lookahead = 1;
 257             }
 258         }
 259
 260         if(defined($ordinal)) {
 261             if($ordinal ne "@" && $ordinals{$ordinal}) {
 262                 $$output->write("$file: ordinal redefined: $_\n");
 263             }
 264             $ordinals{$ordinal}++;
 265         }
 266     }
 267     close(IN);
 268 }
 269
 270 sub name {
 271     my $self = shift;
 272     my $name = \${$self->{NAME}};
 273
 274     return $$name;
 275 }
 276
 277 sub is_allowed_kind {
 278     my $self = shift;
 279     my $allowed_kind = \%{$self->{ALLOWED_KIND}};
 280
 281     my $kind = shift;
 282     if(defined($kind)) {
 283         return $$allowed_kind{$kind};
 284     } else {
 285         return 0;
 286     }
 287 }
 288
 289 sub is_limited_type {
 290     my $self = shift;
 291     my $allowed_modules_limited = \%{$self->{ALLOWED_MODULES_LIMITED}};
 292
 293     my $type = shift;
 294
 295     return $$allowed_modules_limited{$type};
 296 }
 297
 298 sub allowed_type_in_module {
 299     my $self = shift;
 300     my $allowed_modules = \%{$self->{ALLOWED_MODULES}};
 301     my $allowed_modules_limited = \%{$self->{ALLOWED_MODULES_LIMITED}};
 302
 303     my $type = shift;
 304     my @modules = split(/ \& /, shift);
 305
 306     if(!$$allowed_modules_limited{$type}) { return 1; }
 307
 308     foreach my $module (@modules) {
 309         if($$allowed_modules{$type}{$module}) { return 1; }
 310     }
 311
 312     return 0;
 313 }
 314
 315 sub type_used_in_module {
 316     my $self = shift;
 317     my $used_modules = \%{$self->{USED_MODULES}};
 318
 319     my $type = shift;
 320     my @modules = split(/ \& /, shift);
 321
 322     foreach my $module (@modules) {
 323         $$used_modules{$type}{$module} = 1;
 324     }
 325
 326     return ();
 327 }
 328
 329 sub types_not_used {
 330     my $self = shift;
 331     my $used_modules = \%{$self->{USED_MODULES}};
 332     my $allowed_modules = \%{$self->{ALLOWED_MODULES}};
 333
 334     my $not_used;
 335     foreach my $type (sort(keys(%$allowed_modules))) {
 336         foreach my $module (sort(keys(%{$$allowed_modules{$type}}))) {
 337             if(!$$used_modules{$type}{$module}) {
 338                 $$not_used{$module}{$type} = 1;
 339             }
 340         }
 341     }
 342     return $not_used;
 343 }
 344
 345 sub types_unlimited_used_in_modules {
 346     my $self = shift;
 347
 348     my $output = \${$self->{OUTPUT}};
 349     my $used_modules = \%{$self->{USED_MODULES}};
 350     my $allowed_modules = \%{$self->{ALLOWED_MODULES}};
 351     my $allowed_modules_unlimited = \%{$self->{ALLOWED_MODULES_UNLIMITED}};
 352
 353     my $used_types;
 354     foreach my $type (sort(keys(%$allowed_modules_unlimited))) {
 355         my $count = 0;
 356         my @modules = ();
 357         foreach my $module (sort(keys(%{$$used_modules{$type}}))) {
 358             $count++;
 359             push @modules, $module;
 360         }
 361         if($count) {
 362             foreach my $module (@modules) {
 363               $$used_types{$type}{$module} = 1;
 364             }
 365         }
 366     }
 367     return $used_types;
 368 }
 369
 370 sub translate_argument {
 371     my $self = shift;
 372     my $translate_argument = \%{$self->{TRANSLATE_ARGUMENT}};
 373
 374     my $argument = shift;
 375
 376     return $$translate_argument{$argument};
 377 }
 378
 379 sub all_declared_types {
 380     my $self = shift;
 381     my $translate_argument = \%{$self->{TRANSLATE_ARGUMENT}};
 382
 383     return sort(keys(%$translate_argument));
 384 }
 385
 386 sub found_type {
 387     my $self = shift;
 388     my $type_found = \%{$self->{TYPE_FOUND}};
 389
 390     my $name = shift;
 391
 392     $$type_found{$name}++;
 393 }
 394
 395 sub type_found {
 396     my $self = shift;
 397     my $type_found= \%{$self->{TYPE_FOUND}};
 398
 399     my $name = shift;
 400
 401     return $$type_found{$name};
 402 }
 403
 404 sub all_functions {
 405     my $self = shift;
 406     my $function_calling_convention = \%{$self->{FUNCTION_CALLING_CONVENTION}};
 407
 408     return sort(keys(%$function_calling_convention));
 409 }
 410
 411 sub all_functions_stub {
 412     my $self = shift;
 413     my $function_stub = \%{$self->{FUNCTION_STUB}};
 414
 415     return sort(keys(%$function_stub));
 416 }
 417
 418 sub all_functions_found {
 419     my $self = shift;
 420     my $function_found = \%{$self->{FUNCTION_FOUND}};
 421
 422     return sort(keys(%$function_found));
 423 }
 424
 425 sub function_calling_convention {
 426     my $self = shift;
 427     my $function_calling_convention = \%{$self->{FUNCTION_CALLING_CONVENTION}};
 428
 429     my $name = shift;
 430
 431     return $$function_calling_convention{$name};
 432 }
 433
 434 sub is_function {
 435     my $self = shift;
 436     my $function_calling_convention = \%{$self->{FUNCTION_CALLING_CONVENTION}};
 437
 438     my $name = shift;
 439
 440     return $$function_calling_convention{$name};
 441 }
 442
 443 sub is_shared_function {
 444     my $self = shift;
 445     my $function_shared = \%{$self->{FUNCTION_SHARED}};
 446
 447     my $name = shift;
 448
 449     return $$function_shared{$name};
 450 }
 451
 452 sub found_shared_function {
 453     my $self = shift;
 454     my $function_shared = \%{$self->{FUNCTION_SHARED}};
 455
 456     my $name = shift;
 457
 458     $$function_shared{$name} = 1;
 459 }
 460
 461 sub function_arguments {
 462     my $self = shift;
 463     my $function_arguments = \%{$self->{FUNCTION_ARGUMENTS}};
 464
 465     my $name = shift;
 466
 467     return $$function_arguments{$name};
 468 }
 469
 470 sub function_module {
 471     my $self = shift;
 472     my $function_module = \%{$self->{FUNCTION_MODULE}};
 473
 474     my $name = shift;
 475
 476     return $$function_module{$name};
 477 }
 478
 479 sub function_stub {
 480     my $self = shift;
 481     my $function_stub = \%{$self->{FUNCTION_STUB}};
 482
 483     my $name = shift;
 484
 485     return $$function_stub{$name};
 486 }
 487
 488 sub found_function {
 489     my $self = shift;
 490     my $function_found = \%{$self->{FUNCTION_FOUND}};
 491
 492     my $name = shift;
 493
 494     $$function_found{$name}++;
 495 }
 496
 497 sub function_found {
 498     my $self = shift;
 499     my $function_found = \%{$self->{FUNCTION_FOUND}};
 500
 501     my $name = shift;
 502
 503     return $$function_found{$name};
 504 }
 505
 506 1;