#!/usr/bin/perl
#
# This program puts humpty-dumpty back together again.
#
# dpkg-repack is Copyright (c) 1996-8  Joey Hess <joeyh@master.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.

sub Syntax {
	print <<eof;
Usage: dpkg-repack [--root=dir] 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;
}

# Print out a status line.
sub Status { my $message=shift;
	print "-- $message\n";
}

# Run a system command, and print an error message if it fails.
# The errormessage parameter is optional.
sub SafeSystem { my ($command,$errormessage)=@_;
	my $ret=system $command;
	if (int($ret/256) > 0) {
		$errormessage="Error running: $command" 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\": $!");
}

# 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;
}

# Pull the control files info out out the status file (like dpkg -s)
# and return it.
sub Extract_Control {
	open (STAT,"<$dpkg_lib/status") || Die "Can't open $dpkg_lib/status";
	my $prev="\n";
	my $info=undef;
	while (<STAT>) {
		if (($prev eq "\n") && (m/^Package: (.*)\n/ ne undef)) {
			if ($1 eq $packagename) {
				$info=$_;
				while (<STAT>) {
					last if $_ eq "\n";
					$info.=$_ if (/^Status:/ eq undef);
				}
				last;
			}
		}
		$prev=$_;
	}
	close STAT;

	# Add an Architecture: field
	if (!$arch) {
		$arch=`dpkg --print-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 $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 {
	open (LIST,"<$dpkg_lib/info/$packagename.list")
		|| Die "$packagename does not seem to be installed (no list file found).";
	while (<LIST>) {
		chomp;
		$fn="$rootdir/$_";
		if (!-e $fn && !-l $fn) {
			Error "File not found: $_"
		}
		elsif (-d $fn and !-l $fn) {
			# There has to be a better way to do this!
			my ($dev,$ino,$mode,$nlink,$uid,$gid,$rdev,$size,$atime,
				$mtime,$ctime,$blksize,$blocks) = stat($fn);
			SafeMkdir "$build_dir/$_",$mode;
			chown $uid,$gid,"$build_dir/$_";
			
			if (-u _) { # setuid
				SafeSystem "chmod u+s $build_dir/$_";
			}
			if (-g _) { # setgid
				SafeSystem "chmod g+s $build_dir/$_";
			}
			if (-k _) { # sticky
				SafeSystem "chmod +t $build_dir/$_";
			}
			chmod "$build_dir/$_",$mode;
			($dev,$ino,$mode_new,$nlink,$uid,$gid,$rdev,$size,
				$atime,$mtime,$ctime,$blksize,$blocks) 
				= stat("$build_dir/$_");
			if ($mode ne $mode_new) {
				Error "Bad perms on directory: $_";
			}
		}
		else {
			SafeSystem "cp -pd $fn $build_dir/$_";
		}
	}
	close LIST;
}

# Parse parameters.
use Getopt::Long;
$ret=&GetOptions(
	"root|r=s", \$rootdir,
	"arch|a=s", \$arch,
);
$packagename=shift;
if (!$packagename || !$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. Aborting." }
$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.
umask 022;

# Generate the directory tree.
Status("Creating control files");
Make_Dirs();
Install_DEBIAN();
Install_Control($control);
Status("Copying files");
Install_Files();

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

# Finish up.
Status("Cleaning up");
CleanUp();
if ($error_flag) {
        Error "Errors were encountered in processing.";
        Error "The package may not unpack correctly.";
}
else {
	Status("Package build successful");
}
