#!/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);

#
# 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 );
# avoid warnings about unused variables:
$crossbase = $crossprefix = $crossdir = $crossbin = $crosslib =
$crossinc = $crossinfo = "";

sub usageversion {
    print(STDERR <<END)
Usage:
 dpkg-cross [--install|-i] <files...>
 dpkg-cross [--remove|-r] <packages...>
 dpkg-cross [--status|-s] <packages...>
 dpkg-cross [--list|-L] <packages...>

Options:
 -a|--arch ARCH: set architecture (necessary)

dpkg-cross installs or removes libraries and include files for
cross-compiling Debian packages. It is a very-lightweight clone of
dpkg for only that purpose. 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";
}


while( @ARGV ) {
    $_= shift( @ARGV );
    last if m/^--$/;
    if (!/^-/) {
        unshift(@ARGV,$_);
		last;
    }
	elsif (/^--(help|version)$/) {
        usageversion();
		exit( 0 );
	}
	elsif (/^(-i|--install)$/) {
		die "$progname: Only one action can be specified!\n" if $mode;
		$mode = "install";
	}
	elsif (/^(-r|--remove)$/) {
		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 (/^(-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 @ARGV == 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();
read_installed();

if ($mode eq "status") {
	$action = \&print_status;
}
elsif ($mode eq "list") {
	$action = \&print_list;
}
elsif ($mode eq "install") {
	$action = \&do_install;
}
elsif ($mode eq "remove") {
	$action = \&do_remove;
}

foreach $package ( @ARGV ) {
	&$action( $package );
}

write_installed();
exit 0;


sub print_status {
	my $package = shift(@_);

	print "$package is ";
	if ($version{$package}) {
		print "installed in version $version{$package}\n";
	}
	else {
		print "not installed.\n";
	}
}


sub print_list {
	my $package = shift(@_);
	
	if (!$version{$package}) {
		print "$package is not installed.\n";
		return;
	}

	open( F, "<$crossinfo/$package.list" )
		|| warn "$progname: Cannot open $crossinfo/$package.list: $!\n", return;
	print <F>;
	close( F );
}


sub do_install {
	my $package = shift(@_);

	my $tmpdir = "/tmp/.dpkg-cross.$$";
	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, $errs, $dir );
	my( @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;

	# extract interesting fields from the control info
	foreach $field ( "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'";
	}

	# 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
	mkdir( $tmpdir, 0755 ) ||
		warn "$progname: Cannot create $tmpdir: $!\n", return;

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

	# 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) {
			# 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$dpkg_errs";
		}
		goto fail1;
	}

	# make sure destination dirs exist
	makedirs( $crossdir );
	makedirs( $crosslib );
	makedirs( $crossinc );
	makedirs( $crossinfo );

	# remove an maybe existing old version of the package
	if ($version{$pkg_package}) {
		print "Removing old version ($version{$pkg_package}) of $pkg_package\n";
		sub_remove( $pkg_package ) || goto fail1;
	}

	# interrupts from now on are bad
	$SIG{'INT'} = 'IGNORE';

	# move libs to their location
	foreach $dir ( @libdirs ) {
		-d "$tmpdir/$dir" || next;
		# remove subdirs in .../lib, don't need them
		for $file ( <$tmpdir/$dir/*> ) {
			next unless -d $file;
			system "rm -rf $file";
		}
		open( PIPE, "tar cf - -C $tmpdir/$dir . | ".
			 "tar xvf - -C $crosslib 2>&1 |" );
		while( <PIPE> ) {
			if (/^tar:\s*(.*)/) {
				$tar_errs .= "$1\n";
				next;
			}
			else {
				chomp( $_ );
				chop( $_ ) if $_ =~ m,/$,;
				push( @files, "$crosslib/$_" ) unless $_ eq '.';
			}
		}
		close( PIPE );
		if ($tar_errs) {
			warn "$progname: moving libraries to $crosslib failed:\n".
				 "$tar_errs\n";
			goto fail2;
		}
	}

	# check for absolute symlinks in $crosslib, and correct them
	# also remove subdirectories of $crosslib
	foreach $file ( @files ) {
		next unless -l $file;
		my $linkto = readlink($file);
		next unless $linkto =~ m,^(\.\.)?/,;
		
		my $basename;
		($basename = $linkto) =~ s,.*/,,;
		unlink $file;
		symlink( $basename, $file )
			|| warn "$progname: Cannot create symlink $file -> $basename\n";
		warn "$progname: Warning: $file is currently a dangling symlink\n"
			if (!-e "$crosslib/$basename");
	}
		
	# now move include files to their destination
	foreach $dir ( @incdirs ) {
		my( @incfiles );
		-d "$tmpdir/$dir" || next;
		open( PIPE, "tar cf - -C $tmpdir/$dir . | ".
			 "tar xvf - -C $crossinc 2>&1 |" );
		while( <PIPE> ) {
			if (/^tar:\s*(.*)/) {
				$tar_errs .= "$1\n";
				next;
			}
			else {
				chomp( $_ );
				chop( $_ ) if $_ =~ m,/$,;
				push( @files, "$crossinc/$_" ) unless $_ eq '.';
				push( @incfiles, "$crossinc/$_" ) unless $_ eq '.';
			}
		}
		close( PIPE );
		if ($tar_errs) {
			warn "$progname: moving libraries to $crossinc failed:\n".
				 "$tar_errs\n";
			goto fail2;
		}
		# check for dangling symlinks
		foreach $file ( @incfiles ) {
			if (-l $file && !-x $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") {
		($errs = `mv $tmpdir/shlibs $crossinfo/$pkg_package.shlibs`) &&
			warn "$progname: Couldn't install shlibs file for $package: ".
				 "$errs\n";
	}

	# create a .list file
	if (open( F, ">$crossinfo/$pkg_package.list" )) {
		print F join( "\n", @files ), "\n";
		close( F );
	}
	else {
		warn "$progname: Cannot create $crossinfo/$pkg_package.list: $!\n";
		goto fail3;
	}

	$SIG{'INT'} = $oldinthandler;

	# now, finally, everything's ok :-)
	print "Installed $pkg_package $pkg_version ";
	if ($version{$pkg_package}) {
		print "(updated from $version{$pkg_package})\n";
	}
	else {
		print "(new)\n";
	}
	
	system "rm -rf $tmpdir";
	$version{$pkg_package} = $pkg_version;
	$versions_modified = 1;
	return;
	
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: Installation of $package failed.\n"
		unless $nofail_msg;
}


sub do_remove {
	my $package = shift(@_);

	if (!$version{$package}) {
		warn "$progname: $package isn't installed, cannot remove\n";
		return;
	}

	if (sub_remove( $package )) {
		print "Removed $package $version{$package}\n";
		undef $version{$package};
		$versions_modified = 1;
	}
	else {
		print STDERR "Removing $package failed\n";
	}
}


sub sub_remove {
	my $package = shift(@_);
	my @files;
	my( $file, $ok );
	
	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 $_;
	}
	close( F );
	push( @files, "$crossinfo/$package.list" );
	
	foreach $file ( @files ) {
		$isdir = -d $file;
		$ok = ($isdir && !-l $file) ? 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";
	}
	return 1;
}


sub read_installed {

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


sub write_installed {
	my $package;
	
	return if !$versions_modified;

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

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

