menuselect-dummy

asterisk 是一个很有知名度开源软件

#!/usr/bin/perl -w

# menuselect - a simple drop-in replacement of the batch-mode menuselect
# included with Asterisk.
#
# Copyright (C) 2008 by Tzafrir Cohen <[e-mail]>
#
# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.
#
# This program 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 General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307
# USA

# Installation: copy this script to menuselect/menuselect . Copy the
# included Makefile as menuselect/Makefile and run:
#
#   make -C makefile dummies
#
# It takes configuration from build_tools/conf . Sample config file:
#
#   By default all modules will be built (except those marked not be
#   used by default)
#
#   # exclude: Don't try to build the following modules. 
#   #exclude app_test
#
#   # You can have multiple items in each line, and multiple lines.
#   # Each item is a perl regular expression that must match the whole
#   # module name.
#   #exclude res_config_.*
#
#   # include: syntax is the same as exclude. Overrides exclude and
#   # modules that are marked as disabled by defualt:
#   #include res_config_sqlite3 app_skel
#
#   # If you want to make sure some modules will be conifgured to build,
#   # you can require them. If modules that match any of the 'require'
#   # pattern are not configured to build, menuselect will panic.
#   # Same pattern rules apply here. Why would you want that? I have no
#   # idea.
#   #require chan_h323 app_directory
#
#   # random - the value for this keyword is a number between 1 and 
#   # 100. The higher it is, more chances not to include each module.
#   # Writes the list of modules that got hit to
#   # build_tools/mods_removed_random .
#   # Note that unlike 'make randomconfig' and such the random
#   # configuration changes each time you run 'make', thus if a build
#   # failed you should first read build_tools/mods_removed_random
#   # before re-running make.
#   #random 10
#
#   # Anything after a '#' is ignored, and likewise empty lines.
#   # Naturally.

use strict;

# Holds global dependncy information. Keys are module names.
my %ModInfo = ();

# extract configuration from kernel modules:
my $AutoconfDepsFile = "build_tools/menuselect-deps";

# configuration file to read for some directives:
my $ConfFile = "build_tools/conf";

# Modules removed randomely:
my $RandomeModsFile = "build_tools/mods_removed_random";

my $MakedepsFile = "menuselect.makedeps";

my $MakeoptsFile = "menuselect.makeopts";

# If those modules are not present, the build will fail (PCRE patterns)
my @RequiredModules = ();

my @Subdirs = qw/apps cdr channels codecs formats funcs main pbx res utils/;

my @XmlCategories = 'cflags';

# Modules should not bother building (PCRE patterns)
my @ExcludedModules = ();

# Do try building those. Overrides 'exclude' and 'defaultenable: no'
my @IncludedModules = ();

# A chance to rule-out a module randomely.
my $RandomKnockoutFactor = 0;

sub warning($) {
	my $msg = shift;
	print STDERR "$0: Warning: $msg\n";
}

# Convert XML syntax to mail-header-like syntax:
# <var>value</var> --> Var: value
sub extract_xml_key($) {
	my $xml_line = shift;
	if ($xml_line !~ m{^\s*<([a-zA-Z0-9]*)>([^<]*)</\1>}) {
		warning "parsed empty value from XML line $xml_line";
		return ('', ''); # warn?
	}
	my ($var, $val) = ($1, $2);
	$var =~ s{^[a-z]}{\u$&};
	return ($var, $val);
}

