Sweden-Number/tools/winapi/winapi_fixup

#!/usr/bin/perl -w

# Copyright 2001 Patrik Stridvall

use strict;

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

use config qw(
    &file_type &files_filter
    &file_skip &files_skip
    &file_normalize 
    &get_spec_files
    &translate_calling_convention16 &translate_calling_convention32
    $current_dir $wine_dir $winapi_dir $winapi_check_dir
);
use output;
use options;
use modules;
use util;
use winapi;
use winapi_parser;

my $output = output->new;

my %options_long = (
    "debug" => { default => 0, description => "debug mode" },
    "help" => { default => 0, description => "help mode" },
    "verbose" => { default => 0, description => "verbose mode" },

    "progress" => { default => 1, description => "show progress" },

    "win16" => { default => 1, description => "Win16 fixup" },
    "win32" => { default => 1, description => "Win32 fixup" },

    "local" =>  { default => 1, description => "local fixup" },
    "documentation" => { default => 1, parent => "local", description => "documentation fixup" },
    "documentation-ordinal" => { default => 0, parent => "documentation", description => "documentation ordinal fixup" },
    "documentation-missing" => { default => 0, parent => "documentation", description => "documentation missing fixup" },
    "documentation-name" => { default => 1, parent => "documentation", description => "documentation name fixup" },
    "stub" => { default => 0, parent => "local", description => "stub fixup" },

    "global" => { default => 1, description => "global fixup" },

    "modify" => { default => 0, description => "actually perform the fixups" },	    
);

my %options_short = (
    "d" => "debug",
    "?" => "help",
    "v" => "verbose"
);

my $options_usage = "usage: winapi_fixup [--help] [<files>]\n";

my $options = options->new(\%options_long, \%options_short, $options_usage);

my $modules = modules->new($options, $output, $wine_dir, $current_dir, \&file_type, "$winapi_check_dir/modules.dat");

my $win16api = winapi->new($options, $output, "win16", "$winapi_check_dir/win16");
my $win32api = winapi->new($options, $output, "win32", "$winapi_check_dir/win32");
my @winapis = ($win16api, $win32api);

if($wine_dir eq ".") {
    winapi->read_all_spec_files($modules, $wine_dir, $current_dir, \&file_type, $win16api, $win32api);
} else {
    my @spec_files = $modules->allowed_spec_files($wine_dir, $current_dir);
    winapi->read_spec_files($modules, $wine_dir, $current_dir, \@spec_files, $win16api, $win32api);
}

sub get_all_module_internal_ordinal {
    my $internal_name = shift;

    my @entries = ();
    foreach my $winapi (@winapis) {
	my @module = (); {
	    my $module = $winapi->function_internal_module($internal_name);
	    if(defined($module)) {
		@module = split(/ & /, $module);
	    }
	}
	my @ordinal = (); {
	    my $ordinal = $winapi->function_internal_ordinal($internal_name);
	    if(defined($ordinal)) {
		@ordinal = split(/ & /, $ordinal);
	    }
	}

	my $module;
	my $ordinal;
	while(defined($module = shift @module) && defined($ordinal = shift @ordinal)) {
	    push @entries, [$module, $ordinal];
	}
    }

    return @entries;
}

sub get_all_module_external_ordinal {
    my $external_name = shift;

    my @entries = ();
    foreach my $winapi (@winapis) {
	my @name = (); {
	    my $name = $winapi->function_external_name($external_name);
	    if(defined($name)) {
		@name = split(/ & /, $name);
	    }
	}
	my @module = (); {
	    my $module = $winapi->function_external_module($external_name);
	    if(defined($module)) {
		@module = split(/ & /, $module);
	    }
	}
	my @ordinal = (); {
	    my $ordinal = $winapi->function_external_ordinal($external_name);
	    if(defined($ordinal)) {
		@ordinal = split(/ & /, $ordinal);
	    }
	}

	my $name;
	my $module;
	my $ordinal;
	while(# defined($name = shift @name) &&
	      defined($module = shift @module) &&
	      defined($ordinal = shift @ordinal)) 
	{
	    push @entries, [$name, $module, $ordinal];
	}
    }

    return @entries;
}

sub normalize_set {
    local $_ = shift;

    if(!defined($_)) {
	return undef;
    }
    
    my %hash = ();
    foreach my $key (split(/\s*&\s*/)) {
	$hash{$key}++;
    }

    return join(" & ", sort(keys(%hash)));
}

my @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(@c_files);

