#!/usr/bin/perl -w
#
#############################################################################
# Copyright (c) 2014 Jean Delvare <jdelvare@suse.de>
# All Rights Reserved.
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of version 2 of the GNU General Public License as
# published by the Free Software Foundation.
#
# 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.
#############################################################################
#
# The purpose of this script is to catch, and in most cases fix,
# inconsistencies between supported.conf and the set of modules being actually
# installed. It is recommended to run it on a complete set of installed modules
# (all flavors and architectures) otherwise you may get false positives. Note
# that you can pass as many modules directories as you want.
#
# Usage: supported-conf-fixup [OPTIONS] supported.conf [/lib/modules/x.x-flavor ...]
# Options:
#  -h, --help		Print usage and exit
#      --mod-path	Report wrong module paths
#      --mod-missing	Report missing modules
#      --mask-path	Report wrong mask paths
#      --mask-missing	Report missing mask paths
#      --not-listed	Report unlisted modules
#  -v, --verbose	Be verbose
#  -o, --output file	Write updated supported.conf to file
#      --sort		Sort the output file
#
# To do: better handling of _ vs -
# To do: better handling of .ko being optional

use strict;
use vars qw($sup_conf_file @sup_conf_data @supported_mod @supported_mask %supported
	    %installed $n_ins %installed_paths %builtin %not_listed $verbose
	    $check_mod_path $check_mod_missing $check_mask_path $check_mask_missing
	    $check_not_listed $output $n_err $n_corrected $usage $sort);
use File::Find;
use Getopt::Long;
use Fcntl;

# Data structures:
# @sup_conf_data contains raw lines from supported.conf
# @supported_mod contains hashes with the following keys:
#   - line: line number in supported.conf
#   - module path: relative path + module name
# @supported_mask contains hashes with the following keys:
#   - line: line number in supported.conf
#   - mask path: relative path + *
# %supported contains the same information as @supported_mod + @supported_mask,
#   but as a module/mask path => line mapping
# %installed contains the list of installed modules, as a
#   module name => module paths mapping
# %installed_paths records paths which contain installed modules (only
#   keys are meaningful)
# %not_listed keys list installed modules which aren't listed in supported.conf
#   (so their support status is unknown)
# %builtin contains the list of built-in modules, as a
#   module name => module paths mapping

Getopt::Long::Configure("bundling");
$verbose = 0;
GetOptions(
	"help|h"	=> \$usage,
	"mod-path"	=> \$check_mod_path,
	"mod-missing"	=> \$check_mod_missing,
	"mask-path"	=> \$check_mask_path,
	"mask-missing"	=> \$check_mask_missing,
	"not-listed"	=> \$check_not_listed,
	"verbose|v+"	=> \$verbose,
	"output|o=s"	=> \$output,
	"sort"		=> \$sort,
) or exit 1;

if ($usage || @ARGV < 1) {
	print STDERR
"Usage: $0 [OPTIONS] supported.conf [/lib/modules/x.x-flavor ...]
Options:
 -h, --help		Print usage and exit
     --mod-path		Report wrong module paths
     --mod-missing	Report missing modules
     --mask-path	Report wrong mask paths
     --mask-missing	Report missing mask paths
     --not-listed	Report unlisted modules
 -v, --verbose		Be verbose
 -o, --output file	Write updated supported.conf to file
     --sort		Sort the output file
";
	exit 1;
}

$sup_conf_file = shift @ARGV;

sub gather_path
{
	my $file_or_dir = $_;
	my $module_path = $File::Find::name;
	my ($path, $module);

	# Special case for modules.builtin
	if ($file_or_dir eq "modules.builtin") {
		open(BUILTIN, "<$file_or_dir") or die;
		while (<BUILTIN>) {
			next unless m,^kernel/(.*)/([^/]+)\.ko(\.xz|\.gz|\.zst)?$,;
			$path = $1;
			$module = $2;

			if (exists $builtin{$module}) {
				next if grep { $_ eq $path } @{$builtin{$module}};
				# There can be duplicates with different paths across architectures
				push @{$builtin{$module}}, $path;
			} else {
				$builtin{$module} = [ $path ];
			}
		}
		close(BUILTIN);
		return;
	}

	return unless $module_path =~ s,^(.*?/)?kernel/,,;
	if (-f $file_or_dir) {
		return unless $module_path =~ m,^(.*)/([^/]+)\.ko(\.xz|\.gz|\.zst)?$,;
		$path = $1;
		$module = $2;

		if (exists $installed{$module}) {
			return if grep { $_ eq $path } @{$installed{$module}};
			# There can be duplicates with different paths across architectures
			push @{$installed{$module}}, $path;
		} else {
			$installed{$module} = [ $path ];
		}
		$n_ins++;

		$not_listed{"$path/$module"} = 1;
	} elsif (-d $file_or_dir) {
		$installed_paths{$module_path}++;
	}
}

# First, gather all installed modules with their path
$n_ins = 0;
if (@ARGV) {
	find(\&gather_path, @ARGV);
	print "Found $n_ins installed modules\n";
}

