#!/usr/bin/perl
#
# dpkg-cross -- manage libraries for cross compiling
#
# Roman Hodek <Roman.Hodek@informatik.uni-erlangen.de>, 4 Feb 97
# This is free software; see the GNU General Public Licence
# version 2 or later for copying conditions.  There is NO warranty.

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

#
# general code to set up dpkg-cross configuration
#
$conffile = "/etc/dpkg/cross-compile";
($progname = $0) =~ s,.*/,,;
@intern_vars = qw( crossbase crossprefix crossdir crossbin crosslib crossinc
				   crossinfo maintainer );
# avoid warnings about unused variables:
$crossbase = $crossprefix = $crossdir = $crossbin = $crosslib =
$crossinc = $crossinfo = "";
$maintainer = "";

# packages to omit in dependencies
@omit_depends = qw( gcc binutils gpm );

$dpkg_statfile = "/var/lib/dpkg/status";

sub usageversion {
    print(STDERR <<END)
dpkg-cross version 1.0

Usage:
 dpkg-cross [--install|-i] <files...>
 dpkg-cross [--build|-b] <files...>
 dpkg-cross [--remove|--purge|-r] <packages...>
 dpkg-cross [--status|-s] <packages...>
 dpkg-cross [--list|-l] <packages...>
 dpkg-cross [--list-files|-L] <packages...>
 dpkg-cross [--query|-Q] <pkgpath>
 dpkg-cross [--update|-u] <pkgpath>

Options:
 -a|--arch ARCH: set architecture (necessary)
 -v|--version: be verbose
 -q|--quiet: be quiet

dpkg-cross installs or removes libraries and include files for
cross-compiling Debian packages. It reads $conffile to
determine the base directory of the cross compiler installation, and
works in the subdirectories lib and include there.
END
        || die "$progname: failed to write usage: $!\n";
}

