pesign-obs-integration/pesign-gen-repackage-spec

#!/usr/bin/perl
# Given a set of rpm packages and directory with their new content,
# generate a specfile that generates new packages
#
# Copyright (c) 2013 SUSE Linux Products GmbH, Nuernberg, Germany.
#
# 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

use strict;
use warnings;

my $USAGE = "Usage: $0 --directory <payload directory> rpm...\n";

use Getopt::Long;
use Fcntl qw(:mode :seek);

my $directory;
my $output = ".";
my @rpms;

$ENV{LC_ALL} = "en_US.UTF-8";

GetOptions(
	"help|h" => sub { print $USAGE; exit; },
	"directory|d=s" => \$directory,
	"output|o=s" => \$output,
) or die $USAGE;
@rpms = @ARGV;
if (!@rpms) {
	print STDERR "$0: No packages given\n";
	die $USAGE;
}
if (!$directory || substr($directory, 0, 1) ne '/' || ! -d $directory) {
	print STDERR "$0: --directory must be an absolute path\n";
	die $USAGE;
}

sub query_array {
	my ($rpm, @tags) = @_;
	my @res;

	my $format = "[" . join("|", map { "\%{$_}" } @tags) . "\\n]";
	open(my $fh, '-|', "rpm", "-qp", "--qf", $format, $rpm)
		or die "rpm: $!\n";
	while (<$fh>) {
		chomp;
		my @t = split(/\|/, $_, -1);
		push(@res, \@t);
	}
	close($fh);
	return @res;
}

sub query_single {
	my ($rpm, $tag) = @_;
	my $res;

	open(my $fh, '-|', "rpm", "-qp", "--qf", "\%{$tag}\\n", $rpm)
		or die "rpm: $!\n";
	{
		local $/ = undef;
		$res = <$fh>;
	}
	chomp $res;
	if ($res eq "(none)") {
		$res = "";
	}
	close($fh);
	return $res;

}

# specfile dependency => rpm tag name
my %dep2tag = (
	conflicts => "conflict",
	obsoletes => "obsolete",
	provides => "provide",
	requires => "require",
	suggests => "suggests",
	enhances => "enhances",
);

# strong version of suggests and enhances
my %dep2strong = (
	suggests => "recommends",
	enhances => "supplements",
);

# specfile scriptlet => rpm tag name
my %script2tag = (
	pre          => "prein",
	post         => "postin",
	preun        => "preun",
	postun       => "postun",
	pretrans     => "pretrans",
	posttrans    => "posttrans",
	verifyscript => "verifyscript",
	# FIXME: triggers
);

# tags which are printed verbatim in the specfile
my @simple_tags = qw(version release license group summary packager vendor
                     url distribution);

sub load_package {
	my $rpm = shift;
	my %res;

	for my $tag (qw(name arch sourcerpm description), @simple_tags) {
		$res{$tag} = query_single($rpm, $tag);
	}
	my @files;
	my @list = query_array($rpm, qw(filenames fileflags filemodes fileusername filegroupname filesizes filemtimes filelinktos));
	for my $file (@list) {
		push(@files, {
				name   => $file->[0],
				flags  => $file->[1],
				mode   => $file->[2],
				owner  => $file->[3],
				group  => $file->[4],
				size   => $file->[5],
				mtime  => $file->[6],
				target => $file->[7],
		});
	}
	$res{files} = \@files;
	while (my ($dep, $tag) = each(%dep2tag)) {
		my @deps;
		my @list = query_array($rpm, "${tag}name", "${tag}flags", "${tag}version");
		for my $d (@list) {
			next if $d->[0] eq "(none)";
			push(@deps, {
					name => $d->[0],
					flags => $d->[1],
					version => $d->[2],
			});
		}
		$res{$dep} = \@deps;
	}

	while (my ($script, $tag) = each(%script2tag)) {
		my $s = query_single($rpm, $tag);
		next unless $s && $s ne "(none)";
		my $interp = query_single($rpm, "${tag}prog");
		$res{$script} = {
			interp => $interp,
			script => $s,
		};
	}
	open(my $fh, '-|', "rpm", "-qp", "--changelog", $rpm) or die "rpm: $!\n";
	{
		local $/ = undef;
		my $changelog = <$fh>;
		close($fh);
		$res{changelog} = $changelog;
	}

	return \%res;
}

# quote percent signs in text
sub quote {
	my $text = shift;

	$text =~ s/%/%%/g;
	return $text;
}

sub print_package {
	my ($p, $is_main) = @_;

	if ($is_main) {
		print SPEC "Name: $p->{name}\n";
		print SPEC "Buildroot: $directory\n";
		print SPEC "\%define _use_internal_dependency_generator 0\n";
		print SPEC "\%define __find_provides %{nil}\n";
		print SPEC "\%define __find_requires %{nil}\n";
		print SPEC "\%define __find_supplements %{nil}\n";
		if ($p->{nosource}) {
			# We do not generate any no(src).rpm, but we want the
			# %{sourcerpm} tag in the binary packages to match.
			# So we add a dummy source and mark it as nosource.
			print SPEC "Source0: repackage.spec\n";
			print SPEC "NoSource: 0\n";
		}
	} else {
		print SPEC "\%package -n $p->{name}\n";
	}
	for my $tag (@simple_tags) {
		next if $p->{$tag} eq "";
		print SPEC "$tag: " . quote($p->{$tag}) . "\n";
	}
	print SPEC "BuildArch: noarch\n" if $p->{arch} eq "noarch";
	for my $dep (keys(%dep2tag)) {
		print_deps($dep, $p->{$dep});
	}
	print SPEC "\%description -n $p->{name}\n";
	print SPEC quote($p->{description}) . "\n\n";

	for my $script (keys(%script2tag)) {
		next unless $p->{$script};
		my $file = "$script-$p->{name}";
		open(my $fh, '>', "$output/$file") or die "$output/$file: $!\n";
		print SPEC "\%$script -p $p->{$script}{interp} -n $p->{name} -f $file\n";
		print $fh $p->{$script}{script};
		close($fh);

	}
	if ($p->{files}) {
		print SPEC "\%files -n $p->{name}\n";
		print_files($p->{files});
	}
	print SPEC "\n";
}

