tools/winapi/winapi_extract

#!/usr/bin/perl -w

# Copyright 2002 Patrik Stridvall
#
# This library is free software; you can redistribute it and/or
# modify it under the terms of the GNU Lesser General Public
# License as published by the Free Software Foundation; either
# version 2.1 of the License, or (at your option) any later version.
#
# This library is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
# Lesser General Public License for more details.
#
# You should have received a copy of the GNU Lesser General Public
# License along with this library; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#

use strict;

BEGIN {
    $0 =~ m%^(.*?/?tools)/winapi/winapi_extract$%;
    require "$1/winapi/setup.pm";
}

use config qw(
    &file_type &files_skip &files_filter &get_spec_files
    $current_dir $wine_dir $winapi_dir $winapi_check_dir
);
use output qw($output);
use winapi_extract_options qw($options);

if($options->progress) {
    $output->enable_progress;
} else {
    $output->disable_progress;
}

use c_parser;
use function;
use type;

use winapi_c_parser;
use winapi_function;

use vars qw($win16api $win32api @winapis);
if ($options->spec_files || $options->implemented || $options->stub_statistics || $options->winetest) {
    require winapi;
    import winapi qw($win16api $win32api @winapis);
}

my %module2entries;
my %module2spec_file;
if($options->spec_files || $options->winetest) {
    local $_;

    foreach my $spec_file (get_spec_files("winelib")) {
	my $entries = [];

	my $module = $spec_file;
	$module =~ s/^.*?([^\/]*)\.spec$/$1/;

	my $type = "win32";

	open(IN, "< $wine_dir/$spec_file");

	my $header = 1;
	my $lookahead = 0;
	while($lookahead || defined($_ = <IN>)) {
	    $lookahead = 0;

	    s/^\s*?(.*?)\s*$/$1/; # remove whitespace at begining and end of line
	    s/^(.*?)\s*#.*$/$1/;  # remove comments
	    /^$/ && next;         # skip empty lines

	    if($header)  {
	        if(/^(?:\d+|@)/) {
		    $header = 0;
		    $lookahead = 1;
		}
		next;
	    }

	    if(/^(\d+|@)\s+stdcall\s+(\w+)\s*\(\s*([^\)]*)\s*\)/) {
		my $ordinal = $1;
		my $name = $2;
		my @args = split(/\s+/, $3);

		push @$entries, [$name, "undef", \@args];
	    }
	}
	close(IN);

	$module2spec_file{$module} = $spec_file;
	$module2entries{$module} = $entries;
    }
}

my %specifications;

sub documentation_specifications {
    my $function = shift;

    my @debug_channels = @{$function->debug_channels};
    my $documentation = $function->documentation;
    my $documentation_line = $function->documentation_line;
    my $return_type = $function->return_type;
    my $linkage = $function->linkage;
    my $internal_name = $function->internal_name;

    if($linkage eq "static") {
	return;
    }

    local $_;
    foreach (split(/\n/, $documentation)) {
	if(/^\s*\*\s*(\S+)\s*[\(\[]\s*(\w+)\s*\.\s*(\S+)\s*[\)\]]/) {
	    my $external_name = $1;
	    my $module = lc($2);
	    my $ordinal = $3;

	    if($ordinal eq "@") {
		if(1 || !exists($specifications{$module}{unfixed}{$external_name})) {
		    $specifications{$module}{unfixed}{$external_name}{ordinal} = $ordinal;
		    $specifications{$module}{unfixed}{$external_name}{external_name} = $external_name;
		    $specifications{$module}{unfixed}{$external_name}{function} = $function;
		} else {
		    $output->write("$external_name ($module.$ordinal) already exists\n");
		}
	    } elsif($ordinal =~ /^\d+$/) {
		if(1 || !exists($specifications{$module}{fixed}{$ordinal})) {
		    $specifications{$module}{fixed}{$ordinal}{ordinal} = $ordinal;
		    $specifications{$module}{fixed}{$ordinal}{external_name} = $external_name;
		    $specifications{$module}{fixed}{$ordinal}{function} = $function;
		    } else {
			$output->write("$external_name ($module.$ordinal) already exists\n");
		    }
	    } elsif($ordinal eq "init") {
		if(!exists($specifications{$module}{init})) {
		    $specifications{$module}{init}{function} = $function;
		} else {
		    $output->write("$external_name ($module.$ordinal) already exists\n");
		}
	    } else {
		if(!exists($specifications{$module}{unknown}{$external_name})) {
		    $specifications{$module}{unknown}{$external_name}{ordinal} = $ordinal;
		    $specifications{$module}{unknown}{$external_name}{external_name} = $external_name;
		    $specifications{$module}{unknown}{$external_name}{function} = $function;
		} else {
		    $output->write("$external_name ($module.$ordinal) already exists\n");
		}
	    }

	    if($options->debug) {
		$output->write("$external_name ($module.$ordinal)\n");
	    }
	}
    }
}

