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