#!/usr/bin/perl
#
#  dpkg-cross-convert - Manage libraries for cross compiling
#  Copyright (C) 1997-2000  Roman Hodek <roman@hodek.net>
#  Copyright (C) 2004  Raphael Bossek <bossekr@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, write to the Free Software
#  Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
#
#  $Id: dpkg-cross-convert,v 1.1 2004/06/16 20:35:30 yoush-guest Exp $

use POSIX;
use POSIX qw(:errno_h :signal_h);

require "dpkg-cross.pl";

#$debug = 1;
	
# packages to omit in dependencies
@omit_depends = qw( gcc binutils );

sub usageversion {
    print(STDERR <<END)
dpkg-cross-convert version $DPKGCROSSVERSION

Usage:
 dpkg-cross-convert <packages-files|.debs>...

Options:
 --test:  just test if old-style installation exists
 --purge: purge all remaining files of an old installation (if you need
          the libs, reinstall manually)
 -a|--arch ARCH: set architecture (necessary)

dpkg-cross-convert tries to convert old dpkg-cross 0.x style
installations to the new 1.x style. But an old installation doesn't
contain all necessary information for this, namely the control file
for the packages is missing. Therefore dpkg-cross-convert somehow has
to get those infos, and several possibilities exist:
 - From an installed package (in the native system) of the same version
 - From a Packages or Packages.gz file
 - From a .deb of appropriate version (architecture doesn't matter)
dpkg-cross-convert automatically looks at /var/lib/dpkg/available
(packages that dpkg thinks are available) and /var/lib/dpkg/status
(infos about installed (native) packages). Furthermore you can supply
Packages files (found in the FTP archives) or .deb files on the
command line. The file type is determined automatically.
Cross packages for which no sufficient infos are available can't be
converted and must be reinstalled later.

It may be a good idea to back up your cross compiling installation
before running dpkg-cross-convert, in case something goes wrong.
END
        || die "$progname: failed to write usage: $!\n";
}

while( @ARGV ) {
    $_= shift( @ARGV );
    last if m/^--$/;
    if (!/^-/) {
        unshift(@ARGV,$_);
		last;
    }
	elsif (/^(-h|--help|--version)$/) {
        usageversion();
		exit( 0 );
	}
	elsif (/^(-a|--arch$)/) {
		if (!($arch = $')) {
			@ARGV || die "$progname: --arch needs an argument\n";
			$arch = shift( @ARGV );
		}
	}
	elsif (/^--purge$/) {
		$purge_mode = 1;
	}
	elsif (/^--test$/) {
		$test_mode = 1;
	}
	else {
		die "$progname: Unknown option $_\n";
	}
}

if ($test_mode) {
	my @found = ();
	foreach $arch (qw( i386 m68k alpha powerpc sparc)) {
		foreach $var ( @intern_vars ) {
			eval "undef \$$var";
		}
		read_config();
		setup();
		push( @found, $arch ) if -d $crossinfo;
	}
	if (@found) {
		print "You seem to have an old (pre-1.0) installation of ".
   	          "cross-compiling\n";
		print "headers and libraries. (Architectures: @found)\n";
		print "Please use dpkg-cross-convert to convert your ".
		      "installation.\n";
	}
	exit 0;
}

# if not set on cmd line, take from environment
$arch ||= $ENV{'ARCH'};
die "$progname: architecture isn't set\n" if !$arch;

read_config();
setup();

# exit if no old style installation exists
if (!-d $crossinfo) {
	print "No old style (dpkg-cross 0.x) installation found.\n";
	print "Nothing to do.\n";
	exit 0;
}

read_installed();
if ($n_installed == 0) {
	print "$crossinfo exists but no old-style packages installed anymore\n";
	print "Removing $crossinfo\n";
	system( "rm -rf $crossinfo" );
	exit 0;
}

if ($purge_mode) {
	foreach $pkg ( keys %version ) {
		print "Removing files of $pkg\n";
		sub_remove( $pkg );
	}
	system( "rm -rf $crossinfo" );
	print "Purged remaining packages installed the old way:\n";
	print_pkg_list( sort keys %version );
	print "You can re-install those packages manually with dpkg-cross\n";
	print "if you still want to have them.\n";
	exit 0;
}

# now we know which old-style packages are installed. Try to get the
# control infos for those from somewhere.

read_pkgs( "/var/lib/dpkg/status" );
read_pkgs( "/var/lib/dpkg/available" );

foreach $file ( @ARGV ) {
	read_any_file( $file );
}

# convert packages for which it is possible
foreach $pkg ( keys %version ) {
	next if !exists( $control{$pkg} );
	if (!convert( $pkg )) {
		push( @not_done, $pkg );
	}
	else {
		push( @install, $pkg );
		my $stripped_version;
		# strip epoch (not stored in file name)
		($stripped_version = $version{$pkg}) =~ s/^\d+://;
		$filename{$pkg} = "/tmp/$pkg-$arch-cross_${stripped_version}_all.deb";
	}
}
if (@install) {
	# first remove the old files
	foreach $pkg ( @install ) {
		print "Removing old files of $pkg\n";
		sub_remove( $pkg );
	}
	# first unpack the converted packages with dpkg
	print "Unpacking converted packages:\n";
	open( PIPE, "dpkg --unpack " .
		        join( " ", map { $filename{$_}; } @install ) . " 2>&1 |" );
	my $errs = 0;
	while( <PIPE> ) {
		next if /^(\(Reading database|Preparing to replace)/i;
		if (/^Unpacking replacement ([^ _]+)-\Q$arch\E-cross/i) {
			print "  $1\n";
		}
		else {
			print;
		}
		$errs = 1 if /Errors were encountered while processing/i;
		if ($errs) {
			/^\s+(\/tmp\/)?([^ _]+)(_\S+\.deb)?$/;
			my $name = $2;
			$name =~ s/-\Q$arch\E-cross$//;
			push( @failed, $name ) if $name;
		}
	}
	close( PIPE );

	foreach $pkg (sort_depends()) {
		$pkg =~ s/-\Q$arch\E-cross$//;
		next if !member( $pkg, keys %version ) ||
				member( $pkg, @not_done ) || member( $pkg, @failed );
		print "Configuring $pkg\n";
		open( PIPE,  "dpkg --configure $pkg-$arch-cross |" );
		my $errs = 0;
		while( <PIPE> ) {
			print unless /^Setting up/i ||
						 /^dpkg: error processing/i ||
						 /leaving unconfigured$/i ||
						 ($errs && /^\s/);
			$errs = 1 if /Errors were encountered while processing/i;
		}
		close( PIPE );
		push( @failed, $pkg ) if $?;
	}

	# remove packages that were installed ok
	foreach $pkg ( @install ) {
		unlink $filename{$pkg} if !member( $file, @failed );
	}
}

# print which packages couldn't be converted, either because no infos
# were available or conversion or dpkg failed.
@no_control = grep( !exists($control{$_}), keys %version );

if (@no_control || @not_done || @failed) {
	print "The following packages couldn't be converted:\n";
	print_pkg_list( sort( @no_control, @not_done, @failed ));
}
if (@not_done) {
	print "These packages failed conversion:\n";
	print_pkg_list( sort @not_done );
}
if (@failed) {
	print "These packages failed installation by dpkg:\n";
	print_pkg_list( sort @failed );
	print "The files are still in /tmp, if you want to try again.\n";
}
if (@no_control) {
	print "You can aid conversion of:\n";
	print_pkg_list( sort @no_control );
	print "by supplying control infos for these packages, either from a\n";
	print "Packages file or the binary package (of same version).\n";
	print "If you can't find control infos for remaining packages, use\n";
	print "dpkg-cross-convert --purge to remove the rest of the old-style\n";
	print "installation, and reinstall missing packages in current version\n";
	print "with dpkg-cross\n";
}

# check if everything is converted
read_installed();
if ($n_installed == 0) {
	print "No old-style packages installed anymore!\n";
	print "Removing $crossinfo\n";
	system( "rm -rf $crossinfo" );
}

exit 0;


sub print_pkg_list {
	my @list = @_;
	my( $i, $name, $suffix, $pos );

	print "  "; $pos = 2;
	for( $i = 0; $i < @list; ++$i ) {
		$name = $list[$i];
		$suffix = ($i == $#list) ? "" : ", ";
		$len = length($name)+length($suffix);
		if ($pos + $len > 78) {
			print "\n  ";
			$pos = 2;
		}
		print "$name$suffix";
		$pos += $len;
	}
	print "\n  (", scalar(@list), " package", (@list == 1) ? "" : "s", ")\n";
}

sub read_any_file {
	my $file = shift;
	my $bytes;

	if (!open( F, "<$file" )) {
		print "Can't open $file: $!\n";
		return;
	}
	
	# read first 21 bytes of the file to determine file type
	if (read( F, $bytes, 21 ) < 21) {
		print "Can't read magic from $file\n";
		return;
	}

	if ($bytes eq "!<arch>\ndebian-binary") {
		# is a .deb, use dpkg for it
		close( F );
		read_deb( $file );
		return;
	}
	elsif (substr( $bytes, 0, 2 ) eq "\037\213") {
		# gzipped files, reopen over pipe
		close( F );
		print "$file is compressed\n" if $debug;
		$file = "gzip -dc $file |";
		open( F, $file );
	}
	else {
		$file = "<$file";
		seek( F, 0, SEEK_SET );
	}

	# if it's no .deb, it should be a Packages or similar file, which
	# always start with a "Package: ..." line. Check this.
	$line = <F>;
	close( F );
	if ($line !~ /^Package:\s*\S+\s*$/) {
		print "$file: unknown file type\n";
		return;
	}

	read_pkgs( $file );
}

sub read_pkgs {
	my $file = shift;
	my( $text, $p, $v );
	local($/) = "";

	if (!open( F, $file )) {
		print "Can't open $file: $!\n";
		return;
	}
	
	while( <F> ) {
		next if !/Package:\s*(\S+)\s*$/mi;
		next if !($p = $1);
		next if !/Version:\s*(\S+)\s*$/mi;
		next if !($v = $1);

		if (exists $version{$p} && $version{$p} eq $v) {
			$control{$p} = $_;
			print "Found infos for ${p}_$v from $file\n" if $debug;
		}
	}
	close( F );
}

sub read_deb {
	my $file = shift;
	my( $text, $p, $v );
	local($/) = "";

	open( F, "dpkg-deb --field $file 2>&1" );
	$text = <F>;
	close( F );

	return if $text =~ /not a debian format/mi;
	$text =~ /Package:\s*(\S+)\s*$/mi;
	return if !($p = $1);
	$text =~ /Version:\s*(\S+)\s*$/mi;
	return if !($v = $1);

	if (exists $version{$p} && $version{$p} eq $v) {
		$control{$p} = $text;
		print "Found infos for ${p}_$v from $file\n" if $debug;
	}
}

sub convert {
	my $pkg = shift;
	my( $tmpdir, $tar_errs, $dir, @kheaders );

	print STDERR "Converting: $pkg\n";
	
	if (!open( F, "<$crossinfo/$pkg.list" )) {
		print STDERR "Can't open $crossinfo/$pkg.list: $!\n";
		return 0;
	}
	chomp( @files = <F> );
	close( F );
	# omit dirs (tar would pack their contents, too)
	@files = grep( ! -d "$_", @files );
	# test if kernel headers dirs are symlinks; if yes, pack just the
	# links, not the contents of the dirs
	if (grep( /^\Q$crossinc\E\/(linux|asm|scsi)(\/|$)/, @files )) {
		foreach $dir ( "$crossinc/linux", "$crossinc/asm", "$crossinc/scsi" ) {
			next if ! -s $dir;
			@files = grep( ! /^\Q$dir\E(\/|$)/, @files );
			push( @files, $dir );
		}
	}
	# remove leading /, to avoid tar warning
	map( $_ =~ s,^/,, , @files );
	
	$tmpdir = "/tmp/.dpkg-cross-convert.$$";
	if (-e $tmpdir) {
		system( "rm -rf $tmpdir" );
		die "$tmpdir already exists and can't delete it\n" if -e $tmpdir;
	}
	makedirs( "$tmpdir/DEBIAN" );

	# move files belonging to that package
	open( PIPE, "(tar cf - -C / @files | ".
		 "tar xf - -C $tmpdir) 2>&1 |" );
	while( <PIPE> ) {
		$tar_errs .= "$1\n" if /^tar:\s*(.*)/;
	}
	close( PIPE );
	if ($tar_errs) {
		warn "moving libraries to $tmpdir failed:\n$tar_errs\n";
		goto fail;
	}
	
	# copy shlibs file, if there is one
	system( "cp $crossinfo/$pkg.shlibs $tmpdir/DEBIAN/shlibs" )
		if -f "$crossinfo/$pkg.shlibs";

	# create control infos
	if (!open( OUT, ">$tmpdir/DEBIAN/control" )) {
		warn "Cannot create $tmpdir/DEBIAN/control: $!\n";
		goto fail;
	}
	foreach ( split( "\n", $control{$pkg} )) {
		if (/Package:\s+(.*)$/i) {
			# append $arch-cross to package name
			$_ = "Package: $1-$arch-cross\nArchitecture: all";
			$depends{"$1-$arch-cross"} = [];
		}
		elsif (/(Pre-Depends|Depends|Conflicts|Provides|Replaces):\s*(.*)$/i) {
			# rewrite package names in dependencies & co.
			my $field = $1;
			my $newdeps = rewrite_dependencies( $2 );
			# turn Pre-Depends into Depends; nothing critical can
			# happen with cross-compiling stuff
			$field =~ s/^Pre-//i;
			$_ = "$field: $newdeps";
			if ($field =~ /depends/i) {
				add_dependencies( "$pkg-$arch-cross", $newdeps );
			}
		}
		elsif (/Section:/i) {
			# change section to devel
			$_ = "Section: devel";
		}
		elsif (/Priority:/i) {
			# change priority to extra
			$_ = "Priority: extra";
		}
		elsif (/(Status|Installed-Size|Suggests|Recommends|Filename|
				 Size|MD5sum|Architecture|Essential):/ix) {
			# ignore these.
			$_ = "";
		}
		elsif (/Description:\s+(.*)$/i) {
			$_ = "Description: $1 (for cross compiling)\n";
			$_ .= " This package was generated by dpkg-cross for ".
				  "cross compiling.\n .";
		}
		print OUT "$_\n" if $_;
	}
	close( OUT );

	if (system( "dpkg-deb -b $tmpdir /tmp >/dev/null" )) {
		print STDERR "Building package with dpkg-deb -b failed.\n";
		goto fail;
	}

	system( "rm -rf $tmpdir" );
	return 1;
	
  fail:
	system( "rm -rf $tmpdir" );
	return 0;
}

sub rewrite_dependencies {
	my $str = shift;

	@list = map( rewrite_alternatives($_), split( /\s*,\s*/, $str));
	# remove empty elements
	@list = map { $_ ? ( $_ ) : () } @list;
	return join(", ", @list );
}

sub rewrite_alternatives {
	my $str = shift;

	@list = map( rewrite_item($_), split( /\s*\|\s*/, $str ));
	# remove empty elements
	@list = map { $_ ? ( $_ ) : () } @list;
	return join( " | ", @list );
}

sub rewrite_item {
	my $str = shift;

	$str =~ /^([^ (]+)/;
	return () if member( $1, @omit_depends );
	$str =~ s/^([^ (]+)/$1-$arch-cross/;
	return $str;
}

sub add_dependencies {
	my $depending_pkg = shift;
	my $depstr = shift;
	
	foreach (split( /\s*,\s*/, $depstr )) {
		foreach (split( /\s*\|\s*/, $_ )) {
			s/\s*\(.*$//; # drop version info
			push( @{$depends{$depending_pkg}}, $_ );
		}
	}
}

sub sort_depends {
	my( $node, $target, %indegree, @todo, @ordered_list );
	
	# first, calculate indegrees
	foreach $node ( keys %depends ) {
		foreach $target ( @{$depends{$node}} ) {
			$indegree{$target}++;
		}
	}

	# init todo list with nodes that have indegree 0
	foreach $node ( keys %depends ) {
		push( @todo, $node ) if $indegree{$node} == 0;
	}

	# now process targets of each node in todo list
	while( $node = shift(@todo) ) {
		unshift( @ordered_list, $node );
		# for each target, reduce indegree and append to todo queue if it
		# becomes 0
		foreach $target ( @{$depends{$node}} ) {
			push( @todo, $target ) if --($indegree{$target}) == 0;
		}
	}

	# if some indegree is still > 0, we have some sort of cycle
	# just append those pkgs to the end and don't care further about them
	foreach $node ( keys %depends ) {
		push( @ordered_list, $node ) if $indegree{$node} > 0;
	}

#	print "Dependencies:\n";
#	foreach $node ( keys %depends ) {
#		print "$node: @{$depends{$node}}\n";
#	}
#	print "Ordered:\n  ", join( "\n  ", @ordered_list ), "\n";
	return @ordered_list;
}

sub sub_remove {
	my $package = shift(@_);
	my @files;
	my( $file, $ok );
	my( %kernelh_symlink );
	
	if (!open( F, "<$crossinfo/$package.list" )) {
		warn "$progname: Cannot open $crossinfo/$package.list: $!\n".
			 "Cannot remove $package\n";
		return 0;
	}
	while( <F> ) {
		chomp( $_ );
		unshift( @files, $_ ) if $_;
		if ($_ =~ m,^\Q$crossinc\E/(linux|asm|scsi)$,) {
			$kernelh_symlink{$1} = -l $_;
		}
	}
	close( F );
	push( @files, "$crossinfo/$package.list" );
	
	foreach $file ( @files ) {
		next if $file =~ m,^\Q$crossinc\E/(linux|asm|scsi)(/|$), &&
			    $kernelh_symlink{$1};
		$isdir = -d $file && ! -l $file;
		$ok = $isdir ? rmdir $file : unlink $file;
		if (!$ok) {
			if ($! == ENOENT)  {
				warn "$progname: Warning: cannot remove $file: $!\n";
			}
			elsif (!($isdir && $! == ENOTEMPTY)) {
				warn "$progname: Cannot remove $file: $!\n";
				return 0;
			}
		}
	}
	if (-f "$crossinfo/$package.shlibs") {
		unlink "$crossinfo/$package.shlibs" ||
			warn "$progname: Warning: cannot remove $crossinfo/$package.shlibs: $!\n";
	}

	undef $version{$package};
	write_installed();
	return 1;
}

sub read_installed {

	$n_installed = 0;
	open( F, "<$crossinfo/installed" ) || return;
	while( <F> ) {
		if (/^(\S+)\s+(\S+)/) {
			$version{$1} = $2;
			++$n_installed;
		}
	}
	close( F );
}


sub write_installed {
	my $package;
	
	open( F, ">$crossinfo/installed" ) ||
		die "$progname: Cannot open $crossinfo/installed: $!\n";
	foreach $package ( sort keys %version ) {
		print F "$package $version{$package}\n" if $version{$package};
	}
	close( F );
}

sub makedirs {
	my $dir = shift(@_);
	my @dir;
	my( $d, $path );

	return if -d $dir;

	@dirs = split( "/", $dir );
	if ($dirs[0] eq "") { 
		shift( @dirs ); 
		$path = "/";
	}

	foreach $d ( @dirs ){
		$path .= $d;
		if (!-d $path){
			mkdir( $path, 0755 )
				|| die "$progname: Cannot make directory $path\n";
		}
		$path .= "/";
	}
}

sub member() {
	my $elt = shift;
	my @list = @_;

	return scalar(grep( $_ eq $elt, @list )) != 0;
}

