#!/usr/bin/perl
#
# dpkg-repack puts humpty-dumpty back together again.
#
# Copyright © 1996-2006 Joey Hess <joeyh@debian.org>
# Copyright © 2012,2014-2015 Guillem Jover <guillem@debian.org>
#
# 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, see <https://www.gnu.org/licenses/>.

use strict;
use warnings;

use File::stat;
use Getopt::Long;

my $VERSION = '1.41';

my $error_flag;
my $dirty_flag;
my $build_dir;
my $rootdir;
my $arch;
my @deb_options;
my $generate;

sub Syntax {
	print { *STDERR } <<USAGE;
Usage: dpkg-repack [option...] packagename...

Options:
      --root=<dir>      Take package from filesystem rooted on <dir>.
      --arch=<arch>     Force the parch to be built for architecture <arch>.
      --generate        Generate build directory but do not build deb.
  -d, --deb-option=<option>
                        Pass build <option> to dpkg-deb.
  -?, --help            Show this usage information.
      --version         Show the version.

<packagename> is the name of the package(s) to attempt to repack.
USAGE
}

sub Version {
	print 'dpkg-repack ' . $VERSION . "\n";
}

sub Info {
	print "dpkg-repack: @_\n";
}

sub Warn {
	print { *STDERR } "dpkg-repack: @_\n";
}

sub Error {
	Warn @_;
	$error_flag = 1;
}

sub Die {
	Error('Fatal Error:', @_);
	CleanUp();
	exit 1;
}

# Run a system command, and print an error message if it fails.
sub SafeSystem {
	my $errormessage = pop @_;

	my $ret = system @_;
	if (int($ret / 256) > 0) {
		$errormessage = 'Error running: ' . join ' ', @_
			if !$errormessage;
		Error($errormessage);
	}
}

# Make the passed directory, print an error message if it fails.
sub SafeMkdir {
	my ($dir, $perms) = @_;

	mkdir $dir, $perms or Error("Unable to make directory, \"$dir\": $!");
	# mkdir doesn't do sticky bits and suidness.
	chmod $perms, $dir or Error("Unable to change permissions on \"$dir\": $!");
}

# This removes the temporary directory where we built the package.
sub CleanUp {
	if ($dirty_flag) {
		SafeSystem('rm', '-rf', $build_dir,
		           "Unable to remove $build_dir ($!). Please remove it by hand.");
	}
	$dirty_flag = 0;
}

# This makes the directories we will rebuild the package in.
sub Make_Dirs {
	$dirty_flag = 1;

	SafeMkdir $build_dir, 0755;
	SafeMkdir "$build_dir/DEBIAN", 0755;
}

# Get package control file via dpkg -s.
sub Extract_Control {
	my $packagename = shift;

	my @control = qx{dpkg --root=$rootdir/ -s $packagename};
	chomp foreach @control;

	# Add something to the Description to mention dpkg-repack.
	my $indesc = 0;
	my $x;
	for ($x = 0; $x < @control; $x++) {
		if ($control[$x] =~ /^(\S+):/) {
			last if $indesc; # end of description
			$indesc = 1 if lc $1 eq 'description';
		}
	}
	if ($indesc) {
		my $date = qx'date -R';
		chomp $date;
		chomp $control[$x - 1];
		$control[$x - 1] .= "\n";
		$control[$x - 1] .= " .\n";
		$control[$x - 1] .= " (Repackaged on $date by dpkg-repack.)";
	}
	
	if ($arch) {
		@control = grep { !/^Architecture:/ } @control;
		push @control, "Architecture: $arch\n";
	}

	if (! grep { /^Status:\s+.*\s+installed/ } @control) {
		Die "Package $packagename not fully installed";
	}
	@control = grep { !/^Status:\s+/ } @control;
	push @control, "\n";

	return @control;
}

# Install the control file. Pass it the text of the file.
sub Install_Control {
	my ($packagename, @control) = @_;

	open my $control_fh, '>', "$build_dir/DEBIAN/control"
		or Die "Can't write to $build_dir/DEBIAN/control";

	my $skip = 0;
	foreach (@control) {
		# Remove the Conffiles stanza
		if (/^(\S+):/) {
			$skip = lc $1 eq 'conffiles';
		}
		print { $control_fh } "$_\n" unless $skip;
	}

	close $control_fh;
	SafeSystem 'chown', '0:0', "$build_dir/DEBIAN/control", '';
}

# Install all the files in the DEBIAN directory. (Except control file and
# file list file.)
sub Install_DEBIAN {
	my ($packagename, @conffiles) = @_;

	my @control_files;
	open my $q_fh, '-|', "dpkg-query --admindir=$rootdir/var/lib/dpkg --control-path $packagename 2>/dev/null"
		or Die "dpkg-query failed: $!";
	while (my $fn = <$q_fh>) {
		chomp $fn;
		push @control_files, $fn;
	}
	close $q_fh;

	foreach my $fn (@control_files) {
		my ($basename) = $fn =~ m/^.*\.(.*?)$/;
		SafeSystem 'cp', '-p', $fn, "$build_dir/DEBIAN/$basename", '';
	}

	# Conffiles have to be handled specially, because
	# dpkg-query --control-path does not list the conffiles file.
	# Also, we need to generate one that only contains conffiles
	# that are still present on the filesystem.
	if (@conffiles) {
		open my $out_fh, '>', "$build_dir/DEBIAN/conffiles"
			or Die "write conffiles: $!";
		foreach (@conffiles) {
			print { $out_fh } "$_\n";
		}
		close $out_fh;
		SafeSystem 'chown', '0:0', "$build_dir/DEBIAN/conffiles", '';
	}
}

