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