#!/usr/bin/perl -w
#
# This program puts humpty-dumpty back together again.
#
# dpkg-repack is Copyright (c) 1996-2006 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 $packagename $pattern $rootdir $list $generate $build $nodel $remove $purge $skip $force $help $all);

sub Syntax {
	print STDERR <<eof;
Usage: dpkg-newrepack [options] pattern
	--dir=dir	Take package from filesystem rooted on <dir>.
	--list		Display packakes list.
	--generate	Generate build directory.
	--build		Generate build directory and build deb package.
	    --nodel	Not delete build directory after build.
	--remove	Remove package.
	--purge		Purge package.
	    --sikp	Skip *.prerm and *.postrm execution, delete all conroll script.
	    --force	Use --force-all option, see dpkg --force-help .
	--help		This.
	--all		All available package, ignore pattern.
	pattern		The grep pattern of the full package name.
eof
#	--arch=arch	Force the parch to be built for architecture <arch>.
}

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

sub Warn {
        print STDERR "dpkg-newrepack: @_\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 || 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 @control=`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=`date -R`;
		chomp $date;
		$control[$x-1]=$control[$x-1]." .\n"." (Repackaged on $date by dpkg-newrepack.)";
	}
	
#	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;

	return join("\n", @control)."\n";
}
		
# Install the control file. Pass it the text of the file.
sub Install_Control {
	my @control=split("\n", shift);
	
	open (CONTROL,">$build_dir/DEBIAN/control")
		|| Die "Can't write to $build_dir/DEBIAN/control";
	
	my $control;
	my $skip=0;
	foreach (@control) {
		# Remove the Conffiles stanza
		if (/^(\S+):/) {
			$skip = lc $1 eq "conffiles";
		}
		print CONTROL "$_\n" unless $skip;
	}

	close CONTROL;
	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 @conffiles=@_;
	
	my @control_files;
#	open (Q, "dpkg-query --admindir=$rootdir/var/lib/dpkg --control-path $packagename 2>/dev/null |") || die "dpkg-query failed: $!";
	open (Q, "ls -1 $rootdir/var/lib/dpkg/info/$packagename.* 2>/dev/null |") || die "ls failed: $!";
	while (my $fn=<Q>) {
		chomp $fn;
		push @control_files, $fn;
	}
	close Q;

	foreach my $fn (@control_files) {
		my ($basename)=$fn=~m/^.*\.(.*?)$/;
		if ($basename ne 'list' && $basename ne 'conffiles') {
			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 control conffiles
	# that are still present on the filesystem.
	if (@conffiles) {
		open (OUT, ">$build_dir/DEBIAN/conffiles") || Die "write conffiles: $!";
		foreach (@conffiles) {
			print OUT "$_\n";
		}
		close OUT;
		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 $control=shift;

	# 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 (split /\n/,$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/,`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 !-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 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.
use Getopt::Long;
$rootdir='';
my $ret=&GetOptions(
	"dir|d=s",	\$rootdir,
	"list|l",	\$list,
	"generate|g",	\$generate,
	"build|b",	\$build,
	"nodel|n",	\$nodel,
	"remove|r",	\$remove,
	"purge|p",	\$purge,
	"skip|s",	\$skip,
	"force|f",	\$force,
	"help|h",	\$help,
	"all|a",	\$all,
);
#	"arch|a=s", \$arch,

if (!$ret || $help || (!@ARGV && !$all)) {
#if (!@ARGV || $help) {
	Syntax();
	exit 1;
}	

# Some sanity checks.
if ($> ne 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.";
}

$pattern="";
if (@ARGV && !$all) {
    $pattern="| grep $ARGV[0]";
}
#my @deblist=`dpkg-query --admindir=$rootdir/var/lib/dpkg -W -f '\${status} \${package} \${version} \${architecture}\n' | grep 'install ok '$pattern`;
my @deblist=`dpkg-query --admindir=$rootdir/var/lib/dpkg -W -f '\${status}_\${package}_\${version}_\${architecture}\n' $pattern`;
chomp foreach (@deblist);

if ($list) {
	foreach my $packagenames (@deblist) {
		my @package=split(/[_]+/,$packagenames);
		print $package[0]." :: ".$package[1]."_".$package[2]."_".$package[3]."\n";
	}
}
if ($generate || $build || $remove || $purge) {
	foreach my $packagenames (@deblist) {
		my @package=split(/[_]+/,$packagenames);
		$build_dir="./".$package[1]."_".$package[2]."_".$package[3];
		$packagename=$package[1];

		if ($generate || $build ) {
			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();
			my @conffiles=Install_Files($control);
			Install_DEBIAN(@conffiles);
			Install_Control($control);
		}

		if ($build) { SafeSystem("dpkg","--build",$build_dir,".","") }

		if (!$nodel && $build) { CleanUp() }

		if ($remove) {SafeSystem("dpkg","--root=$rootdir","--remove","$packagename","")}
		if ($purge) {
			if ($skip) {
				my @res1=`rm -rf $rootdir/var/lib/dpkg/info/$packagename.pre*`;
				my @res2=`rm -rf $rootdir/var/lib/dpkg/info/$packagename.post*`;
			}
			if ($force) {
			    SafeSystem("dpkg","--root=$rootdir","--purge","--force-all","$packagename","");
			} else {
			    SafeSystem("dpkg","--root=$rootdir","--purge","$packagename","");
			}
		}

		# Finish up.
		if ($error_flag) {
			Error("Problems were encountered in processing.");
			Error("The package may be broken.");
			$error_flag=0;
		}
	}
} elsif (!$list) {
	Syntax();
	exit 1;
}