tools/winapi_check/winapi_parser.pm

   1 #
   2 # Copyright 1999, 2000, 2001 Patrik Stridvall
   3 #
   4 # This library is free software; you can redistribute it and/or
   5 # modify it under the terms of the GNU Lesser General Public
   6 # License as published by the Free Software Foundation; either
   7 # version 2.1 of the License, or (at your option) any later version.
   8 #
   9 # This library is distributed in the hope that it will be useful,
  10 # but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 # Lesser General Public License for more details.
  13 #
  14 # You should have received a copy of the GNU Lesser General Public
  15 # License along with this library; if not, write to the Free Software
  16 # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17 #
  18
  19 package winapi_parser;
  20
  21 use strict;
  22
  23 use output qw($output);
  24 use options qw($options);
  25
  26 sub parse_c_file {
  27     my $file = shift;
  28     my $callbacks = shift;
  29
  30     my $empty_callback = sub { };
  31
  32     my $c_comment_found_callback = $$callbacks{c_comment_found} || $empty_callback;
  33     my $cplusplus_comment_found_callback = $$callbacks{cplusplus_comment_found} || $empty_callback;
  34     my $function_create_callback = $$callbacks{function_create} || $empty_callback;
  35     my $function_found_callback = $$callbacks{function_found} || $empty_callback;
  36     my $type_create_callback = $$callbacks{type_create} || $empty_callback;
  37     my $type_found_callback = $$callbacks{type_found} || $empty_callback;
  38     my $preprocessor_found_callback = $$callbacks{preprocessor_found} || $empty_callback;
  39
  40     # global
  41     my $debug_channels = [];
  42
  43     my $in_function = 0;
  44     my $function_begin;
  45     my $function_end;
  46     {
  47         my $documentation_line;
  48         my $documentation;
  49         my $function_line;
  50         my $linkage;
  51         my $return_type;
  52         my $calling_convention;
  53         my $internal_name = "";
  54         my $argument_types;
  55         my $argument_names;
  56         my $argument_documentations;
  57         my $statements_line;
  58         my $statements;
  59
  60         $function_begin = sub {
  61             $documentation_line = shift;
  62             $documentation = shift;
  63             $function_line = shift;
  64             $linkage = shift;
  65             $return_type= shift;
  66             $calling_convention = shift;
  67             $internal_name = shift;
  68             $argument_types = shift;
  69             $argument_names = shift;
  70             $argument_documentations = shift;
  71
  72             if(defined($argument_names) && defined($argument_types) &&
  73                $#$argument_names == -1)
  74             {
  75                 foreach my $n (0..$#$argument_types) {
  76                     push @$argument_names, "";
  77                 }
  78             }
  79
  80             if(defined($argument_documentations) &&
  81                $#$argument_documentations == -1)
  82             {
  83                 foreach my $n (0..$#$argument_documentations) {
  84                     push @$argument_documentations, "";
  85                 }
  86             }
  87
  88             $in_function = 1;
  89         };
  90
  91         $function_end = sub {
  92             $statements_line = shift;
  93             $statements = shift;
  94
  95             my $function = &$function_create_callback();
  96
  97             if(!defined($documentation_line)) {
  98                 $documentation_line = 0;
  99             }
 100
 101             $function->file($file);
 102             $function->debug_channels([@$debug_channels]);
 103             $function->documentation_line($documentation_line);
 104             $function->documentation($documentation);
 105             $function->function_line($function_line);
 106             $function->linkage($linkage);
 107             $function->return_type($return_type);
 108             $function->calling_convention($calling_convention);
 109             $function->internal_name($internal_name);
 110             if(defined($argument_types)) {
 111                 $function->argument_types([@$argument_types]);
 112             }
 113             if(defined($argument_names)) {
 114                 $function->argument_names([@$argument_names]);
 115             }
 116             if(defined($argument_documentations)) {
 117                 $function->argument_documentations([@$argument_documentations]);
 118             }
 119             $function->statements_line($statements_line);
 120             $function->statements($statements);
 121
 122             &$function_found_callback($function);
 123
 124             $in_function = 0;
 125         };
 126     }
 127
 128     my $in_type = 0;
 129     my $type_begin;
 130     my $type_end;
 131     {
 132         my $type;
 133
 134         $type_begin = sub {
 135             $type = shift;
 136             $in_type = 1;
 137         };
 138
 139         $type_end = sub {
 140             my $names = shift;
 141
 142             foreach my $name (@$names) {
 143                 if($type =~ /^(?:struct|enum)/) {
 144                     # $output->write("typedef $type {\n");
 145                     # $output->write("} $name;\n");
 146                 } else {
 147                     # $output->write("typedef $type $name;\n");
 148                 }
 149             }
 150             $in_type = 0;
 151         };
 152     }
 153
 154     my %regs_entrypoints;
 155     my @comment_lines = ();
 156     my @comments = ();
 157     my $statements_line;
 158     my $statements;
 159     my $level = 0;
 160     my $extern_c = 0;
 161     my $again = 0;
 162     my $lookahead = 0;
 163     my $lookahead_count = 0;
 164
 165     print STDERR "Processing file '$file' ... " if $options->verbose;
 166     open(IN, "< $file") || die "<internal>: $file: $!\n";
 167     $/ = "\n";
 168     while($again || defined(my $line = <IN>)) {
 169         if(!$again) {
 170             chomp $line;
 171
 172             if($lookahead) {
 173                 $lookahead = 0;
 174                 $_ .= "\n" . $line;
 175                 $lookahead_count++;
 176             } else {
 177                 $_ = $line;
 178                 $lookahead_count = 0;
 179             }
 180             print " $level($lookahead_count): $line\n" if $options->debug >= 2;
 181             print "*** $_\n" if $options->debug >= 3;
 182         } else {
 183             $lookahead_count = 0;
 184             $again = 0;
 185         }
 186
 187         # CVS merge conflicts in file?
 188         if(/^(<<<<<<<|=======|>>>>>>>)/) {
 189             $output->write("$file: merge conflicts in file\n");
 190             last;
 191         }
 192
 193         # remove C comments
 194         if(s/^([^\"\/]*?(?:\"[^\"]*?\"[^\"]*?)*?)(?=\/\*)//s) {
 195             my $prefix = $1;
 196             if(s/^(\/\*.*?\*\/)//s) {
 197                 my @lines = split(/\n/, $1);
 198                 push @comment_lines, $.;
 199                 push @comments, $1;
 200                 &$c_comment_found_callback($. - $#lines, $., $1);
 201                 if($#lines <= 0) {
 202                     $_ = "$prefix $_";
 203                 } else {
 204                     $_ = $prefix . ("\n" x $#lines) . $_;
 205                 }
 206                 $again = 1;
 207             } else {
 208                 $_ = "$prefix$_";
 209                 $lookahead = 1;
 210             }
 211             next;
 212         }
 213
 214         # remove C++ comments
 215         while(s/^([^\"\/]*?(?:\"[^\"]*?\"[^\"]*?)*?)(\/\/.*?)$/$1/s) {
 216             &$cplusplus_comment_found_callback($., $2);
 217             $again = 1;
 218         }
 219         if($again) { next; }
 220
 221         # remove preprocessor directives
 222         if(s/^\s*\#/\#/s) {
 223             if(/^\#.*?\\$/s) {
 224                 $lookahead = 1;
 225                 next;
 226             } elsif(s/^\#\s*(\w+)((?:\s+(.*?))?\s*)$//s) {
 227                 my @lines = split(/\n/, $2);
 228                 if($#lines > 0) {
 229                     $_ = "\n" x $#lines;
 230                 }
 231                 if(defined($3)) {
 232                     &$preprocessor_found_callback($1, $3);
 233                 } else {
 234                     &$preprocessor_found_callback($1, "");
 235                 }
 236                 $again = 1;
 237                 next;
 238             }
 239         }
 240
 241         # Remove extern "C"
 242         if(s/^\s*extern\s+"C"\s+\{//m) {
 243             $extern_c = 1;
 244             $again = 1;
 245             next;
 246         }
 247
 248         my $documentation_line;
 249         my $documentation;
 250         my @argument_documentations = ();
 251         {
 252             my $n = $#comments;
 253             while($n >= 0 && ($comments[$n] !~ /^\/\*\*/ ||
 254                               $comments[$n] =~ /^\/\*\*+\/$/))
 255             {
 256                 $n--;
 257             }
 258
 259             if(defined($comments[$n]) && $n >= 0) {
 260                 my @lines = split(/\n/, $comments[$n]);
 261
 262                 $documentation_line = $comment_lines[$n] - scalar(@lines) + 1;
 263                 $documentation = $comments[$n];
 264
 265                 for(my $m=$n+1; $m <= $#comments; $m++) {
 266                     if($comments[$m] =~ /^\/\*\*+\/$/ ||
 267                        $comments[$m] =~ /^\/\*\s*(?:\!)?defined/) # FIXME: Kludge
 268                     {
 269                         @argument_documentations = ();
 270                         next;
 271                     }
 272                     push @argument_documentations, $comments[$m];
 273                 }
 274             } else {
 275                 $documentation = "";
 276             }
 277         }
 278
 279         if($level > 0)
 280         {
 281             my $line = "";
 282             while(/^[^\{\}]/) {
 283                 s/^([^\{\}\'\"]*)//s;
 284                 $line .= $1;
 285                 if(s/^\'//) {
 286                     $line .= "\'";
 287                     while(/^./ && !s/^\'//) {
 288                         s/^([^\'\\]*)//s;
 289                         $line .= $1;
 290                         if(s/^\\//) {
 291                             $line .= "\\";
 292                             if(s/^(.)//s) {
 293                                 $line .= $1;
 294                                 if($1 eq "0") {
 295                                     s/^(\d{0,3})//s;
 296                                     $line .= $1;
 297                                 }
 298                             }
 299                         }
 300                     }
 301                     $line .= "\'";
 302                 } elsif(s/^\"//) {
 303                     $line .= "\"";
 304                     while(/^./ && !s/^\"//) {
 305                         s/^([^\"\\]*)//s;
 306                         $line .= $1;
 307                         if(s/^\\//) {
 308                             $line .= "\\";
 309                             if(s/^(.)//s) {
 310                                 $line .= $1;
 311                                 if($1 eq "0") {
 312                                     s/^(\d{0,3})//s;
 313                                     $line .= $1;
 314                                 }
 315                             }
 316                         }
 317                     }
 318                     $line .= "\"";
 319                 }
 320             }
 321
 322             if(s/^\{//) {
 323                 $_ = $'; $again = 1;
 324                 $line .= "{";
 325                 print "+1: \{$_\n" if $options->debug >= 2;
 326                 $level++;
 327                 $statements .= $line;
 328             } elsif(s/^\}//) {
 329                 $_ = $'; $again = 1;
 330                 $line .= "}" if $level > 1;
 331                 print "-1: \}$_\n" if $options->debug >= 2;
 332                 $level--;
 333                 if($level == -1 && $extern_c) {
 334                     $extern_c = 0;
 335                     $level = 0;
 336                 }
 337                 $statements .= $line;
 338             } else {
 339                 $statements .= "$line\n";
 340             }
 341
 342             if($level == 0) {
 343                 if($in_function) {
 344                     &$function_end($statements_line, $statements);
 345                     $statements = undef;
 346                 } elsif($in_type) {
 347                     if(/^\s*(?:WINE_PACKED\s+)?((?:\*\s*)?\w+\s*(?:\s*,\s*(?:\*+\s*)?\w+)*\s*);/s) {
 348                         my @parts = split(/\s*,\s*/, $1);
 349                         &$type_end([@parts]);
 350                     } elsif(/;/s) {
 351                         die "$file: $.: syntax error: '$_'\n";
 352                     } else {
 353                         $lookahead = 1;
 354                     }
 355                 }
 356             }
 357             next;
 358         } elsif(/(extern\s+|static\s+)?((struct\s+|union\s+|enum\s+|signed\s+|unsigned\s+)?\w+((\s*\*)+\s*|\s+))
 359             ((__cdecl|__stdcall|CDECL|VFWAPIV|VFWAPI|WINAPIV|WINAPI|CALLBACK)\s+)?
 360             (\w+(\(\w+\))?)\s*\(([^\)]*)\)\s*(\{|\;)/sx)
 361         {
 362             my @lines = split(/\n/, $&);
 363             my $function_line = $. - scalar(@lines) + 1;
 364
 365             $_ = $'; $again = 1;
 366
 367             if($11 eq "{")  {
 368                 $level++;
 369             }
 370
 371             my $linkage = $1;
 372             my $return_type = $2;
 373             my $calling_convention = $7;
 374             my $name = $8;
 375             my $arguments = $10;
 376
 377             if(!defined($linkage)) {
 378                 $linkage = "";
 379             }
 380
 381             if(!defined($calling_convention)) {
 382                 $calling_convention = "";
 383             }
 384
 385             $linkage =~ s/\s*$//;
 386
 387             $return_type =~ s/\s*$//;
 388             $return_type =~ s/\s*\*\s*/*/g;
 389             $return_type =~ s/(\*+)/ $1/g;
 390
 391             if($regs_entrypoints{$name}) {
 392                 $name = $regs_entrypoints{$name};
 393             }
 394
 395             $arguments =~ y/\t\n/  /;
 396             $arguments =~ s/^\s*(.*?)\s*$/$1/;
 397             if($arguments eq "") { $arguments = "..." }
 398
 399             my @argument_types;
 400             my @argument_names;
 401             my @arguments = split(/,/, $arguments);
 402             foreach my $n (0..$#arguments) {
 403                 my $argument_type = "";
 404                 my $argument_name = "";
 405                 my $argument = $arguments[$n];
 406                 $argument =~ s/^\s*(.*?)\s*$/$1/;
 407                 # print "  " . ($n + 1) . ": '$argument'\n";
 408                 $argument =~ s/^(IN OUT(?=\s)|IN(?=\s)|OUT(?=\s)|\s*)\s*//;
 409                 $argument =~ s/^(const(?=\s)|CONST(?=\s)|\s*)\s*//;
 410                 if($argument =~ /^\.\.\.$/) {
 411                     $argument_type = "...";
 412                     $argument_name = "...";
 413                 } elsif($argument =~ /^
 414                         ((?:struct\s+|union\s+|enum\s+|(?:signed\s+|unsigned\s+)
 415                           (?:short\s+(?=int)|long\s+(?=int))?)?\w+)\s*
 416                         ((?:const)?\s*(?:\*\s*?)*)\s*
 417                         (?:WINE_UNUSED\s+)?(\w*)\s*(?:\[\]|\s+OPTIONAL)?/x)
 418                 {
 419                     $argument_type = "$1";
 420                     if($2 ne "") {
 421                         $argument_type .= " $2";
 422                     }
 423                     $argument_name = $3;
 424
 425                     $argument_type =~ s/\s*const\s*/ /;
 426                     $argument_type =~ s/^\s*(.*?)\s*$/$1/;
 427
 428                     $argument_name =~ s/^\s*(.*?)\s*$/$1/;
 429                 } else {
 430                     die "$file: $.: syntax error: '$argument'\n";
 431                 }
 432                 $argument_types[$n] = $argument_type;
 433                 $argument_names[$n] = $argument_name;
 434                 # print "  " . ($n + 1) . ": '" . $argument_types[$n] . "', '" . $argument_names[$n] . "'\n";
 435             }
 436             if($#argument_types == 0 && $argument_types[0] =~ /^void$/i) {
 437                 $#argument_types = -1;
 438                 $#argument_names = -1;
 439             }
 440
 441             if($options->debug) {
 442                 print "$file: $return_type $calling_convention $name(" . join(",", @arguments) . ")\n";
 443             }
 444
 445             &$function_begin($documentation_line, $documentation,
 446                              $function_line, $linkage, $return_type, $calling_convention, $name,
 447                              \@argument_types,\@argument_names,\@argument_documentations);
 448             if($level == 0) {
 449                 &$function_end(undef, undef);
 450             }
 451             $statements_line = $.;
 452             $statements = "";
 453         } elsif(/__ASM_GLOBAL_FUNC\(\s*(.*?)\s*,/s) {
 454             my @lines = split(/\n/, $&);
 455             my $function_line = $. - scalar(@lines) + 1;
 456
 457             $_ = $'; $again = 1;
 458
 459             &$function_begin($documentation_line, $documentation,
 460                              $function_line, "", "void", "__asm", $1);
 461             &$function_end($., "");
 462         } elsif(/WAVEIN_SHORTCUT_0\s*\(\s*(.*?)\s*,\s*(.*?)\s*\)/s) {
 463             my @lines = split(/\n/, $&);
 464             my $function_line = $. - scalar(@lines) + 1;
 465
 466             $_ = $'; $again = 1;
 467             my @arguments16 = ("HWAVEIN16");
 468             my @arguments32 = ("HWAVEIN");
 469             &$function_begin($documentation_line, $documentation,
 470                              $function_line,  "", "UINT16", "WINAPI", "waveIn" . $1 . "16", \@arguments16);
 471             &$function_end($., "");
 472             &$function_begin($documentation_line, $documentation,
 473                              $function_line, "", "UINT", "WINAPI", "waveIn" . $1, \@arguments32);
 474             &$function_end($., "");
 475         } elsif(/WAVEOUT_SHORTCUT_0\s*\(\s*(.*?)\s*,\s*(.*?)\s*\)/s) {
 476             my @lines = split(/\n/, $&);
 477             my $function_line = $. - scalar(@lines) + 1;
 478
 479             $_ = $'; $again = 1;
 480
 481             my @arguments16 = ("HWAVEOUT16");
 482             my @arguments32 = ("HWAVEOUT");
 483             &$function_begin($documentation_line, $documentation,
 484                              $function_line, "", "UINT16", "WINAPI", "waveOut" . $1 . "16", \@arguments16);
 485             &$function_end($., "");
 486             &$function_begin($documentation_line, $documentation,
 487                              $function_line, "", "UINT", "WINAPI", "waveOut" . $1, \@arguments32);
 488             &$function_end($., "");
 489         } elsif(/WAVEOUT_SHORTCUT_(1|2)\s*\(\s*(.*?)\s*,\s*(.*?)\s*,\s*(.*?)\s*\)/s) {
 490             my @lines = split(/\n/, $&);
 491             my $function_line = $. - scalar(@lines) + 1;
 492
 493             $_ = $'; $again = 1;
 494
 495             if($1 eq "1") {
 496                 my @arguments16 = ("HWAVEOUT16", $4);
 497                 my @arguments32 = ("HWAVEOUT", $4);
 498                 &$function_begin($documentation_line, $documentation,
 499                                  $function_line, "", "UINT16", "WINAPI", "waveOut" . $2 . "16", \@arguments16);
 500                 &$function_end($., "");
 501                 &$function_begin($documentation_line, $documentation,
 502                                  $function_line, "", "UINT", "WINAPI", "waveOut" . $2, \@arguments32);
 503                 &$function_end($., "");
 504             } elsif($1 eq 2) {
 505                 my @arguments16 = ("UINT16", $4);
 506                 my @arguments32 = ("UINT", $4);
 507                 &$function_begin($documentation_line, $documentation,
 508                                  $function_line, "", "UINT16", "WINAPI", "waveOut". $2 . "16", \@arguments16);
 509                 &$function_end($., "");
 510                 &$function_begin($documentation_line, $documentation,
 511                                  $function_line, "", "UINT", "WINAPI", "waveOut" . $2, \@arguments32);
 512                 &$function_end($., "");
 513             }
 514         } elsif(/DEFINE_REGS_ENTRYPOINT_\d+\(\s*(\S*)\s*,\s*([^\s,\)]*).*?\)/s) {
 515             $_ = $'; $again = 1;
 516             $regs_entrypoints{$2} = $1;
 517         } elsif(/DEFAULT_DEBUG_CHANNEL\s*\((\S+)\)/s) {
 518             $_ = $'; $again = 1;
 519             unshift @$debug_channels, $1;
 520         } elsif(/(DEFAULT|DECLARE)_DEBUG_CHANNEL\s*\((\S+)\)/s) {
 521             $_ = $'; $again = 1;
 522             push @$debug_channels, $1;
 523         } elsif(/typedef\s+(enum|struct|union)(?:\s+(\w+))?\s*\{/s) {
 524             $_ = $'; $again = 1;
 525             $level++;
 526             my $type = $1;
 527             if(defined($2)) {
 528                $type .= " $2";
 529             }
 530             &$type_begin($type);
 531         } elsif(/typedef\s+
 532                 ((?:const\s+|enum\s+|long\s+|signed\s+|short\s+|struct\s+|union\s+|unsigned\s+)*?)
 533                 (\w+)
 534                 (?:\s+const)?
 535                 ((?:\s*\*+\s*|\s+)\w+\s*(?:\[[^\]]*\])?
 536                 (?:\s*,\s*(?:\s*\*+\s*|\s+)\w+\s*(?:\[[^\]]*\])?)*)
 537                 \s*;/sx)
 538         {
 539             $_ = $'; $again = 1;
 540
 541             my $type = "$1 $2";
 542
 543             my @names;
 544             my @parts = split(/\s*,\s*/, $2);
 545             foreach my $part (@parts) {
 546                 if($part =~ /(?:\s*(\*+)\s*|\s+)(\w+)\s*(\[[^\]]*\])?/) {
 547                     my $name = $2;
 548                     if(defined($1)) {
 549                         $name = "$1$2";
 550                     }
 551                     if(defined($3)) {
 552                         $name .= $3;
 553                     }
 554                     push @names, $name;
 555                 }
 556             }
 557             &$type_begin($type);
 558             &$type_end([@names]);
 559         } elsif(/typedef\s+
 560                 (?:(?:const\s+|enum\s+|long\s+|signed\s+|short\s+|struct\s+|union\s+|unsigned\s+)*?)
 561                 (\w+(?:\s*\*+\s*)?)\s+
 562                 (?:(\w+)\s*)?
 563                 \((?:(\w+)\s+)?\s*\*\s*(\w+)\s*\)\s*
 564                 (?:\(([^\)]*)\)|\[([^\]]*)\])\s*;/sx)
 565         {
 566             $_ = $'; $again = 1;
 567             my $type;
 568             if(defined($2) || defined($3)) {
 569                 my $cc = $2 || $3;
 570                 if(defined($5)) {
 571                     $type = "$1 ($cc *)($5)";
 572                 } else {
 573                     $type = "$1 ($cc *)[$6]";
 574                 }
 575             } else {
 576                 if(defined($5)) {
 577                     $type = "$1 (*)($5)";
 578                 } else {
 579                     $type = "$1 (*)[$6]";
 580                 }
 581             }
 582             my $name = $4;
 583             &$type_begin($type);
 584             &$type_end([$name]);
 585         } elsif(/typedef[^\{;]*;/s) {
 586             $_ = $'; $again = 1;
 587             $output->write("$file: $.: can't parse: '$&'\n");
 588         } elsif(/typedef[^\{]*\{[^\}]*\}[^;];/s) {
 589             $_ = $'; $again = 1;
 590             $output->write("$file: $.: can't parse: '$&'\n");
 591         } elsif(/\'[^\']*\'/s) {
 592             $_ = $'; $again = 1;
 593         } elsif(/\"[^\"]*\"/s) {
 594             $_ = $'; $again = 1;
 595         } elsif(/;/s) {
 596             $_ = $'; $again = 1;
 597         } elsif(/extern\s+"C"\s+{/s) {
 598             $_ = $'; $again = 1;
 599         } elsif(/\{/s) {
 600             $_ = $'; $again = 1;
 601             print "+1: $_\n" if $options->debug >= 2;
 602             $level++;
 603         } else {
 604             $lookahead = 1;
 605         }
 606     }
 607     close(IN);
 608     print STDERR "done\n" if $options->verbose;
 609     $output->write("$file: not at toplevel at end of file\n") unless $level == 0;
 610 }
 611
 612 1;