Sweden-Number/tools/winapi/winapi_extract

#!/usr/bin/perl -w

# Copyright 2001 Patrik Stridvall

use strict;

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

use config qw(
    &file_type &file_skip &files_skip &get_spec_files
    $current_dir $wine_dir $winapi_dir $winapi_check_dir
);
use output;
use options;
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 extraction" },
    "win32" => { default => 1, description => "Win32 extraction" },

    "local" =>  { default => 1, description => "local extraction" },
    "global" => { default => 1, description => "global extraction" },

    "spec-files" => { default => 1, parent => "global", description => "spec files extraction" },
);

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

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

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

my %module2spec_file;
my %module2type;
{
    local $_;

    foreach my $spec_file (get_spec_files) {
	my $module;
	my $type;

	open(IN, "< $wine_dir/$spec_file");
	while(<IN>) {
	    s/^\s*?(.*?)\s*$/$1/; # remove whitespace at begining and end of line
	    s/^(.*?)\s*#.*$/$1/;  # remove comments
	    /^$/ && next;         # skip empty lines

	    if(/^name\s+(.*?)$/) {
		$module = $1;
		$module2spec_file{$module} = $spec_file;
	    } elsif(/^type\s+(.*?)$/) {
		$type = $1;
		$module2type{$module} = $type;
	    }
	}
	close(IN);
    }
}

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);

my %specifications;

my @files = files_skip($options->c_files);

my $progress_output;
my $progress_current = 0;
my $progress_max = scalar(@files);

foreach my $file (@files) {
    my $functions = 0;

    $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;

	$functions++;

	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}{debug_channels} = [@debug_channels];
			$specifications{$module}{unfixed}{$external_name}{internal_name} = $internal_name;
			$specifications{$module}{unfixed}{$external_name}{external_name} = $external_name;
			$specifications{$module}{unfixed}{$external_name}{ordinal} = $ordinal;
			$specifications{$module}{unfixed}{$external_name}{return_type} = $return_type;
			$specifications{$module}{unfixed}{$external_name}{argument_types} = [@argument_types];
		    } else {
			output->write("$file: $external_name ($module.$ordinal) already exists\n");
		    }
		} elsif($ordinal =~ /^\d+$/) {
		    if(1 || !exists($specifications{$module}{fixed}{$ordinal})) {
			$specifications{$module}{fixed}{$ordinal}{debug_channels} = [@debug_channels];
			$specifications{$module}{fixed}{$ordinal}{ordinal} = $ordinal;
			$specifications{$module}{fixed}{$ordinal}{internal_name} = $internal_name;
			$specifications{$module}{fixed}{$ordinal}{external_name} = $external_name;
			$specifications{$module}{fixed}{$ordinal}{return_type} = $return_type;
			$specifications{$module}{fixed}{$ordinal}{argument_types} = [@argument_types];
		    } else {
			output->write("$file: $external_name ($module.$ordinal) already exists\n");
		    }
		} elsif($ordinal eq "init") {
		    if(!exists($specifications{$module}{init})) {
			$specifications{$module}{init}{debug_channels} = [@debug_channels];
			$specifications{$module}{init}{external_name} = $external_name;
			$specifications{$module}{init}{internal_name} = $internal_name;
			$specifications{$module}{init}{return_type} = $return_type;
			$specifications{$module}{init}{argument_types} = [@argument_types];
		    } else {
			output->write("$file: $external_name ($module.$ordinal) already exists\n");
		    }
		} else {
		    if(!exists($specifications{$module}{unknown}{$external_name})) {
			$specifications{$module}{unknown}{$external_name}{debug_channels} = [@debug_channels];
			$specifications{$module}{unknown}{$external_name}{internal_name} = $internal_name;
			$specifications{$module}{unknown}{$external_name}{external_name} = $external_name;
			$specifications{$module}{unknown}{$external_name}{ordinal} = $ordinal;
			$specifications{$module}{unknown}{$external_name}{return_type} = $return_type;
			$specifications{$module}{unknown}{$external_name}{argument_types} = [@argument_types];
		    } else {
			output->write("$file: $external_name ($module.$ordinal) already exists\n");
		    }
		}

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


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

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

    if($functions == 0) {
	output->write("$file: doesn't contain any functions\n");
    }
}

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

    my $internal_name = $function->{internal_name};
    my $external_name = $function->{external_name};
    my $ordinal = $function->{ordinal};
    my $return_type = $function->{return_type};
    my @argument_types = @{$function->{argument_types}};

    my $return_kind;
    if($type eq "win16") {
	$return_kind = $win16api->translate_argument($return_type);
    } else {
	$return_kind = $win32api->translate_argument($return_type);
    }
    if(!defined($return_kind)) {
	$return_kind = "undef";
    }
    
    my @argument_kinds;
    foreach my $argument_kind (@argument_kinds) {
	my $argument_kind;
	if($type eq "win16") {
	    $argument_kind = $win16api->translate_argument($argument_kind);
	} else {
	    $argument_kind = $win32api->translate_argument($argument_kind);
	}
	if(!defined($argument_kind)) {
	    $argument_kind = "undef";
	}

	if($argument_kind eq "longlong") {
	    push @argument_kinds, ("long", "long");
	} else {
	    push @argument_kinds, $argument_kind;
	}
    }

    my $calling_convention;
    if($type eq "win16") {
	if($return_kind =~ /^(?:void|s_word|word)$/) {
	    $calling_convention = "pascal16";
	} elsif($return_kind =~ /^(?:long|ptr|segptr|segstr|str|wstr)$/) {
	    $calling_convention = "pascal";
	} else {
	    $calling_convention = "undef";
	}
    } else {
	$calling_convention = "stdcall";
    }

    print OUT "$ordinal $calling_convention $external_name(@argument_kinds) $internal_name\n";
}

if($options->spec_files) {
    foreach my $module (keys(%specifications)) {
	my $spec_file = $module2spec_file{$module};
	my $type = $module2type{$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");
	
	print OUT "name $module\n";
	print OUT "type $type\n";
	if(exists($specifications{$module}{init})) {
	    my $init = $specifications{$module}{init}{internal_name};
	    print OUT "init $init\n";
	}
	print OUT "\n";
	
	my %debug_channels;
	if(exists($specifications{$module}{init})) {
	    my $function = $specifications{$module}{init};
	    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};
	    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}; 
	    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}; 
	    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 $name (sort(keys(%{$specifications{$module}{unknown}}))) {
	    my $function = $specifications{$module}{unknown}{$name};
	    print OUT "# ";
	    output_function(\*OUT, $type, $function);
	    $empty = 0;
	}

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

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

	close(OUT);
    }
}
output->hide_progress;