# /usr/include/rpm/rpmds.h
my %deptypes = (
	pre    => (1 <<  9),
	post   => (1 << 10),
	preun  => (1 << 11),
	postun => (1 << 12),
	verify => (1 << 13),
);
my %depflags = (
	"<"    => (1 << 1),
	">"    => (1 << 2),
	"="    => (1 << 3),
	rpmlib => (1 << 24),
	strong => (1 << 27),
);

sub print_deps {
	my ($depname, $list) = @_;

	foreach my $d (@$list) {
		next if ($d->{flags} & $depflags{rpmlib});

		if ($d->{flags} & $depflags{strong}) {
			print SPEC $dep2strong{$depname};
		} else {
			print SPEC $depname;
		}
		my @deptypes;
		while (my ($type, $bit) = each(%deptypes)) {
			push(@deptypes, $type) if $d->{flags} & $bit;
		}
		print SPEC "(", join(",", @deptypes), ")" if @deptypes;
		print SPEC ": ";

		print SPEC quote($d->{name});
		if ($d->{version}) {
			print SPEC " ";
			for my $op (qw(< > =)) {
				print SPEC $op if $d->{flags} & $depflags{$op};
			}
			print SPEC " " . quote($d->{version});
		}
		print SPEC "\n";
	}
}

# /usr/include/rpm/rpmfi.h
my %filetypes = (
	config    => (1 << 0),
	doc       => (1 << 1),
	missingok => (1 << 3),
	noreplace => (1 << 4),
	ghost     => (1 << 6),
);

sub print_files {
	my $files = shift;

	for my $f (@$files) {
		my $path = "$directory/$f->{name}";
		my $attrs = "";
		# Fix mtime of directories, which cpio -idm fails to preserve
		if (S_ISDIR($f->{mode})) {
			$attrs .= "\%dir ";
			utime($f->{mtime}, $f->{mtime}, $path);
		}
		$attrs .= sprintf('%%attr(%04o, %s, %s) ', ($f->{mode} & 0777),
			$f->{owner}, $f->{group});
		if ($f->{flags} & $filetypes{config}) {
			$attrs .= "%config ";
			my @cfg_attrs;
			for my $attr (qw(missingok noreplace)) {
				next unless $f->{flags} & $filetypes{$attr};
				push(@cfg_attrs, $attr);
			}
			$attrs .= "(" . join(",", @cfg_attrs) . ")" if @cfg_attrs;
		}
		$attrs .= "%doc " if $f->{flags} & $filetypes{doc};
		if ($f->{flags} & $filetypes{ghost}) {
			$attrs .= "%ghost ";
			if (S_ISREG($f->{mode})) {
				open(my $fh, '>', $path) or die "$path: $!\n";
				if ($f->{size} > 0) {
					sysseek($fh, $f->{size} - 1, SEEK_SET);
					syswrite($fh, ' ', 1);
				}
				close($fh);
				utime($f->{mtime}, $f->{mtime}, $path);
			} elsif (S_ISLNK($f->{mode})) {
				symlink($f->{target}, $path);
			}
		}
		# mtime of symlinks is also not preserved by cpio
		if (S_ISLNK($f->{mode})) {
			# perl core does not provide lutimes()/utimensat()
			system("touch", "-h", "-d\@$f->{mtime}", $path);
		}

		print SPEC "$attrs " . quote($f->{name}) . "\n";
		if (-e "$path.sig") {
			print SPEC "$attrs " . quote($f->{name}) . ".sig\n";
		}
	}
}

my %packages;
for my $rpm (@rpms) {
	my $p = load_package($rpm);
	$packages{$p->{name}} = $p;
}

my $sourcerpm;
for my $p (values(%packages)) {
	$sourcerpm = $p->{sourcerpm} unless $sourcerpm;
	if ($p->{sourcerpm} ne $sourcerpm) {
		die "Error: packages built from different source rpm: $sourcerpm vs $p->{sourcerpm}\n";
	}
}
if ($sourcerpm !~ /^(.+)-([^-]+)-([^-]+)\.(no)?src\.rpm$/) {
	die "Error: malformed %{sourcerpm} tag: $sourcerpm\n";
}
my ($main_name, $main_ver, $main_rel, $nosrc) = ($1, $2, $3, $4);
if (!exists($packages{$main_name})) {
	# create an empty main package
	my $first = (values(%packages))[0];
	$packages{$main_name} = {
		name => $main_name,
		version => $main_ver,
		release => $main_rel,
	};
	for my $tag (qw(description changelog arch), @simple_tags) {
		next if $packages{$main_name}->{$tag};
		$packages{$main_name}->{$tag} = $first->{$tag};
	}
}
$packages{$main_name}->{nosource} = $nosrc ? 1 : 0;

open(SPEC, '>', "$output/repackage.spec") or die "$output/repackage.spec: $!\n";
print_package($packages{$main_name}, 1);
for my $p (values(%packages)) {
	next if $p->{name} eq $main_name;
	print_package($p, 0);
}
print SPEC "\%changelog\n";
print SPEC quote($packages{$main_name}->{changelog});
close(SPEC);