File kmp-install of Package suse-module-tools

#!/usr/bin/perl
#
# KMP-INSTALL: Install specified kernel module packages and automatically
#              remove packages providing same-named modules.
#
# Copyright (c) 2014 SUSE
#
# Permission is hereby granted, free of charge, to any person obtaining
# a copy of this software and associated documentation files (the
# "Software"), to deal in the Software without restriction, including
# without limitation the rights to use, copy, modify, merge, publish,
# distribute, sublicense, and/or sell copies of the Software, and to
# permit persons to whom the Software is furnished to do so, subject to
# the following conditions:
#
# The above copyright notice and this permission notice shall be
# included in all copies or substantial portions of the Software.
#
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
# MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT.
# IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY
# CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT,
# TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE
# SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.

use strict;
use warnings;

use IO::Handle;
use File::Find;

my @zypper_cmd = qw(zypper);

sub print_help {
	print
"Usage: $0 [options] <package> ...
Installs given packages and removes any KMPs that contain conficting module
names. Run 'zypper help install' for the list of valid options. Additionally,
the options --non-interactive and --non-interactive-include-reboot-patches
can be used\n";
}

sub add_package {
	my ($list, $attr) = @_;

	return unless $attr->[0] =~ /-kmp-/;
	my $new = {
		name =>    $attr->[0],
		version => $attr->[1],
		arch =>    $attr->[2],
	};
	$new->{repo} = $attr->[3] if defined($attr->[3]);
	# old-version -> new-version
	$new->{version} =~ s/.*->\s*//;
	push(@$list, $new);
}

sub add_module {
	my ($package, $path) = @_;

	return unless $path =~ m@^/lib/modules/([^/]+)/.*/([^/]+\.ko)$@;
	my ($version, $name) = ($1, $2);
	$name =~ s/-/_/g;
	$package->{modules} ||= [];
	push(@{$package->{modules}}, "$version/$name");
}

