#!/usr/bin/perl -w
#
# This program puts humpty-dumpty back together again.
#
# dpkg-repack is Copyright (c) 1996-1999 by Joey Hess <joeyh@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.
#
#   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., 675 Mass Ave., Cambridge, MA 02139, USA.

use strict;
use File::stat;
use vars qw($error_flag $dirty_flag $build_dir $arch $rootdir $packagename
	    $dpkg_lib);

sub Syntax {
	print STDERR <<eof;
Usage: dpkg-repack [--root=dir] packagename [packagename ..]
	--root=dir	Take package from filesystem rooted on <dir>.
	--arch=arch	Force the parch to be built for architecture <arch>.
	packagename	The name of the package to attempt to repack.
eof
}

sub Error {
        print STDERR "dpkg-repack: @_\n";
	$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 || Error("Unable to make directory, \"$dir\": $!");
	# mkdir doesn't do sticky bits and suidness.
	chmod $perms, $dir || 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.");
	}
}

# 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 $info=`dpkg --root=$rootdir/ -s $packagename |grep -v "^Status:"`;
	chomp $info;

	# Add an Architecture: field
	if (!$arch) {
		$arch=`dpkg --print-installation-architecture`;
		chomp $arch;
	}
	$info.="Architecture: $arch\n";

	return $info;
}

# Install the control file. Pass it the text of the file.
sub Install_Control {
	my $control=shift;
	
	open (CONTROL,">$build_dir/DEBIAN/control")
		|| Die "Can't write to $build_dir/DEBIAN/control";
	print CONTROL $control;
	close CONTROL;
}

# Install all the files in the DEBIAN directory. (Except control file and
# file list file.)
sub Install_DEBIAN {
	foreach my $fn (glob("$dpkg_lib/info/$packagename.*")) {
		my ($basename)=$fn=~m/^.*\.(.*?)$/;
		if ($basename ne 'list') {
			SafeSystem "cp","-p",$fn,"$build_dir/DEBIAN/$basename","";
		}
	}
}

# This looks at the list of files in this package, and places them
# all on the directory tree.
sub Install_Files {
	# 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/,`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.
		}
		else {
			$fn="$rootdir/$origfn";
		}

		if (!-e $fn && !-l $fn) {
			Error "File not found: $fn"
		}
		elsif ((-d $fn and !-l $fn) or
		       (-d $fn and -l $fn and !$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 here 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 $st=stat($fn);
			SafeMkdir "$build_dir/$origfn",$st->mode;
		}
		else {
			SafeSystem "cp","-pd",$fn,"$build_dir/$origfn","";
		}
	}
}

# Parse parameters.
use Getopt::Long;
$rootdir='';
my $ret=&GetOptions(
	"root|r=s", \$rootdir,
	"arch|a=s", \$arch,
);

if (!@ARGV || !$ret) {
	Syntax();
	exit 1;
}	
$dpkg_lib=$rootdir.'/var/lib/dpkg';
$build_dir="./dpkg-repack-$$";

# Some sanity checks.
if ($> ne 0) { Die "This program should be run as root (or you could use fakeroot, but that will not always work). Aborting." }

foreach $packagename (@ARGV) {
	if (! -f "$dpkg_lib/info/$packagename.list") {
		Error("Package $packagename not found");
		next;
	}
	
	my $control=Extract_Control();
	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();
	Install_DEBIAN();
	Install_Control($control);
	Install_Files();

	# Let dpkg do its magic.
	SafeSystem("dpkg","--build",$build_dir,".","");

	# Finish up.
	CleanUp();
	if ($error_flag) {
	        Error("Errors were encountered in processing.");
	        Error("The package may not unpack correctly.");
		$error_flag=0;
	}
}
