#! /usr/bin/perl -w

# Catch curl signals and react on them differently
# same for rpm...

# FIXME: document that installing a driver package beforehand doesn't help
#        because rpm doesn't recognize that it resolves a dependency!!!

# FIXME: http authorization, proxy support, etc. !!!

# FIXME: Add a special case for packages that are signed with an unknown
#	 key.

use FileHandle;
use Getopt::Long;
use POSIX qw(setlocale LC_MESSAGES uname sysconf _SC_ARG_MAX strerror
	     ENOENT getcwd);
use Locale::gettext;
use File::Temp qw(mkstemp mkdtemp);
use File::stat;
use strict;

my $progname = $0;
$progname =~ s<.*/><>;

$| = 1;  # Turn on AUTOFLUSH (of STDOUT and STDERR).

setlocale(LC_MESSAGES, "");
bindtextdomain("kernel-update-tool", "/usr/share/locale");
textdomain("kernel-update-tool");

sub _($) {
    return gettext(shift);
}

my $modinfo = '/sbin/modinfo';
my $modprobe = '/sbin/modprobe';

my $module_download_db = '/var/lib/YaST2/download';

my $DOWNLOAD_DRIVER_PACKAGES = 'ask'; # yes / ask / no
my $REUSE_DRIVER_PACKAGES = 'ask';  # yes / ask /no

if (-e "/etc/sysconfig/onlineupdate") {
    eval `bash -c '
	source /etc/sysconfig/onlineupdate
	echo "\\\$DOWNLOAD_DRIVER_PACKAGES=\\"\$DOWNLOAD_DRIVER_PACKAGES\\";"
	echo "\\\$REUSE_DRIVER_PACKAGES=\\"\$REUSE_DRIVER_PACKAGES\\";"
    '`;
}

$DOWNLOAD_DRIVER_PACKAGES = 'ask'
    unless $DOWNLOAD_DRIVER_PACKAGES =~ /^(yes|ask|no)$/;
$REUSE_DRIVER_PACKAGES='ask'
    unless $REUSE_DRIVER_PACKAGES =~ /^(yes|ask|no)$/;

