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