my %module_pseudo_stub;

sub statements_pseudo_stub {
    my $function = shift;

    my $pseudo_stub = 0;
    my $statements = $function->statements;
    if(defined($statements) && $statements =~ /FIXME[^;]*stub/s) {
	if($options->win16) {
	    my $external_name16 = $function->external_name16;
	    foreach my $module16 ($function->modules16) {
		$module_pseudo_stub{$module16}{$external_name16}++;
		$pseudo_stub = 1;
	    }
	}
	if($options->win32) {
	    my $external_name32 = $function->external_name32;
	    foreach my $module32 ($function->modules32) {
		$module_pseudo_stub{$module32}{$external_name32}++;
		$pseudo_stub = 1;
	    }
	}
    }

    return $pseudo_stub;
}

my @h_files = ();
if($options->headers) {
    @h_files = $options->h_files;
    @h_files = files_skip(@h_files);
    @h_files = files_filter("winelib", @h_files);
}

my @c_files = ();
if($options->spec_files || $options->pseudo_implemented || $options->pseudo_stub_statistics) {
    @c_files = $options->c_files;
    @c_files = files_skip(@c_files);
    @c_files = files_filter("winelib", @c_files);
}

my $progress_output;
my $progress_current = 0;
my $progress_max = scalar(@h_files) + scalar(@c_files);

