Sweden-Number/tools/winapi/modules.pm

#
# Copyright 1999, 2000, 2001 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., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA
#

package modules;

use strict;
use warnings 'all';

use vars qw($VERSION @ISA @EXPORT @EXPORT_OK);
require Exporter;

@ISA = qw(Exporter);
@EXPORT = qw();
@EXPORT_OK = qw($modules);

use vars qw($modules);

use config qw(
    file_type files_skip
    file_directory
    get_c_files get_spec_files
    $current_dir $wine_dir
);
use options qw($options);
use output qw($output);

sub import(@) {
    $Exporter::ExportLevel++;
    Exporter::import(@_);
    $Exporter::ExportLevel--;

    if (defined($modules)) {
	return;
    }

    $modules = 'modules'->new;
}

sub get_spec_file_type($) {
    my $file = shift;

    my $module;
    my $type;

    $module = $file;
    $module =~ s%^.*?([^/]+)\.spec$%$1%;

    open(IN, "< $file") || die "$file: $!\n";
    local $/ = "\n";
    my $header = 1;
    my $lookahead = 0;
    while($lookahead || defined($_ = <IN>)) {
	$lookahead = 0;
	s/^\s*(.*?)\s*$/$1/;
	s/^(.*?)\s*#.*$/$1/;
	/^$/ && next;

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

	if(/^(\d+|@)\s+pascal(?:16)?/) {
	    $type = "win16";
	    last;
	}
    }
    close(IN);

    if(!defined($type)) {
	$type = "win32";
    }

    return ($type, $module);
}

