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