sub query_installed_kmps {
	my $res = shift;
	my %seen;

	open(my $pipe, '-|', "rpm", "-qa", "--qf", '[%{n} %{v} %{r} %{arch} %{filenames}\n]', "*-kmp-*");
	while (<$pipe>) {
		chomp;
		my ($n, $v, $r, $a, $file) = split(' ');
		next unless $file =~ m@^/lib/modules/.*/.*/.*\.ko$@;
		my $nvra = "$n-$v-$r.$a";
		if (!exists($seen{$nvra})) {
			add_package($res, [$n, "$v-$r", $a]);
			$seen{$nvra} = $res->[$#$res];
		}
		add_module($seen{$nvra}, $file);
	}
}


sub fetch_packages {
	my $interactive = shift;
	my $new_pkgs = shift;
	my $remove_pkgs = shift;

	my @cmd = @zypper_cmd;
	push(@cmd, "--non-interactive") if !$interactive;
	push(@cmd, qw(-vv install --download-only));
	push(@cmd, @_);
	pipe(READ, WRITE);
	my $pid = fork();
	if (!$pid) {
		# child
		close(READ);
		open(STDOUT, ">&WRITE");
		if (!$interactive) {
			open(NULL, '<', "/dev/null");
			open(STDIN, "<&NULL");
			close(NULL);
			open(NULL, '>', "/dev/null");
			open(STDERR, ">&NULL");
			close(NULL);
		}
		exec(@cmd);
	}
	# parent
	close(WRITE);
	my ($len, $buf, $last_line);
	my ($state, @cur_pkg);
	$state = 0;
	$last_line = "";
	my $list;
	STDOUT->autoflush(1);
	while (($len = sysread(READ, $buf, 4096))) {
		print $buf if $interactive;
		my @lines = split(/\n/, $buf, -1);
		$lines[0] = $last_line . $lines[0];
		# XXX: Assumes that the very last line is terminated by \n
		$last_line = pop(@lines);
		for my $l (@lines) {
			if ($state == 0 && $l =~ /^The following.* package.* going to be (installed|upgraded|downgraded|REMOVED):/) {
				if ($1 eq "REMOVED") {
					$list = $remove_pkgs;
				} else {
					$list = $new_pkgs;
				}
				$state = 1;
				next;
			}
			next unless $state == 1;
			if ($l eq "") {
				$state = 0;
				if (@cur_pkg) {
					add_package($list, \@cur_pkg);
				}
				@cur_pkg = ();
				next;
			}
			$l =~ s/ *$//;
			if ($l =~ /^[^ ]/) {
				if (@cur_pkg) {
					add_package($list, \@cur_pkg);
				}
				@cur_pkg = ($l);
			}
			if ($l =~ /^ /) {
				$l =~ s/^ *//;
				push(@cur_pkg, $l);
			}
		}
	}
	STDOUT->autoflush(0);
	close(READ);
	waitpid($pid, 0);
	return $?;
}

my %repo_cache;
sub get_repo_cache {
	my $name = shift;
	my $res;

	if (exists($repo_cache{$name})) {
		return $repo_cache{$name};
	}
	open(my $pipe, '-|', "zypper", "repos", $name);
	while (<$pipe>) {
		chomp;
		if (m@^MD Cache Path\s*:\s*(/.*)@) {
			$res = $1;
			$res =~ s:/raw/:/packages/:;
			$res =~ s/\s*$//;
		}
	}
	close($pipe);
	$repo_cache{$name} = $res;
	return $res;
}

sub find_fetched {
	my $packages = shift;
	my %local_packages;

	for $a (@_) {
		if ($a =~ /\.rpm$/ && -e $a) {
			open(my $pipe, '-|', "rpm", "-qp", "--qf",
				'%{n}-%{v}-%{r}.%{arch}', $a);
			my $nvra = <$pipe>;
			close($pipe);
			if (defined($nvra)) {
				$local_packages{$nvra} = $a;
			}
		}
	}
	for my $p (@$packages) {
		my $nvra = "$p->{name}-$p->{version}.$p->{arch}";
		if ($p->{repo} eq "Plain RPM files cache") {
			if (exists($local_packages{$nvra})) {
				$p->{path} = $local_packages{$nvra};
			} else {
				print STDERR "Cannot find package $p->{name}\n";
			}
			next;
		}
		my $dir = get_repo_cache($p->{repo});
		if (!$dir) {
			print STDERR "Cannot find zypp cache for repository $p->{repo} (package $p->{name})\n";
			next;
		}
		my $file = "$nvra.rpm";
		my $wanted = sub {
			$p->{path} = $File::Find::name if $_ eq $file;
		};
		find($wanted, $dir);
		if (!$p->{path}) {
			print STDERR "Cannot find $file in zypp cache ($dir)\n";
			next;
		}
	}
	for my $p (@$packages) {
		next unless $p->{path};
		open(my $pipe, '-|', "rpm", "-qlp", $p->{path});
		my @files = <$pipe>;
		close($pipe);
		for my $f (@files) {
			add_module($p, $f);
		}
	}
}

# treat -n, --non-interactive, -0 and --non-interactive-include-reboot-patches
# as global zypper options
my @save_argv = @ARGV;
@ARGV=();
for my $a (@save_argv) {
	if ($a =~ /^-(h|-help)$/) {
		print_help();
		exit 0;
	} elsif ($a =~ /^-(n$|-non-interactive$|0$|-non-interactive-)/) {
		push(@zypper_cmd, $a);
	} else {
		push(@ARGV, $a);
	}
}
if (!@ARGV) {
	print_help();
	exit 1;
}

print "Fetching packages\n";
my (@new_pkgs, @remove_pkgs, @installed_pkgs);
my $ret = fetch_packages(0, \@new_pkgs, \@remove_pkgs, @ARGV);
if ($ret != 0) {
	print "zypper returned an error, retrying in interactive mode\n";
	@new_pkgs = ();
	@remove_pkgs = ();
	$ret = fetch_packages(1, \@new_pkgs, \@remove_pkgs, @ARGV);
}
if ($ret != 0) {
	exit 1;
}
find_fetched(\@new_pkgs, @ARGV);
query_installed_kmps(\@installed_pkgs);

# Do not check packages to be updated/removed for module conflicts
my (%new_pkgs, %remove_pkgs);
for my $p (@remove_pkgs) {
	my $nvra = "$p->{name}-$->{version}.$p->{arch}";
	$remove_pkgs{$nvra} = 1;
}
for my $p (@new_pkgs) {
	$new_pkgs{$p->{name}} = 1;
}
my @tmp = @installed_pkgs;
@installed_pkgs = ();
for my $p (@tmp) {
	my $nvra = "$p->{name}-$->{version}.$p->{arch}";
	next if $new_pkgs{$p->{name}} || $remove_pkgs{$nvra};
	push(@installed_pkgs, $p);
}

# check for conflicts
my %new_modules;
for my $p (@new_pkgs) {
	next unless $p->{modules};
	for my $m (@{$p->{modules}}) {
		$new_modules{$m} = $p->{name};
	}
}
my @conflicting_pkgs;
for my $p (@installed_pkgs) {
	next unless $p->{modules};
	for my $m (@{$p->{modules}}) {
		next unless exists($new_modules{$m});
		print "Package $p->{name} conflicts with new package $new_modules{$m}\n";
		push(@conflicting_pkgs, $p);
		last;
	}
}

# Install new packages, removing conflicting installed packages
my @cmd = (@zypper_cmd, "install", @ARGV);
for my $p (@conflicting_pkgs) {
	push(@cmd, "!$p->{name}.$p->{arch}=$p->{version}");
}
print join(" ", "Running", @cmd), "\n";
if (system(@cmd) != 0) {
	exit 1;
}
exit 0;