sub find_spec_files($) {
    my $self = shift;

    my $dir2spec_file = \%{$self->{DIR2SPEC_FILE}};
    my $spec_file2dir = \%{$self->{SPEC_FILE2DIR}};

    $output->progress("modules");

    my $spec_file_found = {};
    my $allowed_dir;
    my $spec_file;

    my @spec_files = <{dlls/*/*.spec}>;

    foreach $spec_file (@spec_files) {
        $spec_file =~ /(.*)\/.*\.spec/;

        $allowed_dir = $1;

        $$spec_file_found{$spec_file}++;
        $$spec_file2dir{$spec_file}{$allowed_dir}++;
        $$dir2spec_file{$allowed_dir}{$spec_file}++;
        # gdi32.dll and gdi.exe have some extra sources in subdirectories
        if ($spec_file =~ m!/gdi32\.spec$!)
        {
            $$spec_file2dir{$spec_file}{"$allowed_dir/enhmfdrv"}++;
            $$dir2spec_file{"$allowed_dir/enhmfdrv"}{$spec_file}++;
        }
        if ($spec_file =~ m!/gdi(?:32|\.exe)\.spec$!)
        {
            $$spec_file2dir{$spec_file}{"$allowed_dir/mfdrv"}++;
            $$dir2spec_file{"$allowed_dir/mfdrv"}{$spec_file}++;
        }
    }

    return $spec_file_found;
}

sub read_spec_files($$) {
    my $self = shift;

    my $spec_file_found = shift;

    my $dir2spec_file = \%{$self->{DIR2SPEC_FILE}};
    my $spec_files16 = \@{$self->{SPEC_FILES16}};
    my $spec_files32 = \@{$self->{SPEC_FILES32}};
    my $spec_file2module = \%{$self->{SPEC_FILE2MODULE}};
    my $module2spec_file = \%{$self->{MODULE2SPEC_FILE}};

    my @spec_files;
    if($wine_dir eq ".") {
	@spec_files = get_spec_files("winelib");
    } else {
	my %spec_files = ();
	foreach my $dir ($options->directories) {
	    $dir = "$current_dir/$dir";
	    $dir =~ s%/\.$%%;
	    foreach my $spec_file (sort(keys(%{$$dir2spec_file{$dir}}))) {
		$spec_files{$spec_file}++;
	    }
	}
	@spec_files = sort(keys(%spec_files));
    }

    @$spec_files16 = ();
    @$spec_files32 = ();
    foreach my $spec_file (@spec_files) {
	(my $type, my $module) = get_spec_file_type("$wine_dir/$spec_file");

	$$spec_file2module{$spec_file} = $module;
	$$module2spec_file{$module} = $spec_file;

	if($type eq "win16") {
	    push @$spec_files16, $spec_file;
	} elsif($type eq "win32") {
	    push @$spec_files32, $spec_file;
	} else {
	    $output->write("$spec_file: unknown type '$type'\n");
	}
    }

    foreach my $spec_file (@spec_files) {
	if(!$$spec_file_found{$spec_file} && $spec_file !~ m%tests/[^/]+$%) {
	    $output->write("modules: $spec_file: exists but is not specified\n");
	}
    }
}

sub new($) {
    my $proto = shift;
    my $class = ref($proto) || $proto;
    my $self  = {};
    bless ($self, $class);

    my $spec_file_found = $self->find_spec_files();
    $self->read_spec_files($spec_file_found);

    return $self;
}

sub all_modules($) {
    my $self = shift;

    my $module2spec_file = \%{$self->{MODULE2SPEC_FILE}};

    return sort(keys(%$module2spec_file));
}

sub is_allowed_module($$) {
    my $self = shift;

    my $module2spec_file = \%{$self->{MODULE2SPEC_FILE}};

    my $module = shift;

    return defined($$module2spec_file{$module});
}

sub is_allowed_module_in_file($$$) {
    my $self = shift;

    my $dir2spec_file = \%{$self->{DIR2SPEC_FILE}};
    my $spec_file2module = \%{$self->{SPEC_FILE2MODULE}};

    my $module = shift;
    my $file = shift;
    $file =~ s/^\.\///;

    my $dir = $file;
    $dir =~ s/\/[^\/]*$//;

    if($dir =~ m%^include%) {
	return 1;
    }

    foreach my $spec_file (sort(keys(%{$$dir2spec_file{$dir}}))) {
	if($$spec_file2module{$spec_file} eq $module) {
	    return 1;
	}
    }

    return 0;
}

sub allowed_modules_in_file($$) {
    my $self = shift;

    my $dir2spec_file = \%{$self->{DIR2SPEC_FILE}};
    my $spec_file2module = \%{$self->{SPEC_FILE2MODULE}};

    my $file = shift;
    $file =~ s/^\.\///;

    my $dir = $file;
    $dir =~ s/\/[^\/]*$//;

    my %allowed_modules = ();
    foreach my $spec_file (sort(keys(%{$$dir2spec_file{$dir}}))) {
	my $module = $$spec_file2module{$spec_file};
	$allowed_modules{$module}++;
    }

    my $module = join(" & ", sort(keys(%allowed_modules)));

    return $module;
}

sub allowed_dirs_for_module($$) {
   my $self = shift;

   my $module2spec_file = \%{$self->{MODULE2SPEC_FILE}};
   my $spec_file2dir = \%{$self->{SPEC_FILE2DIR}};

   my $module = shift;

   my $spec_file = $$module2spec_file{$module};

   return sort(keys(%{$$spec_file2dir{$spec_file}}));
}

sub allowed_spec_files16($) {
    my $self = shift;

    my $spec_files16 = \@{$self->{SPEC_FILES16}};

    return @$spec_files16;
}

sub allowed_spec_files32($) {
    my $self = shift;

    my $spec_files32 = \@{$self->{SPEC_FILES32}};

    return @$spec_files32;
}

sub found_module_in_dir($$$) {
    my $self = shift;

    my $module = shift;
    my $dir = shift;

    my $used_module_dirs = \%{$self->{USED_MODULE_DIRS}};

    $dir = "$current_dir/$dir";
    $dir =~ s%/\.$%%;

    $$used_module_dirs{$module}{$dir}++;
}

sub complete_modules($$) {
    my $self = shift;

    my $c_files = shift;

    my %dirs;

    foreach my $file (@$c_files) {
	my $dir = file_directory("$current_dir/$file");
	$dirs{$dir}++;
    }

    my @c_files = get_c_files("winelib");
    @c_files = files_skip(@c_files);
    foreach my $file (@c_files) {
	my $dir = file_directory($file);
	if(exists($dirs{$dir})) {
	    $dirs{$dir}--;
	}
    }

    my @complete_modules = ();
    foreach my $module ($self->all_modules) {
	my $index = -1;
	my @dirs = $self->allowed_dirs_for_module($module);
	foreach my $dir (@dirs) {
	    if(exists($dirs{$dir}) && $dirs{$dir} == 0) {
		$index++;
	    }
	}
	if($index == $#dirs) {
	    push @complete_modules, $module;
	}
    }

    return @complete_modules;
}

sub global_report($) {
    my $self = shift;

    my $module2spec_file = \%{$self->{MODULE2SPEC_FILE}};
    my $used_module_dirs = \%{$self->{USED_MODULE_DIRS}};

    my @messages;
    foreach my $dir ($options->directories) {
	$dir = "$current_dir/$dir";
	$dir =~ s%/\.$%%;
	foreach my $module ($self->all_modules) {
	    if(!$$used_module_dirs{$module}{$dir}) {
		my $spec_file = $$module2spec_file{$module};
		push @messages, "modules: $spec_file: directory ($dir) is not used\n";
	    }
	}
    }

    foreach my $message (sort(@messages)) {
	$output->write($message);
    }
}

1;