sub matching_mask
{
	my $module_path = shift;

	foreach my $mask (@supported_mask) {
		my $prefix = $mask->{module_path};
		$prefix =~ s,/*,,;
		return "$mask->{module_path} at line $mask->{line}"
			if $module_path =~ m,^$prefix,;
	}
}

# Then, parse supported.conf
open(SUP, $sup_conf_file) || die;
while (<SUP>) {
	# Store raw data, needed to generate the updated file
	push @sup_conf_data, $_;

	chomp;
	s/#.*$//;				# Strip comments
	s/\s+$//;				# Strip trailing whitespace
	next if m/^$/;				# Skip blank lines
	s/^([+-]([\w\d-]+)?\s)*\s*//;		# Strip guards

	my $new_entry = {
		'line' => $.,
		'module_path' => $_,
	};

	# Check for masks that come too early
	my $matching_mask = matching_mask($_);

	if (m/\/\*$/) {
		print "WARNING: Mask $_ at line $. is shadowed by $matching_mask\n"
			if $matching_mask;
		push @supported_mask, $new_entry;
	} else {
		print "WARNING: Module $_ at line $. is shadowed by $matching_mask\n"
			if $matching_mask;
		push @supported_mod, $new_entry;
	}

	# Check for duplicate entries
	if (exists $supported{$_}) {
		print "WARNING: Duplicate entry $_, lines $supported{$_} and $.\n";
	} else {
		$supported{$_} = $.;
	}
}
close(SUP);
print "Gathered ", scalar @supported_mod, " modules and ",
      scalar @supported_mask, " masks from $sup_conf_file\n";

# Amongst all paths containing modules, list the ones which end the same as the parameter
sub candidate_paths
{
	my $path = shift;
	(my $last = $path) =~ s,.*/,,;

	return grep { $_ =~ m,[\s/]$last$, } keys %installed_paths;
}

sub check_path
{
	my $entry = $_;
	my $module_path = $entry->{module_path};
	my $line = $entry->{line};
	my ($path, $module, $ext, $module_alt);
	
	if ($module_path =~ m,^(.*)/\*$,) {
		$path = $1;
		# Mask, check that this directory exists
		if (exists $installed_paths{$path}) {
			# Mark all matching modules as listed
			foreach $module (keys %not_listed) {
				delete $not_listed{$module} if $module =~ m,^$path/,;
			}
		} else {
			# Check if other installed paths end with the same component
			my @candidate = candidate_paths($path);

			if (0 == scalar @candidate) {
				if ($check_mask_missing) {
					print "$sup_conf_file: $line: Referenced path $path doesn't exist, no candidate\n"
						if $verbose;
					$n_err++;
					# Delete that line
					$sup_conf_data[$line - 1] = '';	
					$n_corrected++;
				}
			} elsif (1 == scalar @candidate) {
				if ($check_mask_path) {
					print "$sup_conf_file: $line: Mask path $path is wrong, correct is $candidate[0]\n"
						if $verbose;
					$n_err++;
					# Update the path
					$sup_conf_data[$line - 1] =~ s,(\s)$path/,$1$candidate[0]/,;
					$n_corrected++;

					# Strip trailing whitespace
					$sup_conf_data[$line - 1] =~ s,\s*\n$,\n,;
				}
			} else {
				if ($check_mask_path) {
					$n_err++;
					print "$sup_conf_file: $line: Referenced path $path doesn't exist, too many candidates (",
					      join(", ", @candidate), ")\n"
						if $verbose;
				}
			}
		}
		return;
	}

	unless ($module_path =~ m,^(.*)/([^/]+)(\.ko)(\.xz|\.gz|\.zst)?$, ||
		$module_path =~ m,^(.*)/([^/]+)$,) {
		print STDERR "$sup_conf_file: $line: Unparsable module path: $module_path\n";
		return;
	}
	$path = $1;
	$module = $2;
	$ext = defined $3 ? $3 : '';

	# Exact name may be different so try all variants
	if (!exists $installed{$module}) {
		($module_alt = $module) =~ tr/-/_/;
		if (exists $installed{$module_alt}) {
			$module = $module_alt;
		} else {
			($module_alt = $module) =~ tr/_/-/;
			if (exists $installed{$module_alt}) {
				$module = $module_alt;
			}
		}
	}

	# Module, check if it exists
	if (!exists $installed{$module}) {
		if ($check_mod_missing) {
			if (exists $builtin{$module}) {
				print "$sup_conf_file: $line: Referenced module $module is built-in\n"
					if $verbose >= 2;
			} else {
				print "$sup_conf_file: $line: Referenced module $module doesn't exist\n"
					if $verbose;
				$n_err++;
				# Delete that line
				$sup_conf_data[$line - 1] = '';
				$n_corrected++;
			}
		}
		if ($check_mod_path) {
			if (exists $builtin{$module} && !grep { $_ eq $path } @{$builtin{$module}}) {
				print "$sup_conf_file: $line: Referenced module $module may be built-in but path doesn't match (",
				      join(" and ", @{$builtin{$module}}),
				      ", supported.conf says $path\n" if $verbose;
			}
		}
	} elsif (!grep { $_ eq $path } @{$installed{$module}}) {
		if ($check_mod_path) {
			print "$sup_conf_file: $line: Path for module $module is wrong: installed at ",
			      join(" and ", @{$installed{$module}}),
			      ", supported.conf says $path\n" if $verbose;
			$n_err++;

			# If there is only one candidate, assume it is right
			if (1 == @{$installed{$module}}) {
				# Update the path
				$sup_conf_data[$line - 1] =~ s,(\s)$path/,$1$installed{$module}->[0]/,;
				$n_corrected++;

				# Attempt to preserve tab-based comment alignment
				if ($sup_conf_data[$line - 1] =~ m,(\t+)#,) {
					my $old_len = length "$path/$module$ext";
					my $new_len = length "$installed{$module}->[0]/$module$ext";
					my $align = (int($old_len / 8) + length $1) * 8;
					my $new_spacing = "\t" x ($align / 8 - int($new_len / 8));
					$sup_conf_data[$line - 1] =~ s,(\t+)#,$new_spacing#,;
				}
				# Strip trailing whitespace
				$sup_conf_data[$line - 1] =~ s,\s*\n$,\n,;
			}
		}
	}

	# Mark as listed
	delete $not_listed{"$path/$module"};
	# Exact name may be different so try all variants
	$module =~ tr/-/_/;
	delete $not_listed{"$path/$module"};
	$module =~ tr/_/-/;
	delete $not_listed{"$path/$module"};
}

# Finally, compare both sets and report and/or correct inconsistencies
$n_err = $n_corrected = 0;
print "\n";
check_path($_) foreach (@supported_mod);
check_path($_) foreach (@supported_mask);
print "\nFound $n_err ", $n_err > 1 ? "errors" : "error", " (corrected $n_corrected)\n"
	if ($check_mod_path || $check_mod_missing || $check_mask_path || $check_mask_missing);

# If requested, print unlisted modules
if ($check_not_listed) {
	print "Modules installed but not listed in supported.conf:\n";
	print "$_\n" foreach (sort keys %not_listed);
}

# Module name comparison function for sorting
sub modcmp
{
	my $mod1 = $a;
	my $mod2 = $b;

	$mod1 =~ s/\s*#.*$//mg;				# Strip comments
	$mod2 =~ s/\s*#.*$//mg;				# Strip comments
	$mod1 =~ s/\n//g;				# Strip empty lines
	$mod2 =~ s/\n//g;				# Strip empty lines
	$mod1 =~ s/^([+-]([\w\d-]+)?\s)*\s*//;		# Strip guards
	$mod2 =~ s/^([+-]([\w\d-]+)?\s)*\s*//;		# Strip guards

	# Masks must always go after explict module names they match
	return  1 if $mod1 =~ m/^(.*)\/\*$/ && substr($mod2, 0, length($1)) eq $1;
	return -1 if $mod2 =~ m/^(.*)\/\*$/ && substr($mod1, 0, length($1)) eq $1;

	return $mod1 cmp $mod2;
}

sub sort_data
{
	my (@header, @sorted, $n, $comment);

	# Preserve comments and blank lines at the top of supported.conf
	for ($n = 0; $n < @sup_conf_data; $n++) {
		last unless $sup_conf_data[$n] =~ m/^\s*(#|$)/;
		push @header, $sup_conf_data[$n];
	}

	# Store all the rest in an array, except blank lines
	for ($comment = ""; $n < @sup_conf_data; $n++) {
		next if $sup_conf_data[$n] =~ m/^\s*$/;

		# Comments are attached to the module which follows or precedes
		# them. We use a heuristic to distinguish between the two
		# cases: comments which start before column 24 are attached to
		# the module which follows them, while comments which start
		# after column 24 are attached to teh module which precedes
		# them.
		if ($sup_conf_data[$n] =~ m/^(\s*)#/) {
			my $leading = $1;
			$leading =~ s/ {1,7}\t/\t/g;
			$leading =~ s/ {8}/\t/g;
			if (length($leading) <= 3) {
				$comment .= $sup_conf_data[$n];
			} else {
				$sorted[@sorted - 1] .= $sup_conf_data[$n];
			}
			next;
		}

		push @sorted, $comment . $sup_conf_data[$n];
		$comment = "";
	}

	# Sort the module list
	@sorted = sort modcmp @sorted;

	# Merge the header and the module list
	@sup_conf_data = (@header, @sorted);
}

# If requested, write a fixed version of supported.conf
if ($output) {
	sort_data() if $sort;
	open(OUTPUT, ">$output") || die;
	for (my $n = 0; $n < @sup_conf_data; $n++) {
		# Merge blank lines
		print OUTPUT $sup_conf_data[$n]
			unless $sup_conf_data[$n] eq "\n" && $sup_conf_data[$n - 1] eq "\n";
	}
	close(OUTPUT);
	print "Fixed supported.conf saved as $output\n";
} elsif ($n_corrected) {
	print "Use option -o to write out the corrected file\n";
} elsif ($sort) {
	print "Use option -o to write out the sorted file\n";
}