foreach my $file (@h_files, @c_files) {
    my %functions;

    $progress_current++;

    {
	open(IN, "< $file");
	local $/ = undef;
	$_ = <IN>;
	close(IN);
    }

    my $max_line = 0;
    {
      local $_ = $_;
      while(s/^.*?\n//) { $max_line++; }
      if($_) { $max_line++; }
    }

    my $parser;
    if (!$options->old) {
	$parser = new c_parser($file);
    } else {
	$parser = new winapi_c_parser($file);
    }

    my $function;
    my $line;

    my $update_output = sub {
	my $progress = "";
	my $prefix = "";

	$progress .= "$file (file $progress_current of $progress_max)";
	$prefix .= "$file:";

	if(defined($function)) {
	    my $name = $function->name;
	    my $begin_line = $function->begin_line;
	    my $begin_column = $function->begin_column;

	    $progress .= ": function $name";
	    $prefix .= "$begin_line.$begin_column: function $name: ";
	} else {
	    $prefix .= " "; 
	}

	if(defined($line)) {
	    $progress .= ": line $line of $max_line";
	}

	$output->progress($progress);
	$output->prefix($prefix);
    };

    &$update_output();

    my $found_function = sub {
	$function = shift;

	my $name = $function->name;
	$functions{$name} = $function;

	if ($function->statements) {
	    &$update_output();
	}

	my $old_function;
	if($options->implemented || $options->stub_statistics) {
	    $old_function = 'winapi_function'->new;
	} else {
	    $old_function = 'function'->new;
	}

	$old_function->file($function->file);
	$old_function->debug_channels([]); # FIXME: Not complete

	$old_function->documentation_line(0); # FIXME: Not complete
	$old_function->documentation(""); # FIXME: Not complete

	$old_function->function_line($function->begin_line());
	$old_function->linkage($function->linkage);
	$old_function->return_type($function->return_type);
	$old_function->calling_convention($function->calling_convention);
	$old_function->internal_name($function->name);
	if (defined($function->argument_types)) {
	    $old_function->argument_types([@{$function->argument_types}]);
	}
	if (defined($function->argument_names)) {
	    $old_function->argument_names([@{$function->argument_names}]);
	}
	$old_function->argument_documentations([]); # FIXME: Not complete
	$old_function->statements_line($function->statements_line);
	$old_function->statements($function->statements);

	if($options->spec_files || $options->winetest) {
	    documentation_specifications($old_function);
	}

	if ($function->statements) {
	    $function = undef;
	    &$update_output();
	} else {
	    $function = undef;
	}

	my $pseudo_stub = 0;
	if ($options->pseudo_implemented || $options->pseudo_stub_statistics) {
	    $pseudo_stub = statements_pseudo_stub($old_function);
	}

	my $module = $old_function->module;
	my $external_name = $old_function->external_name;
	my $statements = $old_function->statements;
	if ($options->pseudo_implemented && $module && $external_name && $statements) {
	    my @external_names = split(/\s*&\s*/, $external_name);
	    my @modules = split(/\s*&\s*/, $module);

	    my @external_names2;
	    while(defined(my $external_name = shift @external_names) &&
		  defined(my $module = shift @modules))
	    {
		if ($pseudo_stub) {
		    $output->write("$module.$external_name: pseudo implemented\n");
		} else {
		    $output->write("$module.$external_name: implemented\n");
		}
	    }
	}
    };
    $parser->set_found_function_callback($found_function);

    my $found_line = sub {
	$line = shift;

	&$update_output;
    };
    $parser->set_found_line_callback($found_line);

    my $found_type = sub {
	my $type = shift;

	&$update_output();
	
	my $kind = $type->kind;
	my $_name = $type->_name;
	my $name = $type->name;
	
	foreach my $field ($type->fields) {
	    my $field_type_name = $field->type_name;
	    my $field_name = $field->name;

	    if ($options->struct && $kind =~ /^(?:struct|union)$/) {
		if ($name) {
		    $output->write("$name:$field_type_name:$field_name\n");
		} else {
		    $output->write("$kind $_name:$field_type_name:$field_name\n");
		}
	    }
	}

	return 1;
    };
    $parser->set_found_type_callback($found_type);

    {
	my $line = 1;
	my $column = 0;
	if(!$parser->parse_c_file(\$_, \$line, \$column)) {
	    $output->write("can't parse file\n");
	}
    }

    $output->prefix("");
}


if($options->implemented && !$options->pseudo_implemented) {
    foreach my $winapi (@winapis) {
	my $type = $winapi->name;

	if($type eq "win16" && !$options->win16) { next; }
	if($type eq "win32" && !$options->win32) { next; }

	foreach my $module ($winapi->all_modules) {
	    foreach my $external_name ($winapi->all_functions_in_module($module)) {
		 my $external_calling_convention =
		     $winapi->function_external_calling_convention_in_module($module, $external_name);

		 if($external_calling_convention eq "forward") {
		     (my $forward_module, my $forward_external_name) =
			 $winapi->function_forward_final_destination($module, $external_name);

		     my $forward_external_calling_convention =
			 $winapi->function_external_calling_convention_in_module($forward_module, $forward_external_name);

		     if(!defined($forward_external_calling_convention)) {
			 next;
		     }

		     $external_calling_convention = $forward_external_calling_convention;
		 }

		 if ($external_calling_convention ne "stub") {
		     $output->write("*.spec: $module.$external_name: implemented\n");
		 }
	    }
	}
    }
}

sub output_function {
    local *OUT = shift;
    my $type = shift;
    my $ordinal = shift;
    my $external_name = shift;
    my $function = shift;

    my $internal_name = $function->internal_name;

    my $return_kind;
    my $calling_convention;
    my $refargument_kinds;
    if($type eq "win16") {
	$return_kind = $function->return_kind16 || "undef";
	$calling_convention = $function->calling_convention16 || "undef";
	$refargument_kinds = $function->argument_kinds16;
    } elsif($type eq "win32") {
	$return_kind = $function->return_kind32 || "undef";
	$calling_convention = $function->calling_convention32 || "undef";
	$refargument_kinds = $function->argument_kinds32;
    }

    if(defined($refargument_kinds)) {
	my @argument_kinds = map { $_ || "undef"; } @$refargument_kinds;
	print OUT "$ordinal $calling_convention $external_name(@argument_kinds) $internal_name\n";
    } else {
	print OUT "$ordinal $calling_convention $external_name() $internal_name # FIXME: arguments undefined\n";
    }
}

if($options->spec_files) {
    foreach my $winapi (@winapis) {
	my $type = $winapi->name;

	if($type eq "win16" && !$options->win16) { next; }
	if($type eq "win32" && !$options->win32) { next; }

	foreach my $module ($winapi->all_modules) {
	    my $spec_file = $module2spec_file{$module};

	    if(!defined($spec_file) || !defined($type)) {
		$output->write("$module: doesn't exist\n");
		next;
	    }

	    $spec_file .= "2";

	    $output->progress("$spec_file");
	    open(OUT, "> $wine_dir/$spec_file");

	    if(exists($specifications{$module}{init})) {
		my $function = $specifications{$module}{init}{function};
		print OUT "init " . $function->internal_name . "\n";
	    }
	    print OUT "\n";

	    my %debug_channels;
	    if(exists($specifications{$module}{init})) {
		my $function = $specifications{$module}{init}{function};
		foreach my $debug_channel (@{$function->debug_channels}) {
		    $debug_channels{$debug_channel}++;
		}
	    }
	    foreach my $ordinal (sort {$a <=> $b} keys(%{$specifications{$module}{fixed}})) {
		my $function = $specifications{$module}{fixed}{$ordinal}{function};
		foreach my $debug_channel (@{$function->debug_channels}) {
		    $debug_channels{$debug_channel}++;
		}
	    }
	    foreach my $name (sort(keys(%{$specifications{$module}{unfixed}}))) {
		my $function = $specifications{$module}{unfixed}{$name}{function};
		foreach my $debug_channel (@{$function->debug_channels}) {
		    $debug_channels{$debug_channel}++;
		}
	    }
	    foreach my $name (sort(keys(%{$specifications{$module}{unknown}}))) {
		my $function = $specifications{$module}{unknown}{$name}{function};
		foreach my $debug_channel (@{$function->debug_channels}) {
		    $debug_channels{$debug_channel}++;
		}
	    }

	    my @debug_channels = sort(keys(%debug_channels));
	    if($#debug_channels >= 0) {
		print OUT "debug_channels (" .  join(" ", @debug_channels) . ")\n";
		print OUT "\n";
	    }

	    my $empty = 1;

	    if(!$empty) {
		print OUT "\n";
		$empty = 1;
	    }
	    foreach my $external_name (sort(keys(%{$specifications{$module}{unknown}}))) {
		my $entry = $specifications{$module}{unknown}{$external_name};
		my $ordinal = $entry->{ordinal};
		my $function = $entry->{function};
		print OUT "# ";
		output_function(\*OUT, $type, $ordinal, $external_name, $function);
		$empty = 0;
	    }

	    if(!$empty) {
		print OUT "\n";
		$empty = 1;
	    }
	    foreach my $ordinal (sort {$a <=> $b} keys(%{$specifications{$module}{fixed}})) {
		my $entry = $specifications{$module}{fixed}{$ordinal};
		my $external_name = $entry->{external_name};
		my $function = $entry->{function};
		output_function(\*OUT, $type, $ordinal, $external_name, $function);
		$empty = 0;
	    }

	    if(!$empty) {
		print OUT "\n";
		$empty = 1;
	    }
	    foreach my $external_name (sort(keys(%{$specifications{$module}{unfixed}}))) {
		my $entry = $specifications{$module}{unfixed}{$external_name};
		my $ordinal = $entry->{ordinal};
		my $function = $entry->{function};
		output_function(\*OUT, $type, $ordinal, $external_name, $function);
		$empty = 0;
	    }

	    close(OUT);
	}
    }
}

if($options->stub_statistics) {
    foreach my $winapi (@winapis) {
	my $type = $winapi->name;

	if($type eq "win16" && !$options->win16) { next; }
	if($type eq "win32" && !$options->win32) { next; }

 	my %module_counts;
         foreach my $module ($winapi->all_modules) {
             foreach my $external_name ($winapi->all_functions_in_module($module)) {
		 my $external_calling_convention =
		     $winapi->function_external_calling_convention_in_module($module, $external_name);
		 if($external_calling_convention !~ /^(?:forward|stub)$/) {
		     if($module_pseudo_stub{$module}{$external_name}) {
			 $external_calling_convention = "pseudo_stub";
		     }
		 } elsif($external_calling_convention eq "forward") {
		     (my $forward_module, my $forward_external_name) =
			 $winapi->function_forward_final_destination($module, $external_name);

		     my $forward_external_calling_convention =
			 $winapi->function_external_calling_convention_in_module($forward_module, $forward_external_name);

		     if(!defined($forward_external_calling_convention)) {
			 next;
		     }

		     if($forward_external_calling_convention ne "stub" &&
			$module_pseudo_stub{$forward_module}{$forward_external_name})
		     {
			 $forward_external_calling_convention = "pseudo_stub";
		     }

		     $external_calling_convention = "forward_$forward_external_calling_convention";
		 }

		 $module_counts{$module}{$external_calling_convention}++;
	     }
	 }

	foreach my $module ($winapi->all_modules) {
 	    my $pseudo_stubs = $module_counts{$module}{pseudo_stub} || 0;
 	    my $real_stubs = $module_counts{$module}{stub} || 0;
 	    my $forward_pseudo_stubs = $module_counts{$module}{forward_pseudo_stub} || 0;
 	    my $forward_real_stubs = $module_counts{$module}{forward_stub} || 0;

 	    my $forwards = 0;
 	    my $total = 0;
	    foreach my $calling_convention (keys(%{$module_counts{$module}})) {
		my $count = $module_counts{$module}{$calling_convention};
		if($calling_convention =~ /^forward/) {
		    $forwards += $count;
		}
		$total += $count;
	    }

	    if($total > 0) {
		my $stubs = $real_stubs + $pseudo_stubs;

		$output->write("*.c: $module: ");
		$output->write("$stubs of $total functions are stubs ($real_stubs real, $pseudo_stubs pseudo) " .
			       "and $forwards are forwards\n");
	    }

	    if($forwards > 0) {
		my $forward_stubs = $forward_real_stubs + $forward_pseudo_stubs;

		$output->write("*.c: $module: ");
		$output->write("$forward_stubs of $forwards forwarded functions are stubs " .
			       "($forward_real_stubs real, $forward_pseudo_stubs pseudo)\n");
	    }
	}
    }
}

if($options->winetest) {
    foreach my $module ($win32api->all_modules) {
	my $type = "win32";

        my $package = $module;
	$package =~ s/\.dll$//;
        $package =~ s/\./_/g;

	my @entries;

	foreach my $external_name (sort(keys(%{$specifications{$module}{unknown}}))) {
	    my $entry = $specifications{$module}{unknown}{$external_name};
	    push @entries, $entry;
	}

	foreach my $ordinal (sort {$a <=> $b} keys(%{$specifications{$module}{fixed}})) {
	    my $entry = $specifications{$module}{fixed}{$ordinal};
	    push @entries, $entry;
	}

	foreach my $external_name (sort(keys(%{$specifications{$module}{unfixed}}))) {
	    my $entry = $specifications{$module}{unfixed}{$external_name};
	    push @entries, $entry;
	}

	my $n = 0;
	foreach my $entry (@entries) {
	    my $external_name = $entry->{external_name};
	    my $ordinal = $entry->{ordinal};
	    my $function = $entry->{function};

	    my $return_kind = $function->return_kind32 || "undef";
	    my $calling_convention = $function->calling_convention32 || "undef";
	    my $refargument_kinds = $function->argument_kinds32;

	    my @argument_kinds;
	    if(defined($refargument_kinds)) {
		@argument_kinds = map { $_ || "undef"; } @$refargument_kinds;
	    }

	    next if $calling_convention ne "stdcall";
	    next if $external_name eq "\@";

	    if($n == 0) {
                open(OUT, "> $wine_dir/programs/winetest/include/${package}.pm");

                print OUT "package ${package};\n";
                print OUT "\n";

                print OUT "use strict;\n";
                print OUT "\n";

                print OUT "require Exporter;\n";
                print OUT "\n";

                print OUT "use wine;\n";
                print OUT "use vars qw(\@ISA \@EXPORT \@EXPORT_OK);\n";
                print OUT "\n";

                print OUT "\@ISA = qw(Exporter);\n";
                print OUT "\@EXPORT = qw();\n";
                print OUT "\@EXPORT_OK = qw();\n";
                print OUT "\n";

                print OUT "my \$module_declarations = {\n";
	    } elsif($n > 0) {
		print OUT ",\n";
	    }

	    print OUT "    \"\Q$external_name\E\" => [\"$return_kind\",  [";
	    my $m = 0;
	    foreach my $argument_kind (@argument_kinds) {
		if($m > 0) {
		    print OUT ", ";
		}
		print OUT "\"$argument_kind\"";
		$m++;
	    }
	    print OUT "]]";
	    $n++;
	}

	if($n > 0) {
	    print OUT "\n";
	    print OUT "};\n";
	    print OUT "\n";
            print OUT "&wine::declare(\"$module\",\%\$module_declarations);\n";
            print OUT "push \@EXPORT, map { \"&\" . \$_; } sort(keys(\%\$module_declarations));\n";
	    print OUT "1;\n";
            close(OUT);
	}
    }
}