sub usage($) {
    my ($status) = @_;

    print STDERR sprintf(
_("Usage: %s [options] --status") . "\n" .
_("       %s [options] {--install|--upgrade} {kernel} [driver] ...") . "\n\n" .
_("Options are:") . "\n" .
_("--version kernelrelease
	The kernel release (uname -r) that the status command applies to.
	The kernel release that the install and upgrade actions install
	and upgrade from.
") .
_("--non-interactive
	Do not ask any questions.
") .
_("--dry-run
	Perform everything that would be done during install or upgrade
	without actually installing or upgrading any packages.
") .
_("--verbose
	Be more verbose and send some some debug output to standard error.
") .
_("--download-driver-packages={yes,no,ask}
	Sets whether to attempt to download kernel driver packages
	from the locations defined in /var/lib/YaST2/download/*
	and /var/lib/YaST2/download.conf.
") .
_("--reuse-driver-packages={yes,no,ask}
	Sets whether to attempt to reuse kernel driver packages from the
	previous kernel.
") .
_("--require-signed-packages={yes,no,ask}
	Whether to require packages to be signed.
") .
_("--parse-markers
	Make the script output more easily parseable (for scripting).
"), $0, $0);
    exit $status;
}

my $old_kernel_version;
my $non_interactive;
my $dry_run;
my $force;
my $verbose;
my $require_signed_packages = 'ask';  # yes / ask / no
my $parse_markers;
my $basedir = '';
my $action;

GetOptions('version=s' => \$old_kernel_version,
	   'non-interactive' => \$non_interactive,
	   'dry-run' => \$dry_run,
	   'force' => \$force,
	   'verbose' => \$verbose,
	   'download-driver-packages=s' => \$DOWNLOAD_DRIVER_PACKAGES,
	   'reuse-driver-packages=s' => \$REUSE_DRIVER_PACKAGES,
	   'require-signed-packages=s' => \$require_signed_packages,
	   'parse-markers' => \$parse_markers,
	   'help' => sub { usage(0); },
	   'status' => sub { usage(1) if $action;
			     $action = 'status' },
	   'upgrade' => sub { usage(1) if $action;
			      $action = 'upgrade' },
	   'install' => sub { usage(1) if $action;
			      $action = 'install' },
#	   'basedir=s' => \$basedir,
) &&
@ARGV >= 0 && $action &&
$DOWNLOAD_DRIVER_PACKAGES =~ /^(yes|ask|no)$/ &&
$REUSE_DRIVER_PACKAGES =~ /^(yes|ask|no)$/ &&
$require_signed_packages =~ /^(yes|ask|no)$/
    or usage(1);

$old_kernel_version = (uname)[2]
   unless defined $old_kernel_version;

# Register a temporary object for cleanup on exit.
sub register_temporary_object($) {
    my ($tmp) = @_;

    push @$main::temporary_objects, $tmp;
}

# Clean up temporary objects and exit with the specified status.
sub exit_with($) {
    my ($exit_code) = @_;

    # Clean up temporary objects
    foreach my $object (@$main::temporary_objects) {
	if (-d $object) {
	    $object =~ s/'/'"'"'/g;
	    system("rm -rf '$object'");
	} else {
	    unlink $object;
	}
    }

    exit $exit_code;
}

sub signaled() {
    exit_with(2);
}

$SIG{INT} = \&signaled;
$SIG{TERM} = \&signaled;
$SIG{QUIT} = \&signaled;

sub INFO_FATAL		{ 1 }
sub INFO_PROGRESS	{ 2 }

# Print a message with given status.
sub inform($$) {
    my ($level, $message) = @_;

    if ($level == INFO_FATAL) {
	if ($parse_markers) {
	    print '[FATAL] ';
	} else {
	    print "Fatal: ";
	}
    } elsif ($level == INFO_PROGRESS) {
	print '[PROGRESS] '
	    if $parse_markers;
    }
    print "$message\n";
}

sub CHOICE_ABORT		    {   1 }
sub CHOICE_ALTERNATE_DRIVER_URL	    {   2 }
sub CHOICE_REUSE_OLD		    {   4 }
sub CHOICE_TRY_DOWNLOAD		    {   8 }
sub CHOICE_RETRY_DOWNLOAD	    {  16 }
sub CHOICE_IGNORE_MISSING_SIGNATURE {  32 }
sub CHOICE_SKIP			    {  64 }
sub CHOICE_ALTERNATE_KERNEL_URL	    { 128 }
sub CHOICE_FORCE_INSTALL	    { 256 }
sub CHOICE_FORCE_UPGRADE	    { 512 }

# Present a choice to the user.
#  keys: Hash of values that are substituted in messages and menu entries.
#  message: Message to display.
#  options: Bitwise combination of CHOICE_* constants.
sub choice($$$) {
    my ($keys, $message, $options) = @_;
    my $good;

    sub add_choice($$$$) {
	my ($options, $menu, $option, $text) = @_;

	if ($options & $option) {
	    push @$menu, [ $option, $text ];
	}
    }

    sub choice_substitute($$) {
	my ($keys, $text) = @_;

	$text =~ s/%{([^}]+)}/
	    exists $keys->{$1} ? $keys->{$1} : ""
	/ge;

	return $text;
    }

    $options |= CHOICE_ABORT;
    if ($DOWNLOAD_DRIVER_PACKAGES eq 'no') {
	$options &= ~(CHOICE_ALTERNATE_KERNEL_URL |
		      CHOICE_ALTERNATE_DRIVER_URL);
    }
    if ($require_signed_packages eq 'yes') {
	$options &= ~CHOICE_IGNORE_MISSING_SIGNATURE;
    }
    if ($REUSE_DRIVER_PACKAGES eq 'no') {
	$options &= ~CHOICE_REUSE_OLD;
    }

    if ($non_interactive) {
	for my $x ((CHOICE_TRY_DOWNLOAD,
		    CHOICE_IGNORE_MISSING_SIGNATURE,
		    CHOICE_REUSE_OLD)) {
	    if ($options & $x) {
		return $x;
	    }
	}
	return CHOICE_ABORT;
    }

    unless (exists $keys->{source}) {
	$options &= ~CHOICE_TRY_DOWNLOAD;
    }

    my $menu = [];

    add_choice $options, $menu, CHOICE_ALTERNATE_KERNEL_URL,
	_('Download the Kernel from an Alternate Download Location');

    add_choice $options, $menu, CHOICE_TRY_DOWNLOAD,
	_('Download Driver %{driver} from %{source}') .
	(exists $keys->{description} ? ' (%{description})' : '');

    add_choice $options, $menu, CHOICE_RETRY_DOWNLOAD,
	_('Retry Download of Driver %{driver} from %{source}') .
	(exists $keys->{description} ? ' (%{description})' : '');

    add_choice $options, $menu, CHOICE_ALTERNATE_DRIVER_URL,
	_('Download Driver %{driver} from an Alternate Download Location');

    add_choice $options, $menu, CHOICE_REUSE_OLD,
	_('Reuse Driver %{driver} from the Previous Kernel ' .
	  '%{old_kernel_version}');

    add_choice $options, $menu, CHOICE_IGNORE_MISSING_SIGNATURE,
	_('Use Package %{url} Although Not Signed');

    add_choice $options, $menu, CHOICE_SKIP,
	_('Skip Driver Package %{driver} (this may leave your system ' .
	  'unbootable!)');

    add_choice $options, $menu, CHOICE_FORCE_INSTALL,
	_('Force Package Installation');

    add_choice $options, $menu, CHOICE_FORCE_UPGRADE,
	_('Force Package Upgrade');

    add_choice $options, $menu, CHOICE_ABORT,
	($keys->{action} eq 'installation') ?
	    _('Abort the Kernel Installation') :
	    _('Abort the Kernel Upgrade');

    my $result;
    do {
	if ($options == CHOICE_ABORT) {
	    # This is the only choice left.
	    inform(INFO_FATAL, $message);
	    exit_with 1;
	}
	for(;;) {
	    print "\n";
		print '[MESSAGE] '
		    if ($parse_markers);
		print choice_substitute($keys, $message) . "\n";

	    print "\n";
	    for (my $n = 0; $n < @$menu; $n++) {
		if ($parse_markers) {
		    print '[OPTION ' . ($n+1) .
			(($menu->[$n][0] == CHOICE_ABORT) ? ': ABORT' : '') .
			  '] ';
		} else {
		    printf "%2d ", $n+1;
		}
		print choice_substitute($keys, $menu->[$n][1]) . "\n";
	    }
	    print "\n";
	    if ($parse_markers) {
		print "[READ OPTION]\n";
	    } else {
		print "> ";
	    }
	    $result = <STDIN>;
	    unless ($result) {
		$result = @$menu;
	    }
	    chomp $result;
	    if ($result && $result !~ /[^0-9]/ &&
		$result >= 1 && $result <= @$menu) {
		$result--;
		last;
	    }
	}

	if ($menu->[$result][0] == CHOICE_ABORT) {
	    exit_with 1;
	}
	
	if ($menu->[$result][0] == CHOICE_ALTERNATE_KERNEL_URL ||
	    $menu->[$result][0] == CHOICE_ALTERNATE_DRIVER_URL) {
	    print '[MESSAGE] '
		if ($parse_markers);
	    print _('Enter the URL:') . "\n";
	    if ($parse_markers) {
		print "[READ URL]\n";
	    } else {
		print "> ";
	    }
	    my $url = <STDIN>;
	    chomp $url;
	    delete $keys->{url};
	    $keys->{url} = $url
		if $url ne "";
	    $good=1;
	} else {
	    $good=1;
	}
    } until $good;

    return $menu->[$result][0];
}

# Compute the owning rpm packages for a list of files. Returns a hash
# in the form { 'file' => 'package', ... }.
sub rpm_owning_packages(@) {
    my @files = @_;
    my $cmd0 = "rpm -qf ";
    my $cmd = $cmd0;
    my @packages;
    my $package_map;

    foreach my $file (@files) {
	if (length($cmd) + length($file) + 3 >= sysconf _SC_ARG_MAX) {
	    my @l = `$cmd`;
	    map { chomp } @l;
	    push @packages, @l;
	    $cmd = $cmd0;
	    next;
	}
	$cmd .= " '$file'";
    }
    if ($cmd ne $cmd0) {
	my @l = `$cmd`;
	map { chomp } @l;
	push @packages, @l;
    }
    die "rpm -qf failed\n"
	if @files != @packages;
    foreach my $package (@packages) {
	if ($package =~ /^file .* is not owned by any package$/) {
	    undef $package;
	}
    }
    for (my $n = 0; $n < @files; $n++) {
	next unless $packages[$n];
	$package_map->{$files[$n]} = $packages[$n];
    }
    return $package_map;
}

# Filter duplicate values out of a list.
sub unique(@) {
    my @list = @_;

    my %hash = map { $_ => 1 } @list;
    return keys %hash;
}

# A wrapper to the find(1) command.
sub find($) {
    my ($args) = @_;

    my @files = `find $args`;
    map { chomp } @files;
    return @files;
}

# Find all kernel modules below $dir.
sub find_modules($) {
    my ($dir) = @_;
    return find("$dir -type f -name '\*.ko'");
}

# Check if two directory entries refer to the same file.
sub same_file($$) {
    my ($a, $b) = @_;

    my $sa = stat($a)
        or return 0;
    my $sb = stat($b)
        or return 0;

    return $sa->dev == $sb->dev &&
	   $sa->ino == $sb->ino;
}

# Return a list of all external modules found in
# /lib/modules/$kernel_version/{updates,updates2} and in the
# /lib/modules/*-override-* directory for that kernel.
sub external_modules($) {
    my ($kernel_version) = @_;
    my %modules;

    my $dir = "$basedir/lib/modules/$kernel_version";
    if (-d "$dir/updates") {
	foreach my $m (find_modules "$dir/updates") {
		my $k = $m;
		$k =~ s<.*/><>;
		$modules{$k} = $m;
	}
    }
    
    if (-d "$dir/updates2") {
	foreach my $m (find_modules "$dir/updates2") {
		my $k = $m;
		$k =~ s<.*/><>;
		$modules{$k} = $m;
	}
    }
    
    my $override = $kernel_version;
    $override =~ s/^([^-]+)-[^-]+-(.*)/$1-override-$2/;
    my $dir2 = "$basedir/lib/modules/$override";
    if (-d $dir2 && !same_file($dir2, "$dir/updates") &&
		    !same_file($dir2, "$dir/updates2")) {
	foreach my $m (find_modules "$dir/updates2") {
		my $k = $m;
		$k =~ s<.*/><>;
		$modules{$k} = $m;
	}
    }
    
    return sort values %modules;
}

# Return the file list for $package. $package can be a file or an installed
# package.
sub rpm_files($) {
    my ($package) = @_;
    my @files;
    my $fh;
    
    if (-f $package) {
	$fh = new FileHandle("rpm -qlp '$package' |");
    } else {
	$fh = new FileHandle("rpm -ql '$package' |");
    }
    unless ($fh) {
	die "$package: $!\n";
    }
    @files = <$fh>;
    map { chomp } @files;
    return [ @files ];
}

# Return selected tags from the rpm information of $package. $package can
# be a file or an installed package.
sub rpm_info($) {
    my ($package) = @_;
    my %info;

    my $fh = new FileHandle("rpm -q" .(-f $package ? "p" : "") .
			    " --qf '" . join("", map { "$_\\t%{$_}\\n" } qw(
			    name version release arch epoch license group
			    summary distribution description)) .
			    "' '$package' |");
    die "$package: $!\n"
	unless $fh;
    while (<$fh>) {
	chomp;
	/^(\S+)\t+(.*)/
	    or next;
	$info{$1} = $2;
	if ($1 eq 'description') {
	    while (<$fh>) {
		$info{description} .= "\n$_";
	    }
	    last;
	}
    }
    for (keys %info) {
	$info{$_} = undef
	if $info{$_} eq '(none)';
    }
    return { %info };
}

# Return the Provides and Requires lists of $package. $package can
# be a file or an installed package. The return value is structured
# like this:
# { 'provides' => { 'symbol' => '= version', ... },
#   'requires' => { 'symbol' => '{<,<=,=,>=,>} version', ... } }
sub rpm_reqprov($) {
    my ($package) = @_;
    my $tags;

    if (exists $main::rpm_reqprov_cache->{$package}) {
	return $main::rpm_reqprov_cache->{$package};
    }

    my $fh = new FileHandle("rpm -q" . (-f $package ? "p" : "") . " --qf '" .
	"[provides %{PROVIDENAME} %{PROVIDEFLAGS:depflags} " .
	    "%{PROVIDEVERSION}\n]" .
	"[requires %{REQUIRENAME} %{REQUIREFLAGS:depflags} " .
	    "%{REQUIREVERSION}\n]' $package |");
    unless ($fh) {
	die "$package: $!\n";
    }
    while (<$fh>) {
	/^(\S+)\s+(\S+)\s*(?:(\S+)\s+(\S+))?$/
	    or next;
	# FIXME: There can be multiple definitions ...
	$tags->{$1}{$2} = (defined $4) ? "$3 $4" : undef;
    }

    $main::rpm_reqprov_cache->{$package} = $tags;
    return $tags;
}

# Return selected fields from a kernel module's meta-information.
sub module_info($) {
    my ($module) = @_;
    my %info;

    my $fh = new FileHandle("$modinfo '$module' |")
	or die "$module: $!\n";
    while (<$fh>) {
	chomp;
	/^([^:]+):[ \t]*(.*)/
	    or next;
	push @{ $info{$1} }, $2;
    }
    foreach my $f (qw(filename srcversion depends supported vermagic)) {
	$info{$f} = $info{$f}[0]
	    if exists $info{$f};
    }
    return { %info };
}

# Return a hash of symbols that a module exports, together with the
# symbol's hash. The return value is structured as follows:
# { 'symbol' => 'hash', ... }
sub module_provided_symbols($) {
    my ($module) = @_;

    my $fh = new FileHandle("nm '$module' |")
	or die "$module: $!\n";
    my $symbols;
    while (<$fh>) {
	/^0*([0-9a-f]{8}) A __crc_(.*)/
	    or next;
	$symbols->{$2} = $1;
    }

    return $symbols;
}

# Return a hash of symbols that a module requires, together with the
# symbol's hash. The return value is structured as follows:
# { 'symbol' => 'hash', ... }
sub module_required_symbols($) {
    my ($module) = @_;

    my $fh = new FileHandle("$modprobe --dump-modversions '$module' |")
	or die "$module: $!\n";
    my $symbols;
    while (<$fh>) {
	/^(?:0x)?0*([0-9a-f]{8})\s+(\S+)/
	    or next;
	$symbols->{$2} = $1;
    }

    return $symbols;
}

# Extract the /boot/symvers-* symbol version table from a kernel package.
# The return value is structured as follows:
# { 'symbol' => 'hash', ... }
sub kernel_rpm_symvers($) {
    my ($package) = @_;

    my $tmpdir = mkdtemp("/var/tmp/$progname.XXXXXX")
	    or die "$!\n";
    register_temporary_object($tmpdir);
    my $symbols;
    system "rpm2cpio '$package' | " .
	   "( cd $tmpdir && cpio --quiet -id './boot/symvers-*')"
	and die sprintf(_('Failed to extract symbol versions from %s') . "\n",
			$package);

    foreach my $file (<$tmpdir/boot/symvers-*>) {
	my $fh = new FileHandle("gzip -cd $file |")
	    or die "$file: $!\n";
	while (<$fh>) {
	    /^(?:0x)?0*([0-9a-f]{8})\s+(\S+)/
		or next;
	    $symbols->{$2} = $1;
	}
	$fh->close;
    }

    return $symbols;
}

# Check if $package can be reused for kernel $kernel_version. $package can
# be a file or an installed package.
#  symvers: Symbols that this kernel exports.
sub rpm_check_symvers($$$) {
    my ($package, $kernel_version, $symvers) = @_;

    sub _rpm_check_symvers($$) {
	my ($modules, $symvers) = @_;
	
	# collect all defined symbols
	my $defined_symbols = { %$symvers };
	foreach my $module (@$modules) {
	    my $syms = module_provided_symbols($module);
	    foreach my $sym (keys %$syms) {
		if (exists $defined_symbols->{$sym}) {
		    if ($syms->{$sym} ne $defined_symbols->{$sym}) {
			my $m = $module;
			$module =~ s<.*/><>;
			die "$m: duplicate symbols $sym with different " .
			    "versions ($syms->{$sym} != " .
			    "$defined_symbols->{$sym})\n";
		    }
		}
		$defined_symbols->{$sym} = $syms->{$sym};
		#print "DEF: $syms->{$sym} $sym\n";
	    }
	}

	# check all required symbols
	foreach my $module (@$modules) {
	    my $syms = module_required_symbols($module);
	    foreach my $sym (keys %$syms) {
		unless (exists $defined_symbols->{$sym}) {
		    my $m = $module;
		    $module =~ s<.*/><>;
		    die "$m: symbol $sym not defined\n";
		}
		if ($syms->{$sym} ne $defined_symbols->{$sym}) {
		    my $m = $module;
		    $module =~ s<.*/><>;
		    die "$m: symbol $sym version differs " .
			"($syms->{$sym} != $defined_symbols->{$sym})\n";
		}
		#print "USE: $syms->{$sym} $sym\n";
	    }
	}
    }

    if (-f $package) {
	my $tmpdir = mkdtemp("/var/tmp/$progname.XXXXXX")
	    or die "$!\n";
	register_temporary_object($tmpdir);
	system "rpm2cpio '$package' | (cd $tmpdir && cpio -id --quiet " .
	       "'*.ko' < '$package')"
	    and die sprintf(_('Failed to extract modules from %s') . "\n",
			    $package);
	my @modules = find("$tmpdir -type f " .
	    "-path '*/lib/modules/$kernel_version/*.ko'");
	# FIXME: Fail if no modules are found!
	_rpm_check_symvers [ @modules ], $symvers;
	if ($@) {
	    die $@;
	}
    } else {
	my @modules = modules_for_kernel($package, $kernel_version);
	# FIXME: Fail if no modules are found!
	_rpm_check_symvers [ @modules ], $symvers;
    }
}

# Extract the list of module filenames for kernel $kernel_version.
sub modules_for_kernel($$) {
    my ($package, $kernel_version) = @_;
    my @modules;

    my $files = rpm_files($package);
    $kernel_version =~ s/\./\\./g;
    foreach my $file (@$files) {
	$file =~ m</lib/modules/$kernel_version/.*\.ko>
	    or next;
	push @modules, $file;
    }
    return @modules;
}

sub zap_prefix($$) {
    my ($path, $prefix) = @_;

    $path =~ s<^/*$prefix/*><>;
    return $path;
}

sub basename($) {
    my ($path) = @_;

    $path =~ s<.*/><>;
    return ($path eq '') ? '.' : $path;
}

# If $url is a local file, do nothing. If it looks like a url, try to
# download it using curl. Returns a local filename, undef, or dies.
sub fetch_url($) {
    my ($url) = @_;

    if (-f $url) {
	return $url;
    } elsif ($url =~ m<^[^:/\s]+://>) {
	my ($fh, $file) = mkstemp("/var/tmp/" . basename($url) . ".XXXXXX")
	    or die "$!\n";
	push @$main::temporary_objects, $file;
	inform INFO_PROGRESS, sprintf(_('Downloading %s...'), $url);
	system "curl -f -# -o $file '$url'";
	if (($? >> 8) == 22) {
	    # 4xx error (e.g., not found)
	    return undef;
	} elsif ($?) {
	    die sprintf(_('Failed to download %s'), "\n", $url);
	}
	# FIXME: proxy support
	# FIXME: support for authentication
	return $file;
    }
    return undef;
}

# Check a packages' integrity, and make sure it has been signed
#
# rpm --checksig answers:
# signed.rpm: (sha1) dsa sha1 md5 gpg OK
#	=> status 0
# foo.rpm: sha1 md5 OK
#	=> status 0
# bad.rpm: sha1 MD5 NOT OK
#	=> status 1
# signed.rpm: (SHA1) DSA sha1 md5 (GPG) NOT OK (MISSING KEYS: GPG#384e13cd)
#	=> status 1
#
sub check_package($$) {
    my ($package, $filename) = @_;
    my ($result, $message);

    my $output = `rpm -qp --checksig '$filename' 2>&1`;

    $output =~ s/$filename/$package/g;
    if ($? != 0 || $output !~ /\bsha1\b/ || $output !~ /\bmd5\b/) {
	print $output;
	return ('invalid', sprintf(_('Package %s integrity check failed'),
				   $package));
    }
    # FIXME: If the signing key is missing, give the user a hint how to
    # install that key.
    if ($output !~ /\bgpg\b/) {
	return ('unsigned', sprintf(_('Package %s is not signed'), $package));
    }
    return ('', '');
}

sub rpm_package_arch($) {
    my ($package) = @_;

    my $arch = `rpm -q --qf '%{ARCH}' '$package'`;
    return $arch;
}

# Return the list of YouPaths defined for the installed products.
sub you_product_paths() {
    my @you_paths;

    while (<$basedir/var/adm/YaST/ProdDB/prod_*>) {
	my $fh = new FileHandle($_);
	while (<$fh>) {
	    /^=YouPath: (.*)/
	        or next;
	    push @you_paths, $1;
	}
    }
    return @you_paths;
}

# Determine the download source for $package.
sub download_source($) {
    my ($package) = @_;
    my ($url, $description);

    my $db = "$module_download_db/$package";
    if (-e $db) {
	my $fh = new FileHandle($db)
	    or die "$db: $!\n";
	$_ = <$fh>;
	($url, $description) = m<(.*?)/*;(.*)>;
    }
    return undef
	unless defined $url;

    my $subst = "$module_download_db.conf";
    if (-e $subst) {
	my $fh = new FileHandle($subst)
	    or die "$subst: $!\n";
	while (<$fh>) {
	    s/(^|\s)#.*$//; s/\s+$//;
	    /^$/ and next;
	    if (/(\S+)\s+(\S+)/) {
		my $n;
		while (($n = index($url, $1)) != -1) {
		    $url = substr($url, 0, $n) . $2 .
			   (length($url) >= $n + length($1) + 1 ?
			    substr($url, $n + length($1) + 1) : '');
		}
	    }
	    if ($@) {
		print STDERR "$@\n";
	    }
	}
    }
    return ($url, $description);
}

sub dashes_to_underscores($) {
    my ($str) = @_;

    $str =~ s/-/_/g;
    return $str;
}

sub fetch_kernel_package($$) {
    my ($keys, $kernel_url) = @_;
    my ($status, $message);

  repeat_fetch_kernel:
    my $kernel_pkg = fetch_url($kernel_url);
    unless ($kernel_pkg) {
	$message = sprintf(_('Package %s not found'), $kernel_url);
	$status = 'missing';
    } else {
	($status, $message) = check_package($kernel_url, $kernel_pkg);
    }
    $keys->{url} = $kernel_url;
    if ($status eq 'unsigned' && $require_signed_packages ne 'no') {
	my $result = choice($keys, $message,
			    CHOICE_IGNORE_MISSING_SIGNATURE);
    } elsif ($status eq 'missing' || $status eq 'invalid') {
	my $result = choice($keys, $message, 0);
    }
    return $kernel_pkg;
}

sub fetch_driver_package($$) {
    my ($keys, $driver_url) = @_;
    my ($status, $message);
    my $driver_pkg;

  repeat_fetch_driver:
    $driver_pkg = fetch_url($driver_url);
    unless ($driver_pkg) {
	$message = sprintf(_('Package %s not found'), $driver_url);
	$status = 'missing';
    } else {
	($status, $message) = check_package($driver_url, $driver_pkg);
    }
    my $result;
    if ($status eq 'unsigned' && $require_signed_packages ne 'no') {
	$result = choice($keys, $message,
			 CHOICE_IGNORE_MISSING_SIGNATURE);
    } elsif ($status eq 'missing' || $status eq 'invalid') {
	$result = choice($keys, $message, 0);
    }
    return $driver_pkg;
}

# Convert from a kernel's rpm info to a kernelrelease string.
sub info_to_kernelrelease($) {
    my ($info) = @_;

    my $flavor = $info->{name};
    $flavor =~ s/^kernel-//;
    return "$info->{version}-$info->{release}-$flavor";
}

# Convert from a packages' rpm info to a name-version-release string.
sub info_to_nvr($) {
    my ($info) = @_;

    return "$info->{name}-$info->{version}-$info->{release}";
}

# Split a name-version-release string into its three individual fields.
sub split_nvr($) {
    my ($nvr) = @_;

    return ($nvr =~ /^(.+)-([^-]+)-([^-]+)$/);
}

# Check if $symbol is provided in a requires/provides structure (see
# rpm_reqprov).
sub is_provided($$) {
    my ($symbol, $reqprov) = @_;

    return exists $reqprov->{provides}{$symbol};
}

# Check if a symbol is required in s apsecific version in a requires/provides
# structure (see rpm_reqprov).
sub is_required($$$) {
    my ($symbol, $version, $reqprov) = @_;

    return exists $reqprov->{requires}{$symbol} &&
	   (!defined $version ||
	    $reqprov->{requires}{$symbol} eq "= $version");
}

# Check if a requires/provides structure includes a requirement for
# $kernel_version.
sub requires_kernel($$) {
    my ($kernel_version, $reqprov) = @_;
    my ($ver_rel, $flavor) = ($kernel_version =~ /^([^-]+-[^-]+)-(.*)/);

    return is_required("kernel",         "$ver_rel", $reqprov) ||
	   is_required("kernel-$flavor", "$ver_rel", $reqprov);
}

# Check if an old driver is reusable for a new kernel.
sub old_driver_reusable($$$$) {
    my ($driver, $old_kernel_version, $kernel_url, $kernel_pkg) = @_;

    return undef
	if $REUSE_DRIVER_PACKAGES eq 'no';

    return $main::old_driver_reusable->{$driver}
	if defined $main::old_driver_reusable->{$driver};
    
    unless ($main::symvers) {
	# Get the list of symbols exported by the kernel, needed for
	# later checking for modversion conflicts.
	inform INFO_PROGRESS,
	       sprintf _('Extracting symbol versions from %s'), $kernel_url;
	
	$main::symvers = kernel_rpm_symvers($kernel_pkg);
    }

    eval {
	rpm_check_symvers($driver, $old_kernel_version, $main::symvers);
    };

    $main::main::old_driver_reusable->{$driver} = $@ ? 0 : 1;
    return $main::old_driver_reusable->{$driver};
}

# Create a wrapper package for $driver / $old_version / $flavor for kernel
# $new_version. Returns the filename of the wrapper package.
sub reuse_package($$$$) {
    my ($driver, $old_version, $new_version, $flavor) = @_;
    my ($name, $version, $release) = split_nvr($driver);

    my $_flavor = $flavor ? "_$flavor" : "";
    my ($fh, $file) = mkstemp("/var/tmp/$name-$version-$old_version$_flavor" .
			      "_for_$new_version$_flavor-$release.rpm.XXXXXX")
	or die "$!\n";
    register_temporary_object($file);
    $fh->close();
    my $opt_flavor = $flavor ? "--flavor $flavor" : "";
    my $opt_verbose = $verbose ? "--verbose" : "";

    my $cmd = "/usr/share/kernel-update-tool/repackage-for-reuse $opt_flavor $opt_verbose " .
	   "$driver $old_version $new_version > $file";
    print "$cmd\n"
	if $verbose;
    system($cmd);
    return $file;
}

my ($result, $message);

if ($action eq 'status' || $action eq 'upgrade' || $action eq 'install') {
    $old_kernel_version =~ /^([^-]+)-([^-]+)-(.*)/
	or die sprintf(_('Kernel version %s is not in the form ' .
			 '$version-$release-$flavor') . "\n",
		       $old_kernel_version);
    my $old_package = "kernel-$3-$1-$2";
    system("rpm -q $old_package > /dev/null");
    die sprintf(_('Kernel package %s is not installed') . "\n", $old_package)
	if $?;
}

if ($action eq 'status') {
    @ARGV and usage(1);

    my $dir = "$basedir/lib/modules/$old_kernel_version";

    printf _('Kernel Version: %s') . "\n", $old_kernel_version;
    my @modules = external_modules $old_kernel_version;
    my $owning_packages = rpm_owning_packages @modules;
    foreach my $driver (sort unique values %$owning_packages) {
	printf _('Driver Package: %s') . "\n", $driver;
    }
    my $owners = rpm_owning_packages @modules;
    foreach my $module (@modules) {
	print _('Module: ') . zap_prefix($module, $dir);
	my @attrs;
	if (exists $owners->{$module}) {
	    push @attrs, $owners->{$module};
	} else {
	    push @attrs, _('No owner');
	}
	my $info = module_info($module);
	my $v = $info->{"vermagic"};
	$v =~ s/ .*//;
	if ($old_kernel_version ne $v) {
	    push @attrs, $v;
	}
	if (@attrs) {
	    print " (" . join(", ", @attrs), ")\n";
	}
	# list supported hardware?
	# check modversions?
    }
} elsif ($action eq 'upgrade' || $action eq 'install') {
    @ARGV >= 1 or usage(1);
    my ($kernel_url, @driver_urls) = @ARGV;

    my $keys;
    $keys->{action} = $action;
    $keys->{old_kernel_version} = $old_kernel_version;

    my ($status, $message);
    my $kernel_pkg = fetch_kernel_package($keys, $kernel_url);
    my $new_kernel_info = rpm_info($kernel_pkg);
    my $new_kernel_version = info_to_kernelrelease($new_kernel_info);
    $keys->{new_kernel_version} = $new_kernel_version;

    inform INFO_PROGRESS, sprintf(_('Upgrade from kernel %s to %s'),
	  $old_kernel_version, $new_kernel_version);

    my $new_dpkgs;
    for my $driver_url (@driver_urls) {
	$keys->{driver} = $driver_url;
	$keys->{url} = $driver_url;
	my $driver_pkg = fetch_driver_package($keys, $driver_url);
	my $info = rpm_info($driver_pkg);
	my $reqprov = rpm_reqprov($driver_pkg);
	unless (requires_kernel($new_kernel_version, $reqprov)) {
	    $message = sprintf(_("Package %s must require kernel %s, but it " .
				 "does not"),
			       $driver_url, $new_kernel_version);
	    $result = choice($keys, $message,
			     CHOICE_SKIP);
	    next;
	}

	# FIXME: check for duplicates
	$new_dpkgs->{$info->{name}} = $info;
	$new_dpkgs->{$info->{name}}{package} = $driver_pkg;
    }

    my $old_dpkgs;
    my @old_modules = external_modules $old_kernel_version;
    my $owning_packages = rpm_owning_packages @old_modules;
    # FIXME: check for drivers that are not owned by a driver package
    foreach my $driver (sort unique values %$owning_packages) {
	my ($name, $version, $release) = split_nvr($driver);
	$old_dpkgs->{$name} = {
	    version => $version,
	    release => $release,
	};
    }

    my $new_kernel_reqprov;

    # Go through the list of driver packages for the old kernel, and
    # see how to deal with each one.
  driver:
    foreach my $name (sort keys %$old_dpkgs) {
	my $old_nvr = "$name-$old_dpkgs->{$name}{version}-" .
		      "$old_dpkgs->{$name}{release}";
	$keys->{driver} = $name;
	my $try_urls;

	# Fetch the kernel's Requires and Provides definitions
	unless ($new_kernel_reqprov) {
	    $new_kernel_reqprov = rpm_reqprov($kernel_pkg);
	}

	# Does the new kernel include this driver?
	if (is_provided($name, $new_kernel_reqprov)) {
	    inform INFO_PROGRESS, sprintf(_('Kernel %s includes driver %s'),
					  $new_kernel_version, $name);
	    # FIXME: Check if the same driver is in %$new_dpkgs and fail
	    # if it is.
	    next driver;
	}
	
	# Is a suitable driver already installed?
	foreach my $name2 (`rpm -q --whatprovides $name`) {
	    chomp $name2;
	    my $reqprov = rpm_reqprov($name2);
	    unless (is_provided($name, $reqprov)) {
		die "Oops!";
	    }
	    if (requires_kernel($new_kernel_version, $reqprov)) {
		inform INFO_PROGRESS, sprintf(_('Installed package %s ' .
						'supports driver %s for ' .
						'kernel %s'),
					      $name2, $name,
					      $new_kernel_version);
		if ($action eq 'upgrade') {
		    # FIXME: rpm won't remove the old driver package when
		    # a succesor for the driver module is already installed;
		    # it would if it would install the successor as well.
		    # We remove the old package by hand now, but this
		    # probably won't work in SLES10 with the new package
		    # manager anymore. It's a weird corner case only anyway.
		}
		$new_dpkgs->{$name}{erase} = $old_nvr;
		next driver;
	    }
	}

	# Was a replacement driver package specified on the command line?
	foreach my $name2 (keys %$new_dpkgs) {
	    my $name3 = $new_dpkgs->{$name2}{package};
	    my $driver_reqprov = rpm_reqprov($name3);
	    if (is_provided($name, $driver_reqprov) &&
		requires_kernel($new_kernel_version, $driver_reqprov)) {
		#inform INFO_PROGRESS, sprintf(_('Package %s provides %s'),
		#			      info_to_nvr($new_dpkgs->{$name2}),
		#			      $name2);
		next driver;
	    }
	}

	my $arch;

	# Try to download a suitable driver
	delete $keys->{source};
	delete $keys->{description};
	if ($DOWNLOAD_DRIVER_PACKAGES ne 'no') {
	    my ($base, $description) = download_source($name);
	    if (defined $base) {
		$keys->{source} = $base;
		$keys->{description} = $description;
	    }
	    $arch = rpm_package_arch($name);
	}

	if (exists $keys->{source} && $DOWNLOAD_DRIVER_PACKAGES eq 'yes') {
	    # Try download without asking first
	} elsif ($DOWNLOAD_DRIVER_PACKAGES eq 'ask' ||
		 $REUSE_DRIVER_PACKAGES eq 'ask') {
	    my $reusable_package = old_driver_reusable(
		$old_nvr, $old_kernel_version, $kernel_url, $kernel_pkg);
	  bad_choice:
	    $result = choice($keys, sprintf(_('Action for driver package %s:'),
					      $name),
			     CHOICE_TRY_DOWNLOAD |
			     CHOICE_ALTERNATE_DRIVER_URL |
			     ($reusable_package ? CHOICE_REUSE_OLD : 0) |
			     CHOICE_SKIP);
	    if ($result == CHOICE_TRY_DOWNLOAD) {
		goto try_download;
	    } elsif ($result == CHOICE_ALTERNATE_DRIVER_URL) {
		goto bad_choice
		    unless defined $keys->{url};
		$keys->{source} = $keys->{url};
		delete $keys->{description};
		goto try_download;
	    } elsif ($result == CHOICE_REUSE_OLD) {
		$new_dpkgs->{$name}{reuse} = $old_nvr;
		inform INFO_PROGRESS, sprintf(_('Reusing package %s'),
					      $new_dpkgs->{$name}{reuse});
		next driver;
	    } elsif ($result == CHOICE_SKIP) {
		$new_dpkgs->{$name}{erase} = $old_nvr;
		next driver;
	    }
	}

      try_download:
	if (exists $keys->{source}) {
	    @$try_urls = [];
	    foreach my $product_path (you_product_paths) {
		my $prefix = "$keys->{source}/$product_path/rpm/$arch/$name";
		
		# We usually expect driver packages to contain modules for
		# all kernel flavors. Strip off the flavor.
		my $v1 = $new_kernel_version;
		$v1 =~ s/^([^-]+-[^-]+).*/$1/;
		$v1 = dashes_to_underscores($v1);
		push @$try_urls, "$prefix-$v1.$arch.rpm";

		# Also allow single-flavor driver packages.
		my $v2 = dashes_to_underscores($new_kernel_version);
		push @$try_urls, "$prefix-$v2.$arch.rpm";
	    }
	}

	my $filename;
	delete $keys->{url};
	foreach my $url (@$try_urls) {
	    eval { $filename = fetch_url $url };
	    if ($filename) {
		$keys->{url} = $url;
		last;
	    }
	}

	if (defined $filename) {
	    ($status, $message) = check_package($keys->{url}, $filename);
	    if ($status eq 'unsigned' && $require_signed_packages eq 'no') {
		$status = '';
	    }
	} else {
	    my $reusable_package = old_driver_reusable(
		$old_nvr, $old_kernel_version, $kernel_url, $kernel_pkg);
	    if ($reusable_package && $REUSE_DRIVER_PACKAGES eq 'yes') {
		# No file to download found, so reuse 
		goto reuse_old_driver_package;
	    }
	    $status = 'failed';
	    if (@$try_urls) {
		$message = sprintf(_('Failed to fetch driver package %s ' .
				     'from %s'),
				   $name, $keys->{source});
	    } else {
		$message = sprintf(_('No download source known for ' .
				     'driver package %s'),
				   $name);
	    }
	}
	unless ($status) {
	    my $reqprov = rpm_reqprov($filename);
	    if (!requires_kernel($new_kernel_version, $reqprov)) {
		$status = 'invalid';
		$message = sprintf(_("Package %s must require kernel %s, but " .
				     "it does not"),
				   $keys->{url}, $new_kernel_version);
	    }
	    if (!$status && !is_provided($name, $reqprov)) {
		$status = 'invalid';
		$message = sprintf(_("Package %s does not provide symbol %s"),
				  $name);
	    }
	}
	if ($status) {
	    my $reusable_package = old_driver_reusable(
		$old_nvr, $old_kernel_version, $kernel_url, $kernel_pkg);
	  bad_choice:
	    $result = choice($keys, $message,
			     CHOICE_RETRY_DOWNLOAD |
			     CHOICE_ALTERNATE_DRIVER_URL |
			     ($status eq 'unsigned' ?
				 CHOICE_IGNORE_MISSING_SIGNATURE : 0) |
			     ($reusable_package ? CHOICE_REUSE_OLD : 0) |
			     CHOICE_SKIP);

	    if ($result == CHOICE_RETRY_DOWNLOAD) {
		goto try_download;
	    } elsif ($result == CHOICE_ALTERNATE_DRIVER_URL) {
		goto bad_choice
		    unless defined $keys->{url};
		$keys->{source} = $keys->{url};
		delete $keys->{description};
		goto try_download;
	    } elsif ($result == CHOICE_IGNORE_MISSING_SIGNATURE) {
		$new_dpkgs->{$name} = rpm_info($filename);
		$new_dpkgs->{$name}{url} = $keys->{url};
		$new_dpkgs->{$name}{package} = $filename;
		inform INFO_PROGRESS, sprintf(_('Using package %s'), $name);
		next driver;
	    } elsif ($result == CHOICE_REUSE_OLD) {
	  reuse_old_driver_package:
		$new_dpkgs->{$name}{reuse} = $old_nvr;
		inform INFO_PROGRESS, sprintf(_('Reusing package %s'),
					      $new_dpkgs->{$name}{reuse});
		next driver;
	    } elsif ($result == CHOICE_SKIP) {
		$new_dpkgs->{$name}{erase} = $old_nvr;
		next driver;
	    }
	} else {
	    $new_dpkgs->{$name} = rpm_info($filename);
	    $new_dpkgs->{$name}{url} = $keys->{url};
	    $new_dpkgs->{$name}{package} = $filename;
	    inform INFO_PROGRESS, sprintf(_('Using package %s'), $name);
	    next driver;
	}

	inform INFO_FATAL, sprintf(_('No replacement for driver package ' .
				     '%s; aborting'), $name);
	# FIXME: Inform the user how this can be resolved: sysconfig
	# settings to get interaction, install driver first (does this
	# actually work?). Add setting to still continue without this
	# driver.
	exit_with 1;
    }

    # Create wrapper packages for packages that we want to reuse from the
    # old kernel.
    foreach my $name (keys %$new_dpkgs) {
	if (exists $new_dpkgs->{$name}{reuse}) {
	    my $old = $new_dpkgs->{$name}{reuse};

	    my ($old_version) =
	        ($old_kernel_version =~ /^([^-]+-[^-]+)-.+/);
	    my ($new_version, $flavor) =
		($new_kernel_version =~ /^([^-]+-[^-]+)-(.+)/);

	    my $old_reqprov = rpm_reqprov($old);
	    if (exists $old_reqprov->{requires}{kernel}) {
		# this is a multi-flavor package.
		$flavor = undef;
	    }

	    my $rpm = reuse_package($old, $old_version, $new_version, $flavor);
	    $new_dpkgs->{$name}{package} = $rpm;
	}
    }

    # Construct the rpm command that removes skipped packages when
    # doing an upgrade: if we don't, rpm will complain about broken
    # dependencies.
    my $remove_pkgs;
    if ($action eq 'upgrade') {
	foreach my $name (sort keys %$new_dpkgs) {
	    $remove_pkgs->{$name} = $new_dpkgs->{$name}{erase}
		if exists $new_dpkgs->{$name}{erase};
	}
    }
    if ($remove_pkgs) {
	my $cmd = "rpm --erase" . ($dry_run ? ' --test' : '');
	foreach my $pkg (sort keys %$remove_pkgs) {
	    $cmd .= " " . $remove_pkgs->{$pkg};
	}
	print "$cmd\n"
	    if ($verbose);
	system($cmd);
	if ($?) {
	    inform INFO_FATAL,
		sprintf(_('Removing %s failed'),
			join(", ", sort keys %$remove_pkgs));
		exit_with 1;
	}
    }

    # Construct the rpm command that installs all the new packages.
    my $install_pkgs;
    $install_pkgs->{info_to_nvr($new_kernel_info)} = $kernel_pkg;
    foreach my $name (sort keys %$new_dpkgs) {
	$install_pkgs->{$name} = $new_dpkgs->{$name}{package}
	    if exists $new_dpkgs->{$name}{package};
    }
    if ($install_pkgs) {
	inform INFO_PROGRESS, $action eq 'install' ?
	    _('Installing packages') : _('Upgrading packages');

	my $mode = $force ? ' --force --nodeps' : '';
      repeat_rpm:
	my $cmd = "rpm --$action$mode" . ($dry_run ? ' --test' : '');
	foreach my $pkg (map { $install_pkgs->{$_} } sort keys %$install_pkgs) {
	    $cmd .= " " . $pkg;
	}
	print "$cmd\n"
	    if ($verbose);
	system($cmd);

	if ($? && $mode eq '') {
	    $result = choice($keys, sprintf(
		($action eq 'install' ? _('Installing %s failed') :
					_('Upgrading %s failed')),
		join(", ", sort keys %$install_pkgs)),
		 $action eq 'install' ? CHOICE_FORCE_INSTALL :
					CHOICE_FORCE_UPGRADE);
	    $mode = ' --force --nodeps';
	    goto repeat_rpm;
	}
    }
    if ($?) {
	inform INFO_FATAL,
	    sprintf(($action eq 'install' ?
		         _('Installing %s failed') :
			 _('Upgrading %s failed')),
		    join(", ", sort keys %$install_pkgs));
	    exit_with 1;
    }
} else {
    usage(1);
}

exit_with 0;

# vim:shiftwidth=4 softtabstop=4