foreach my $file (@c_files) {
    my %substitute_line;
    my %insert_line;

    my %spec_file;

    $progress_current++;
    if(options->progress) {
	output->progress("$file: file $progress_current of $progress_max");
    }

    my $found_function = sub {
	my $line = shift;
	my $refdebug_channels = shift;
	my @debug_channels = @$refdebug_channels;
	my $documentation = shift;
	my $linkage = shift;
	my $return_type = shift;
	my $calling_convention = shift;
	my $internal_name = shift;
	my $refargument_types = shift;
	my @argument_types = @$refargument_types;
	my $refargument_names = shift;
	my @argument_names = @$refargument_names;
	my $refargument_documentations = shift;
	my @argument_documentations = @$refargument_documentations;
	my $statements = shift;

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

	my $module16 = $win16api->function_internal_module($internal_name);
	my $module32 = $win32api->function_internal_module($internal_name);

	my $prefix = "";
	$prefix .= "$file: ";
	if(defined($module16) && !defined($module32)) {
	    $prefix .= normalize_set($module16) . ": ";
	} elsif(!defined($module16) && defined($module32)) {
	    $prefix .= normalize_set($module32) . ": ";
	} elsif(defined($module16) && defined($module32)) {
	    $prefix .= normalize_set($module16) . " & " . normalize_set($module32) . ": ";
	} else {
	    $prefix .= "<>: ";
	}
	$prefix .= "$return_type ";
	$prefix .= "$calling_convention " if $calling_convention;
	$prefix .= "$internal_name(" . join(",", @argument_types) . "): ";
	$output->prefix($prefix);

	my $calling_convention16 = translate_calling_convention16($calling_convention);
	my $calling_convention32 = translate_calling_convention32($calling_convention);

	my @external_names = ();
	foreach my $winapi (@winapis) {
	    my $external_names = $winapi->function_external_name($internal_name);
	    if(defined($external_names)) { 
		push @external_names, split(/\s*&\s*/, $external_names);
	    }
	}

	if(options->documentation_ordinal && $documentation) {
	    local $_;
	    foreach (split(/\n/, $documentation)) {
		if(/^(\s*\*\s*(\w+)\s*)(\s*(?:[\(\[]\s*\w+(?:\s*\.\s*\S*\s*)?[\)\]])+)(.*?)$/m) {
		    my $part1 = $1;
		    my $external_name = $2;
		    my $part3 = $3;
		    my $part4 = $4;

		    $part4 =~ s/\s*$//;

		    my @entries = ();
		    while($part3 =~ s/^\s*([\(\[]\s*(\w+)(?:\s*\.\s*(\S*)\s*)?[\)\]])//) {
			push @entries, [$1, lc($2), $3];
		    }

		    my $replaced = 0;
		    my $replace = "";
		    foreach my $entry (@entries) {
			(my $part, my $module, my $ordinal) = @$entry;
			foreach my $entry2 (get_all_module_external_ordinal($external_name)) {
			    (my $external_name2, my $module2, my $ordinal2) = @$entry2;
			    
			    if(defined($module2) && $module eq $module2 && 
			       (!defined($ordinal) || (defined($ordinal2) && $ordinal ne $ordinal2)))
			    {
				if(defined($ordinal)) {
				    if($part =~ s/\U$module\E\s*.\s*\Q$ordinal\E/\U$module2\E.$ordinal2/) {
					$replaced++;
				    }
				} else {
				    if($part =~ s/\U$module\E/\U$module2\E.$ordinal2/) {
					$replaced++;
				    }
				}
			    }
			}
			if($replace) { $replace .= "\n"; }
			$replace .= "$part1$part$part4";
		    }

		    if($replaced > 0) {
			$substitute_line{$_}{search} = "^\Q$_\E\$";
			$substitute_line{$_}{replace} = "$replace";
		    }
		} elsif(/^(\s*\*\s*)(\w+)\s*$/m) {
		    my $part1 = $1;
		    my $external_name = $2;
		    if($internal_name eq $external_name) {
			foreach my $entry (get_all_module_external_ordinal($external_name)) {
			    (my $external_name2, my $module, my $ordinal) = @$entry;

			    # FIXME: Not correct
			    $substitute_line{$_}{search} = "^\Q$_\E\$";
			    $substitute_line{$_}{replace} = "$part1$external_name (\U$module\E.$ordinal)";
			}
		    }
		}
	    }
	}

	if(options->documentation_name && $documentation) {
	    local $_;

	    my @entries = ();
	    foreach (split(/\n/, $documentation)) {
		if(/^(\s*\*\s*(\w+)\s*)(\s*(?:[\(\[]\s*\w+(?:\s*\.\s*\S+\s*)?[\)\]])+)(.*?)$/m) {
		    my $part1 = $1;
		    my $external_name2 = $2;
		    my $part3 = $3;
		    my $part4 = $4;

		    $part4 =~ s/\s*$//;

		    push @entries, [$part1, $external_name2, $part3, $part4];
		}
	    }
	    
	    my @missing_external_names = ();
	    foreach my $external_name (@external_names) {
		my $found = 0;
		foreach my $entry (@entries) {
		    my $part1 = $entry->[0];
		    my $external_name2 = $entry->[1];
		    my $part3 = $entry->[2];
		    my $part4 = $entry->[3];

		    if($external_name eq $external_name2) {
			$found = 1;
		    }
		}
		if(!$found) {
		    push @missing_external_names, $external_name;
		}
	    }

	    foreach my $external_name (@missing_external_names) {
		my $internal_name2 = $internal_name;
		my $external_name2 = $external_name;

		if($internal_name =~ /^(.*?)$external_name(.*?)$/) {
		    my $prefix = $1;
		    my $suffix = $2;

		    my $part1;
		    my $part3;
		    my $external_name2;
		    my $part4;

		    foreach my $entry (@entries) {
			$part1 = $entry->[0];
			$external_name2 = $entry->[1];
			$part3 = $entry->[2];
			$part4 = $entry->[3];

			if($internal_name =~ /^(.*?)$external_name(.*?)$/) {
			    last;
			}
		    }

		    foreach (split(/\n/, $documentation)) {
			if(/\Q$external_name\E/) {
			    if($suffix =~ /^16$/) {
				$substitute_line{$_}{search} = "\Q$internal_name\E";
				$substitute_line{$_}{replace} = "$external_name";
				last;
			    } elsif($suffix =~ /^[AW]$/) {
				$substitute_line{$_}{search} = "^\Q$_\E\$";

				# FIXME: Not correct
				my $replace  = "";
				
				$part3 =~ /^\s*[\(\[]\s*(\w+)(?:\s*\.\s*(\S*)\s*)?[\)\]]/;
				my $module = lc($1);
				my $ordinal = $2;

				foreach my $entry2 (get_all_module_external_ordinal($external_name)) {
				    (my $external_name2, my $module2, my $ordinal2) = @$entry2;

				    my $part12 = $part1;
				    $part12 =~ s/[AW](\s*)$/ $1/;

				    my $part32 = $part3;

				    if($module ne $module2 || $ordinal ne $ordinal2) {
					$part32 =~ s/\U$module\E\s*.\s*\Q$ordinal\E/\U$module2\E.$ordinal2/;
					$replace = "$part12$part32$part4";
				    }
				}

				if($replace) {
				    $replace .= "\n$part1$part3$part4";
				    $substitute_line{$_}{replace} = $replace;
				    last;
				}
			    }

			}

		    }
		} else {
		    output->write("$external_name missing\n");
		}
	    }
	}

	if(options->documentation_missing && !$documentation) {
	    # FIXME: Not correct

	    my $external_name;
	    my $module;
	    my $ordinal;
	    foreach my $winapi (@winapis) {
		$external_name = ($winapi->function_external_name($internal_name) || $external_name);
		$module = ($winapi->function_internal_module($internal_name) || $module);
		$ordinal = ($winapi->function_internal_ordinal($internal_name) || $ordinal);
		if(defined($external_name) || defined($module) || defined($ordinal)) { last; }
	    }

	    if(defined($external_name) && defined($module) && defined($ordinal)) {
		$insert_line{$line} = 
		    "/" . "*" x 71 . "\n" .
		    " *\t\t$external_name (\U$module\E.$ordinal)\n" .
		    " */\n";
	    }
	}

	if(options->stub) {
	    # FIXME: Not correct
	    foreach my $winapi (@winapis) {
		if($winapi->function_stub($internal_name)) {
		    my $module = $winapi->function_internal_module($internal_name);
		    my $ordinal = $winapi->function_internal_ordinal($internal_name);

		    my $external_name = $internal_name;
		    if($winapi->name eq "win16") {
			$external_name =~ s/(?:_)?16([AW]?)$//;
			if(defined($1)) {
			    $external_name .= $1;
			}
		    }

		    my $abort = 0;
		    my $n;
		    my @argument_kinds = map {
			my $type = $_;
			my $kind = "unknown";
			$winapi->type_used_in_module($type, $module);
			if(!defined($kind = $winapi->translate_argument($type))) {
			    output->write("no translation defined: " . $type . "\n");
			}

			# FIXME: Kludge
			if(defined($kind) && $kind eq "longlong") {
			    $n += 2;
			    ("long", "long");
			} elsif(defined($kind)) {
			    $n++;
			    $kind;
			} else {
			    $abort = 1;
			    $n++;
			    "undef";
			}
		    } @argument_types;

		    my $substitute = {};
		    $substitute->{search} = "^\\s*$ordinal\\s+stub\\s+$external_name\\s*(?:#.*?)?\$";

		    if($winapi->name eq "win16") {
			$substitute->{replace} = "$ordinal $calling_convention16 $external_name(@argument_kinds) $internal_name";
		    } else {
			$substitute->{replace} = "$ordinal $calling_convention32 $external_name(@argument_kinds) $internal_name";
		    }

		    if(!defined($spec_file{$module})) {
			$spec_file{$module} = [];
		    }

		    if(!$abort) {
			push @{$spec_file{$module}}, $substitute;
		    }
		}	    
	    }
	}
	$output->prefix("");
    };

    my $found_preprocessor = sub {
	my $directive = shift;
	my $argument = shift;
    };

    winapi_parser::parse_c_file $options, $output, $file, $found_function, $found_preprocessor;

    my $editor = sub {
	local *IN = shift;
	local *OUT = shift;

	my $modified = 0;
	while(<IN>) {
	    chomp;

	    my $line = $insert_line{$.};
	    if(defined($line)) {
		if(options->modify) {
		    $_ = "$line$_";
		    $modified = 1;
		} else {
		    output->write("$file: $.: insert : '$line'\n");
		}
	    }

	    my $search = $substitute_line{$_}{search};
	    my $replace = $substitute_line{$_}{replace};
	    
	    if(defined($search) && defined($replace)) {
		my $modified2 = 0;
		if(options->modify) {
		    if(s/$search/$replace/) {
			$modified = 1;
			$modified2 = 1;
		    }
		}

		if(!options->modify || !$modified2) {
		    my $search2;
		    my $replace2;
		    if(options->modify && !$modified2) {
			$search2 = "unmatched search"; 
			$replace2 = "unmatched replace"; 
		    } else {
			$search2 = "search"; 
			$replace2 = "replace";
		    }
		    output->write("$file: $.: $search2 : '$search'\n");
		    
		    my @replace2 = split(/\n/, $replace);
		    if($#replace2 > 0) {
			output->write("$file: $.: $replace2: \\\n");
			foreach my $replace2 (@replace2) {
			    output->write("'$replace2'\n");
			}
		    } else {
			output->write("$file: $.: $replace2: '$replace'\n");
		    }
		}
	    }
	    print OUT "$_\n";
	}

	return $modified;
    };

    my $n = 0; while(defined(each %substitute_line)) { $n++; }
    if($n > 0) {
	edit_file($file, $editor);
    }

    foreach my $module (sort(keys(%spec_file))) {
	my $file; 
	foreach my $winapi (@winapis) {
	    $file = ($winapi->module_file($module) || $file);
	}

	if(defined($file)) {
	    $file = file_normalize($file);
	}

	my @substitutes = @{$spec_file{$module}};

	my $editor = sub {
	    local *IN = shift;
	    local *OUT = shift;
	    
	    my $modified = 0;
	    while(<IN>) {
		chomp;

		my @substitutes2 = ();
		foreach my $substitute (@substitutes) {
		    my $search = $substitute->{search};
		    my $replace = $substitute->{replace};

		    if(s/$search/$replace/) {
			if(options->modify) {
			    $modified = 1;
			} else {    
			    output->write("$file: search : '$search'\n");
			    output->write("$file: replace: '$replace'\n");
			}
			next;
		    } else {
			push @substitutes2, $substitute;
		    }
		}
		@substitutes = @substitutes2;

		print OUT "$_\n";
	    }
	    
	    return $modified;
	};

	if(defined($file)) {
	    edit_file($file, $editor);
	} else {
	    output->write("$module: doesn't have any spec file\n");
	}

	if($#substitutes >= 0) {
	    foreach my $substitute (@substitutes) {
		my $search = $substitute->{search};
		my $replace = $substitute->{replace};

		output->write("$file: unmatched search : '$search'\n");
		output->write("$file: unmatched replace: '$replace'\n");
	    }
	}

    }
}

output->hide_progress;