# Get information embedded in source files from a subdirectory.
# First parameter is the subdirectory and further ones are the actual
# source files.
sub get_subdir_module_info {
	my $subdir = shift;
	my @files = @_;

	my $dir = uc($subdir);

	foreach my $src (@files) {
		open SRC,$src or die "Can't read from source file $src: $!\n";
		$src =~ m|.*/([^/]*)\.c|;
		my $mod_name = $1;
		my %data = (
			Type=>'module', 
			Module=>$mod_name, 
			Dir=> $dir, 
			Avail=>1
		);

		while (<SRC>) {
			next unless (m|^/\*\*\* MODULEINFO| .. m|^ ?\*\*\*/|);
			next unless (m|^[A-Z]| || m|^\s*<|);

			# At this point we can assume we're in the module 
			# info section.
			chomp;
			my ($var, $val) = extract_xml_key($_);

			if ($var =~ /^(Depend|Use)$/i) {
				# use uppercase for dependency names;
				$val = uc($val); 
			}
			if ( ! exists $data{$var} ) {
				$data{$var} = [$val];
			} else {
				push @{$data{$var}},($val);
			}
		}
		close SRC;

		$ModInfo{uc($mod_name)} = \%data;
	}
}

# extract embedded information in all the source tree.
sub extract_subdirs {
	for my $subdir(@_) {
		get_subdir_module_info($subdir, <$subdir/*.c> , <$subdir/*.cc>);
	}
}

# parse a partial XML document that is included as an input 
# for menuselect in a few places. Naturally a full-fledged XML parsing
# will not be done here. A line-based parsing that happens to work will
# have to do.
sub parse_menuselect_xml_file($) {
	my $file_name = shift;
	open XML,$file_name or 
		die "Failed opening XML file $file_name: $!.\n";
	
	my $header = <XML>;
	$header =~ /^\s*<category\s+name="MENUSELECT_([^"]+)"\s/;
	my $category = $1;
	my $member;

	while(<XML>){
		next unless (m{^\s*<(/?[a-z]+)[>\s]});
		my $tag = $1;

		if ($tag eq 'member') {
			if (! m{^\s*<member\s+name="([^"]+)" displayname="([^"]+)"\s*>}){
				warning "Bad XML member line: $_ ($file_name:$.)\n";
				next;
			}
			my ($name, $display_name) = ($1, $2);

			$member = {
				Type => 'XML',
				Dir => $category,
				Module => $1,
				DisplayName => $2,
				Avail => 1, 

			};
		} elsif ($tag eq '/member') {
			$ModInfo{$member->{Module}} = $member;
		} elsif ($tag eq '/category') {
			last;
		} else {
			if (! m/^\s*<([a-z]+)>([^<]+)</) {
				warning "(1) Unknown XML line $_ ($file_name:$.)\n";
				next
			}
			my ($key, $val) = extract_xml_key($_);
			if ($key eq '') {
				warning "Unknown XML line $_ ($file_name:$.)\n";
				next
			}
			if (! exists $member->{$key}) {
				$member->{$key} = [];
			}
			push @{$member->{$key}}, ($val);
		}
	}

	
	close XML;
}

# Dump our data structure to a file.
sub dump_deps($) {
	my $file = shift;
	open OUTPUT,">$file" or 
	die "cannot open category file $file for writing: $!\n";

	foreach my $mod_name (sort keys %ModInfo) { 
	print OUTPUT "Key: $mod_name\n";
		my $data = $ModInfo{$mod_name};
		foreach my $var (sort keys %{$data} ) {
			my $val = $$data{$var};
			if (ref($val) eq 'ARRAY') {
				print OUTPUT $var.": ". (join ", ", @$val)."\n";
			} else {
				print OUTPUT "$var: $val\n";
			}
		}
		print OUTPUT "\n";
	}
	close OUTPUT;
}

# Get the available libraries that autoconf generated.
sub get_autoconf_deps() {
	open DEPS, $AutoconfDepsFile or
		die "Failed to open $AutoconfDepsFile. Aborting: $!\n";

	my @deps_list = (<DEPS>);
	foreach (@deps_list){
		chomp;
		my ($lib, $avail) = split(/=/);
		$ModInfo{$lib} = {Type=>'lib', Avail=>$avail};
		if (($avail ne "0") && ($avail ne "1")) {
			warning "Library $lib has invalid availability ".
				"value <$avail> (check $AutoconfDepsFile).\n";
		}
	}
	close DEPS;
}

# Read our specific config file.
#
# Its format:
#
#   keyword  values
#
# values are always a spaces-separated list.
sub read_conf() {
	open CONF,$ConfFile or return;

	while (<CONF>) {
		# remove comments and empty lines:
		chomp;
		s/#.*$//;
		next if /^\s*$/;

		my ($keyword, @value) = split;

		if ($keyword eq 'exclude') {
			push @ExcludedModules, @value;
		} elsif ($keyword eq 'include') {
			push @IncludedModules, @value;
		} elsif ($keyword eq 'require') {
			push @RequiredModules, @value;
		} elsif ($keyword eq 'random') {
			$RandomKnockoutFactor = $value[0] / 100;
		} else {
			warning "unknown keyword $keyword in line $. of $ConfFile.";
		}
	}
}

# generate menuselect.makedeps.
# In this file menuselect writes dependecies of each module. CFLAGS will
# then automatically include for each module the _INCLUDE and LDFLAGS
# will include the _LIBS from all the depedencies of the module.
sub gen_makedeps() {
	open MAKEDEPSS, ">$MakedepsFile" or
		die "Failed to open deps file $MakedepsFile for writing. Aborting: $!\n";

	for my $mod_name (sort keys %ModInfo) {
		next unless ($ModInfo{$mod_name}{Type} eq 'module');

		my $mod = $ModInfo{$mod_name};
		my @deps = ();

		# if we have Depend or Use, put their values into 
		# @deps . If we have none, move on.
		push @deps, @{$mod->{Depend}} if (exists $mod->{Depend});
		push @deps, @{$mod->{Use}}    if (exists $mod->{Use});
		next unless @deps; 

		# TODO: don't print dependencies that are not external libs. 
		# Not done yet until I figure out if this is safe.
		my $dep = join(' ', @deps);
		print MAKEDEPSS "MENUSELECT_DEPENDS_".$mod->{Module}."=$dep\n";
	}

	close MAKEDEPSS;
}

# Set modules from patterns specified by 'exclude' in the configuration file
# to exclude modules from building (mark them as unavailable).
sub apply_excluded_patterns() {
	foreach my $pattern (@ExcludedModules) {
		my @excluded = grep {/^$pattern$/i} (keys %ModInfo);
		foreach (@excluded) {
			$ModInfo{$_}{Avail} = 0;
		}
	}
}

# Set modules from patterns specified by 'include' in the configuration
# file to exclude from building (mark them as available).
sub apply_included_patterns() {
	foreach my $pattern (@IncludedModules) {
		my @included = grep {/^$pattern$/i} (keys %ModInfo);
		foreach (@included) {
			$ModInfo{$_}{Avail} = 1;
		}
	}
}

# If user set the "random" config to anything > 0, drop some random
# modules. May help expose wrong dependencies.
sub apply_random_drop() {
	return if ($RandomKnockoutFactor <= 0);

	open MODS_LIST, ">$RandomeModsFile" or
		die "Failed to open modules list file $RandomeModsFile for writing. Aborting: $!\n";
	for my $mod (keys %ModInfo) {
		next unless ($ModInfo{$mod}{Type} eq 'module');
		next unless (rand() < $RandomKnockoutFactor);
		$ModInfo{$mod}{Avail} = 0;
		$ModInfo{$mod}{RandomKill} = 1;
		print MODS_LIST $ModInfo{$mod}{Module}."\n";
	}

	close MODS_LIST;
	

}

sub check_required_patterns() {
	my @failed = ();
	foreach my $pattern (@RequiredModules) {
		my @required = grep {/^$pattern$/i} (keys %ModInfo);
		foreach my $mod (@required) {
			if ((! exists $ModInfo{$mod}{Checked}) ||
				(! $ModInfo{$mod}{Checked}) )
			{
				push @failed, $mod;
			}
		}
	}
	return unless (@failed);

	my $failed_str = join ' ',@failed;
	die("Missing dependencies for the following modules: $failed_str\n");
}

# Disable building for modules that were marked in the embedded module 
# information as disabled for building by default.
sub apply_default_enabled() {
	foreach my $mod (keys %ModInfo) {
		if ((exists $ModInfo{$mod}{Defaultenabled}) &&
				$ModInfo{$mod}{Defaultenabled}[0] eq 'no')
		{
			$ModInfo{$mod}{Avail} = 0;
		}
	}
}

# recursively check dependency for a module.
#
# We run a scan for modules. Modules marked as 'Checked' are ones we
# have already fully verified to have proper dependencies.
#
# We can only use a module or library marked as Avail => 1 (library
# available or module not excluded).
sub check_module($);
sub check_module($) {
	my $mod = shift;

	# we checked it:
	if (exists $ModInfo{$mod}{Checked}) {
		return $ModInfo{$mod}{Checked};
	}
	# A library has no dependencies of its own.
	if ($ModInfo{$mod}{Type} eq 'lib') {
		return ($ModInfo{$mod}{Avail} || 0);
	}
	# An excluded module.
	if ($ModInfo{$mod}{Avail} == 0) {
		return 0;
	}
	# XML inputs have a reversed logic: no 'defaultenabled' means 'no'
	# And we need to actually print enabled ones, rather than disabled
	# ones.
	if ($ModInfo{$mod}{Type} eq 'XML') {
		my $res = ((not exists $ModInfo{$mod}{Defaultenabled}) ||
			($ModInfo{$mod}{Defaultenabled}[0] ne 'yes') );
		$ModInfo{$mod}{Checked} = $res;
		return $res;
	}
	# no dependencies to check:
	if (! exists $ModInfo{$mod}{Depend}) {
		$ModInfo{$mod}{Checked} = 1;
		return 1;
	}

	my $deps_checked = 1; # may be reset below on failures:

	if (exists $ModInfo{$mod}{Tested}) {
		# this probably means a circular dependency of some sort.
		warning "Got to module $mod that is already tested.";
	}
	$ModInfo{$mod}{Tested} = 1;

	foreach my $dep_mod (@{$ModInfo{$mod}{Depend}} ) {
		if (!exists ${ModInfo}{$dep_mod}) {
			# TODO: die here? This should never happen.
			warning "module $mod depends on $dep_mod that does not exist.";
			next;
		}
		$deps_checked &= check_module($dep_mod);
		last if(!$deps_checked) # no point testing further if we failed.
	}

	$ModInfo{$mod}{Checked} = $deps_checked;
	return $deps_checked;
}

# The main dependency resolver function.
sub resolve_deps() {
	apply_default_enabled();
	apply_excluded_patterns();
	apply_included_patterns();

	foreach my $mod (keys %ModInfo) {
		check_module($mod);
	}
}

# generate menuselect.makeopts. Please let me know if some parts are
# still missing.
sub gen_makeopts() {
	open MAKEDEPS, ">$MakeoptsFile" or
		die "Failed to open opts file $MakeoptsFile for writing. Aborting: $!\n";

	my %Subdirs;
	foreach my $mod (sort keys %ModInfo) {
		next unless ($ModInfo{$mod}{Type} =~ /^(module|XML)$/);
		next if ($ModInfo{$mod}{Checked});
		my $dir = $ModInfo{$mod}{Dir};
		if (! exists $Subdirs{$dir}) {
			$Subdirs{$dir} = [];
		}
		push @{$Subdirs{$dir}},( $ModInfo{$mod}{Module} );
	}
	foreach my $dir (sort keys %Subdirs) {
		my $deps = join(' ', @{$Subdirs{$dir}});
		print MAKEDEPS "MENUSELECT_$dir=$deps\n";
	}

	close MAKEDEPS;
}

# 
# The main program start here
#

read_conf();

extract_subdirs(@Subdirs);

parse_menuselect_xml_file('build_tools/cflags.xml');
parse_menuselect_xml_file('sounds/sounds.xml');

apply_random_drop();

get_autoconf_deps();

#dump_deps('build_tools/dump_deps_before_resolve');
resolve_deps();

# Handy debugging:
dump_deps('build_tools/dump_deps');

check_required_patterns();

gen_makedeps();

gen_makeopts();