# This looks at the list of files in this package, and places them
# all on the directory tree.
sub Install_Files {
	my ($packagename, @control) = @_;

	# There are two types of conffiles. Obsolete conffiles should be
	# skipped, while other conffiles should be included if present.
	my @conffiles = ();
	my @obsolete_conffiles;
	my $in_conffiles = 0;
	foreach my $line (@control) {
		if ($line =~ /^Conffiles:/) {
			$in_conffiles = 1;
		}
		elsif ($in_conffiles && $line =~ /^ (.*)\s+([^\s]+)\s+obsolete$/) {
			push @obsolete_conffiles, $1;
		}
		elsif ($in_conffiles && $line =~ /^ (.*)\s+([^\s]+)$/) {
			push @conffiles, $1;
		}
		else {
			$in_conffiles = 0;
		}
	}

	# I need a list of all the files, for later lookups
	# when I test to see where symlinks point to.
	# Note that because I parse the output of the command (for
	# diversions, below) it's important to make sure it runs with English
	# language output.
	my $lc_all = $ENV{LC_ALL};
	$ENV{LC_ALL} = 'C';
	my @filelist = split /\n/, qx{dpkg --root=$rootdir/ -L $packagename};
	$ENV{LC_ALL} = $lc_all if defined $lc_all; # important to reset it.

	# Set up a hash for easy lookups.
	my %filelist = map { $_ => 1 } @filelist;

	my $fn;
	for (my $x = 0; $x <= $#filelist; $x++) {
		my $origfn = $filelist[$x];

		# dpkg -L spits out extra lines to report diversions.
		# we have to parse those (ugly..), to find out where the
		# file was diverted to, and use the diverted file.
		if (defined $filelist[$x + 1] &&
		    ($filelist[$x + 1] =~ m/locally diverted to: (.*)/ ||
		     $filelist[$x + 1] =~ m/diverted by .*? to: (.*)/)) {
			$fn = "$rootdir/$1";
			$x++; # skip over that line.
		}
		elsif ($origfn =~ m/package diverts others to: (.*)/) {
			# not a file at all, skip over it
			next;
		}
		else {
			$fn = $rootdir . $origfn;
		}

		if (grep { $_ eq $fn } @obsolete_conffiles) {
			Warn "Skipping obsolete conffile $fn\n";
			next;
		}

		if (!-e $fn && !-l $fn) {
			Error "File not found: $fn" unless grep { $_ eq $fn } @conffiles;
		}
		elsif ((-d $fn and not -l $fn) or
		       (-d $fn and -l $fn and not $filelist{readlink($fn)}
		        and ($x + 1 <= $#filelist and $filelist[$x + 1] =~ m/^\Q$origfn\E\//))) {
			# See the changelog for version 0.17 for an
			# explanation of what I'm doing above with
			# directory symlinks. I rely on the order of the
			# filelist listing parent directories first, and 
			# then their contents.
			# There has to be a better way to do this!
			my $f = '';
			foreach my $dir (split(m/\/+/, $origfn)) {
				$f .= "/$dir";
				next if -d $build_dir . $f;
				my $st = stat($rootdir . $f);
				SafeMkdir "$build_dir/$f", $st->mode;
				chown($st->uid, $st->gid, "$build_dir/$f");
			}
		}
		elsif (-p $fn) {
			# Copy a named pipe with cp -a.
			SafeSystem 'cp', '-a', $fn, "$build_dir/$origfn", '';
		}
		else {
			SafeSystem 'cp', '-pd', $fn, "$build_dir/$origfn", '';
		}
	}

	return @conffiles;
}

# Parse parameters.
$rootdir = '';
my $ret = GetOptions(
	'root|r=s', \$rootdir,
	'arch|a=s', \$arch,
	'deb-option|d=s@', \@deb_options,
	'generate|g' , \$generate,
	'help|?', sub { Syntax(); exit 0; },
	'version', sub { Version(); exit 0; },
);

if (not @ARGV or not $ret) {
	Syntax();
	exit 1;
}
$build_dir = "./dpkg-repack-$$";

# Some sanity checks.
if ($> != 0) {
	Die 'This program should be run as root (or you could use fakeroot -u). Aborting.';
}
if (exists $ENV{FAKED_MODE} && $ENV{FAKED_MODE} ne 'unknown-is-real') {
	Warn 'fakeroot run without its -u flag may corrupt some file permissions.';
}

foreach my $packagename (@ARGV) {
	my @control = Extract_Control($packagename);
	if (!@control) {
		Die "Unable to locate $packagename in the package list.";
	}

	# If the umask is set wrong, the directories will end up with the wrong
	# perms. (Is this still needed?)
	umask 022;

	# Generate the directory tree.
	Make_Dirs();
	my @conffiles = Install_Files($packagename, @control);
	Install_DEBIAN($packagename, @conffiles);
	Install_Control($packagename, @control);

	# Stop here?
	if ($generate) {
		Info "dpkg-repack: created $build_dir for $packagename";
		next;
	}
	
	# Let dpkg-deb do its magic.
	SafeSystem('dpkg-deb', @deb_options, '--build', $build_dir, '.', '');

	# Finish up.
	CleanUp();
	if ($error_flag) {
		Error('Problems were encountered in processing.');
		Error('The package may be broken.');
		$error_flag = 0;
	}
}