$mode = "";
$verbose = 1;
while( @ARGV ) {
    $_= shift( @ARGV );
    last if m/^--$/;
    if (!/^-/) {
        unshift(@ARGV,$_);
		last;
    }
	elsif (/^(-h|--help|--version)$/) {
        usageversion();
		exit( 0 );
	}
	elsif (/^(-v|--verbose)$/) {
		$verbose = 2;
	}
	elsif (/^(-q|--quiet)$/) {
		$verbose = 0;
	}
	elsif (/^(-i|--install)$/) {
		die "$progname: Only one action can be specified!\n" if $mode;
		$mode = "install";
	}
	elsif (/^(-r|--remove|--purge)$/) {
		die "$progname: Only one action can be specified!\n" if $mode;
		$mode = "remove";
	}
	elsif (/^(-s|--status)$/) {
		die "$progname: Only one action can be specified!\n" if $mode;
		$mode = "status";
	}
	elsif (/^(-l|--list)$/) {
		die "$progname: Only one action can be specified!\n" if $mode;
		$mode = "list";
	}
	elsif (/^(-L|--listfiles)$/) {
		die "$progname: Only one action can be specified!\n" if $mode;
		$mode = "listfiles";
	}
	elsif (/^(-b|--build)$/) {
		die "$progname: Only one action can be specified!\n" if $mode;
		$mode = "build";
	}
	elsif (/^(-Q|--query)$/) {
		die "$progname: Only one action can be specified!\n" if $mode;
		$mode = "query";
	}
	elsif (/^(-u|--update)$/) {
		die "$progname: Only one action can be specified!\n" if $mode;
		$mode = "update";
	}
	elsif (/^(-a|--arch$)/) {
		if (!($arch = $')) {
			@ARGV || die "$progname: --arch needs an argument\n";
			$arch = shift( @ARGV );
		}
	}
	else {
		die "$progname: Unknown option $_\n";
	}
}
die "$progname: too few arguments\n" if !$mode || (!@ARGV && $mode ne "list");
	
# if not set on cmd line, take from environment
$arch ||= $ENV{'ARCH'};
die "$progname: architecture isn't set\n" if !$arch;

read_config();
setup();
# check for old installation
#if (-d $crossinfo) {
#	 print STDERR "This is an old-style (dpkg-cross 0.x) installation.\n";
#	 print STDERR "Please convert with dpkg-cross-convert first!\n";
#	 exit 1;
#}

$retval = 0;

if ($mode eq "query" || $mode eq "update") {
	my %update_list = get_update_list( @ARGV );
	if (!%update_list) {
		print "No updates available.\n";
		exit 0;
	}
	if ($mode eq "query") {
		print "Available updates:\n";
		foreach (sort keys %update_list) {
			print "$_ (from $update_list{$_}->{'Oldver'} to ",
				  "$update_list{$_}->{'Newver'})\n";
		}
	}
	else {
		$mode = "install";
		@ARGV = ();
		foreach (sort keys %update_list) {
			push( @ARGV, $update_list{$_}->{'Path'} );
		}
	}
}
	
if ($mode eq "status") {
	$dpkg_cmd = "--status";
}
elsif ($mode eq "list") {
	unshift( @ARGV, "*" ) if !@ARGV; # list all packages if no arg given
	$dpkg_cmd = "--list";
}
elsif ($mode eq "listfiles") {
	$dpkg_cmd = "--listfiles";
}
elsif ($mode eq "remove") {
	$dpkg_cmd = "--purge";
}
elsif ($mode eq "install") {
	my( @debs, $deb );
	print "Converting packages:\n" if $verbose >= 2;
	foreach $package ( @ARGV ) {
		$deb = sub_build( $package, "/tmp" );
		if ($deb) {
			push( @debs, "/tmp/$deb" );
		}
		else {
			$retval = 1;
		}
	}
	if (@debs) {
		print "Installing converted packages with dpkg\n" if $verbose >= 2;
		open( PIPE, "dpkg -i @debs 2>&1 |" );
		while( <PIPE> ) {
			if ($verbose == 1 && /^Unpacking (replacement )?(\S+)/) {
				print "Unpacking $2\n";
				next;
			}
			print if ($verbose >= 1 && /^Setting up/) ||
					 $verbose >= 2 ||
				     !/^(\(Reading\sdatabase|
					     Selecting\spreviously\sdeselected\spackage|
					     Unpacking|
					     Preparing\sto\sreplace|
						 Setting\sup)/xi;
		}
		close( PIPE );
		if ($?) {
			warn "dpkg -i failed.\n";
			$retval = 1;
		}
		print "Removing tmp packages\n" if $verbose >= 2;
		if (unlink( @debs ) != @debs) {
			warn "Removing @debs failed: $!\n";
			$retval = 1;
		}
	}
}
elsif ($mode eq "build") {
	foreach $package ( @ARGV ) {
		$retval = 1 if !sub_build( $package, "." );
	}
}
	
if ($dpkg_cmd) {
	my $cmdline = "dpkg $dpkg_cmd " .
		          join( " ", map( rewrite_pkg_name($_), @ARGV ));
	print "Calling $cmdline\n" if $verbose >= 2;
	system( $cmdline );
	$retval = $? >> 8;
}
exit $retval;


sub rewrite_pkg_name {
	my $name = shift;

	$name .= "-$arch-cross" if $name !~ /-\Q$arch\E-cross$/;
	return $name;
}

sub sub_build {
	my $package = shift(@_);
	my $debpath = shift(@_);
	my $package_basename;
	($package_basename = $package) =~ s,.*/,,;
	
	my $tmpdir = "/tmp/.dpkg-cross.$$";
	my $dtmp = "$tmpdir/debian/tmp";
	my @libdirs = qw( lib usr/lib usr/X11R6/lib );
	my @incdirs = qw( usr/include usr/X11R6/include );

	my( $field, $val, $pkg_architecture, $pkg_package, $pkg_version );
	my( $dpkg_errs, $tar_errs, $dir, $file, $filex, $debname, $evers, @files );
	my $oldinthandler = $SIG{'INT'};
	my $nofail_msg = 0;
	
	# first of all, check if the file exists
	-r $package || warn "$progname: Cannot access $package: $!\n", return;

	print "Going to convert $package_basename\n" if $verbose >= 2;

	# extract interesting fields from the control info
	foreach $field (qw( package architecture version )) {
		chomp( $val = `dpkg-deb -f $package $field` );
		if ($?) {
			warn "$progname: dpkg-deb -f $field failed on $package: $val\n";
			return "";
		}
		eval "\$pkg_$field = '$val'";
	}
	($evers = $pkg_version) =~ s/^\d+://; # strip epoch for filename
	$debname = "${pkg_package}-$arch-cross_${evers}_all.deb";
	
	# check for right arch of the package
	if ($pkg_architecture ne $arch) {
		warn "$progname: $package has wrong architecture ($pkg_architecture)\n";
		return "";
	}

	# make a tmp dir for extracting
	if (!mkdir( $tmpdir, 0755 )) {
		warn "$progname: Cannot create $tmpdir: $!\n";
		return "";
	}

	# remove tmp files on C-c
	$SIG{'INT'} = sub {
		print "Removing tmp files...\n" if $verbose >= 2;
		system "rm -rf $tmpdir $debpath/$debname";
		die "Interrupted.\n";
	};

	print "Extracting control files\n" if $verbose >= 2;
	# extract the control files (only interested in shlibs)
	if (system "dpkg-deb -e $package $tmpdir") {
		warn "$progname: dpkg-deb -e failed on $package\n";
		goto fail1;
	}

	print "Extracting data files\n" if $verbose >= 2;
	# extract all interesting files (in certain dirs) from the fsys part
	open( PIPE, "dpkg-deb --fsys-tarfile $package | ".
		        "tar xf - -C $tmpdir @libdirs @incdirs 2>&1 |" );
	while( <PIPE> ) {
		if (/^dpkg-deb:\s*(.*)/) {
			$dpkg_errs .= "$1\n";
			next;
		}
		elsif (/^tar:\s*\S+:\s*not found/i || /^tar: error exit delayed/i) {
			# ignore "usr/include: Not found in archive" or similar
		}
		elsif (/^tar:\s*(.*)/) {
			$tar_errs .= "$1\n";
			next;
		}
	}
	close( PIPE );
	if ($dpkg_errs || $tar_errs) {
		warn "$progname: extracting files from $package failed\n";
		if ($dpkg_errs) {
			print STDERR "dpkg-deb error messages:\n$dpkg_errs";
		}
		else {
			print STDERR "tar error messages:\n$tar_errs";
		}
		goto fail1;
	}

	# check for libc5 compat packages
	if (-d "$tmpdir/lib/libc5-compat" ||
		-d "$tmpdir/usr/lib/libc5-compat" ||
		-d "$tmpdir/usr/$arch-linuxlibc1") {
		warn "$pkg_package seems to be for libc5 compability -- ".
			 "cannot handle this\n";
		goto fail1;
	}
	
	# make sure destination dirs exist
	makedirs( "$dtmp$crosslib" );
	makedirs( "$dtmp$crossinc" );
	makedirs( "$dtmp/DEBIAN" );

	print "Moving libraries:\n" if $verbose >= 2;
	# move libs to their location
	foreach $dir ( @libdirs ) {
		-d "$tmpdir/$dir" || next;
		# remove subdirs in .../lib, don't need them
		my @dirfiles;
		for $file ( <$tmpdir/$dir/*> ) {
			if (-d $file) {
				system "rm -rf $file";
			}
			else {
				$file =~ s,^\Q$tmpdir/$dir/\E,,;
				push( @files, $file );
				push( @dirfiles, $file );
			}
		}
		for $file ( @dirfiles ) {
			print "  $dir/$file\n" if $verbose >= 2;
			if (!rename( "$tmpdir/$dir/$file", "$dtmp$crosslib/$file" )) {
				warn "$progname: renaming $tmpdir/$dir/$file to ".
					 "$dtmp$crosslib/$file failed: $!\n";
				goto fail2;
			}
		}
	}

	# check for absolute symlinks in $crosslib, and correct them
	foreach $filex ( @files ) {
		$file = "$dtmp$crosslib/$filex";
		next unless -l $file;
		my $linkto = readlink($file);
		next unless $linkto =~ m,^(\.\.)?/,;
		
		my $basename;
		($basename = $linkto) =~ s,.*/,,;
		unlink $file;
		print "Changing symlink $filex -> $linkto\n"
			if $verbose >= 2;
		symlink( $basename, $file )
			|| warn "$progname: Cannot create symlink $file -> $basename\n";
	}

	# remove usr/include/X11 symlink (comes in the way of a directory)
	unlink( "$tmpdir/usr/include/X11" ) if -l "$tmpdir/usr/include/X11";

	print "Moving include files:\n" if $verbose >= 2;
	# now move include files to their destination
	foreach $dir ( @incdirs ) {
		my( @incfiles );
		-d "$tmpdir/$dir" || next;
		for $file ( `find $tmpdir/$dir` ) {
			chomp( $file );
			next if $file eq "$tmpdir/$dir";
			$file =~ s,^\Q$tmpdir/$dir/\E,,;
			if (-d "$tmpdir/$dir/$file") {
				mkdir( "$dtmp$crossinc/$file", 0755 );
			}
			else {
				push( @files, $file );
				push( @incfiles, $file );
				print "  $dir/$file\n" if $verbose >= 2;
				if (!rename( "$tmpdir/$dir/$file", "$dtmp$crossinc/$file" )) {
					warn "$progname: renaming $tmpdir/$dir/$file to ".
						 "$dtmp$crossinc/$file failed: $!\n";
					goto fail2;
				}
			}
		}
		# check for dangling symlinks
		foreach $file ( @incfiles ) {
			$file = "$dtmp$crossinc/$file";
			if (-l $file && !-e $file) {
				unlink $file;
				warn "$progname: Warning: omitted dangling symlink $file\n";
			}
		}
	}

	if (@files == 0) {
		print "$progname: package $pkg_package doesn't provide any useful ".
			  "files. Skipping.\n";
		$nofail_msg = 1;
		goto fail1;
	}

	# install the shlibs file
	if (-f "$tmpdir/shlibs") {
		print "Installing shlibs file\n" if $verbose >= 2;
		rename( "$tmpdir/shlibs", "$tmpdir/debian/tmp/DEBIAN/shlibs" );
	}
	
	print "Converting control infos\n" if $verbose >= 2;
	# create and install the control file.
	open( CONTROL, "dpkg-deb -I $package control|" );
	open( OUT, ">$tmpdir/debian/tmp/DEBIAN/control" ) ||
		die "Cannot create $tmpdir/debian/tmp/DEBIAN/control: $!\n";
	while( <CONTROL> ) {
		chomp;
		if (/Package:\s+(.*)$/i) {
			# append $arch-cross to package name
			$_ = "Package: $1-$arch-cross";
		}
		elsif (/Architecture:/i) {
			# change architecture of package
			$_ = "Architecture: all";
		}
		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-//;
			$_ = "$field: $newdeps";
		}
		elsif (/Section:/i) {
			# change section to devel
			$_ = "Section: devel";
		}
		elsif (/Priority:/i) {
			# change priority to extra
			$_ = "Priority: extra";
		}
		elsif (/(Installed-Size|Suggests|Recommends|Filename|Size|MD5sum):/i) {
			# 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( CONTROL );
	close( OUT );

	# try to remove empty dirs (ignore ENOTEMPTY)
	rmdir( "$dtmp$crosslib" );
	rmdir( "$dtmp$crossinc" );
	
	# build the .deb
	print "Building $debname\n" if $verbose == 1;
	if (system( "dpkg-deb -b $tmpdir/debian/tmp $debpath" .
			    ($verbose >= 2 ? "" : " >/dev/null 2>&1") )) {
		print STDERR "Building package with dpkg-deb -b failed.\n";
		goto fail1;
	}

	$SIG{'INT'} = $oldinthandler;
	system "rm -rf $tmpdir";

	return $debname;
	
fail3:
	unlink "$crossinfo/$pkg_package.list";
	unlink "$crossinfo/$pkg_package.shlibs";
	
fail2:
	warn "$progname: cleanup couldn't remove all new files\n"
		if (unlink @files) != @files;
	
fail1:
	system "rm -rf $tmpdir";
	$SIG{'INT'} = $oldinthandler;
	print STDERR "$progname: Conversion of $package failed.\n"
		unless $nofail_msg;
	return 0;
}

sub get_update_list {
	my( %installed, %available, %av_path, $pkg, %update_list, $cnt );
	local( *F );

	if ($verbose >= 2) {
		print "Determining installed packages ";
		STDOUT->flush();
	}
	open( F, "<$dpkg_statfile" ) or die "Can't open $dpkg_statfile: $!";
	%installed = parse_pkg_list();
	if ($verbose >= 2) {
		$cnt = %installed;
		$cnt = $cnt+0;
		print "($cnt packages)\n";
	}

	foreach (@_) {
		scan_available( \%available, \%av_path, $_ );
	}

	foreach $pkg (keys %installed) {
		if (exists($available{$pkg}) &&
			version_less_p( $installed{$pkg}, $available{$pkg} )) {
			$update_list{$pkg}->{'Path'} = $av_path{$pkg};
			$update_list{$pkg}->{'Oldver'} = $installed{$pkg};
			$update_list{$pkg}->{'Newver'} = $available{$pkg};
		}
	}
	return %update_list;
}

sub scan_available {
	my $av_ref = shift;
	my $path_ref = shift;
	my $pkgpath = shift;
	my( @pkglist, %available, $file, $pkg, $cnt );

	if ($verbose >= 2) {
		print "Scanning .deb files under $pkgpath ";
		STDOUT->flush();
	}
	@pkglist = `find $pkgpath -type f -a -name '*.deb' -print`;
	die "find command returned error status $?\n" if $?;
	if (!@pkglist) {
		print "No .deb files found under $pkgpath\n" if $verbose >= 1;
		return;
	}
	chomp @pkglist;

	foreach $file (@pkglist) {
		open( F, "dpkg --field $file |" )
			or die "Can't run dpkg --field $file: $!\n";
		if (%available = parse_pkg_list(1)) {
			$pkg = (keys %available)[0];
			$av_ref->{$pkg} = $available{$pkg};
			$path_ref->{$pkg} = $file;
			++$cnt;
		}
	}
	print "($cnt packages)\n" if $verbose >= 2;
}

sub parse_pkg_list {
	my $avail_pkg = shift;
	my( $name, $version, %result );
	local($/) = ""; # read in paragraph mode

	while( <F> ) {
		/^Package:\s*(\S+)\s*$/mi || next; $name = $1;
		if ($avail_pkg) {
			# available package: check architecture
			/^Architecture:\s*(\S+)\s*$/mi || next;
			next if $1 ne $arch;
		}
		else {
			# package from status file: check if installed at all, and
			# if cross-compiling package; strip suffix from name
			next if /^Status:.*\s+(\S+)\s*$/mi && $1 ne 'installed';
			next if $name !~ /-$arch-cross$/;
			$name =~ s/-$arch-cross$//;
		}
		/^Version:\s*(\S+)\s*$/mi || next; $version = $1;
		$result{$name} = $version;
	}
	close( F ) or die "Error status from dpkg\n";;
	return %result;
}

sub version_less_p {
	my $vers1 = shift;
	my $vers2 = shift;

	system( "dpkg --compare-versions $vers1 '<<' $vers2" );
	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 grep { $_ eq $1 } @omit_depends;
	$str =~ s/^([^ (]+)/$1-$arch-cross/;
	return $str;
}

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 .= "/";
	}
}

#
# general code to read dpkg-cross configuration
#

sub read_config {
	my $package;
	
	open( F, "<$conffile" ) || return;
	while( <F> ) {
		next if /^(\s*#|$)/;
		if (/\s*([\w\d_]+)\s*=\s*(.*)\s*$/) {
			if ($package) {
				${$pkgvars{$package}}{$1} = $2;
			}
			elsif (grep $_ eq $1, @intern_vars) {
				eval "\$$1 = '$2'";
			}
			else {
				warn "$progname: Warning: definition of unknown variable $1 ".
					 "in $conffile, line $.\n";
				next;
			}
		}
		elsif (/^\s*([\w\d.-]+):\s*$/) {
			$package = $1;
		}
		else {
			warn "$progname: unrecognized line in $conffile, line $.\n";
		}
	}
	close( F );
}


sub setup {
	my( $package, $var );
	my @vars = ( "arch", @intern_vars );

	# finalize, no subst possible crossbase
	$crossbase ||= "/usr/local";

	# set defaults for internal vars, if not set
	$crossprefix ||= "\$(ARCH)-linux-";
	$crossdir    ||= "\$(CROSSBASE)/\$(ARCH)-linux";
	$crossbin    ||= "\$(CROSSDIR)/bin";
	$crosslib    ||= "\$(CROSSDIR)/lib";
	$crossinc    ||= "\$(CROSSDIR)/include";
	$crossinfo   ||= "\$(CROSSLIB)/dpkg-cross-info";
	# and substitute references in them
	foreach $var ( @intern_vars ) {
		next if $var eq "crossbase" || $var eq "maintainer";
		subst( eval "\\\$$var", $var, @vars );
	}

	# substitute variable references in package var definitions
	foreach $package ( keys %pkgvars ) {
		foreach $var ( keys %{$pkgvars{$package}} ) {
			subst( \${$pkgvars{$package}}{$var}, $var, @vars );
		}
	}
}


sub subst {
	my $valref = shift(@_);
	my $varname = shift(@_);
	my @defined_vars = @_;
	my( $fulltext, $name, $newval );

	while( $$valref =~ /\$\((\w+)\)/ ) {
		$name = $1;
		if (grep "\U$_\E" eq $name, @defined_vars ) {
			$newval = eval "\"\$\L$name\E\"";
		}
		elsif (!($newval = $ENV{$name})) {
			warn "$progname: Cannot substitute \$($name) in definition ".
				 "of $varname\n";
			$newval = "";
		}
		$$valref =~ s/\$\($name\)/$newval/;
	}
}

