#!/usr/bin/perl
#
# Look at what wrappers are needed, get rid of ones that arn't needed any more,
# and generate those that do not already exit. Uses dpkg-divert to keep dpkg
# from installing files over top of the wrappers.

# Configuration section
$histfile='/var/lib/xaw-wrappers/update-wrappers-history';
$wrapperfile='/usr/lib/xaw-wrappers/wrapper';
BEGIN { unshift @INC, "/usr/lib/xaw-wrappers/" }

# Print out the text if verbose.
sub Log {
	print shift if $verbose;
}

# Purge a wrapper from the system.
sub RemoveWrapper { my $fn=shift;
	if (-l $fn && unlink ($fn) eq 0) {
		print "\t$fn: symlink unlink failed: $!\n";
		$errorexit=1;
		return;
	}
	
	my $ret=system "/usr/sbin/dpkg-divert","--quiet","--rename","--remove",$fn;
	if (int($ret/256) ne 0) {
		print "\t$fn: dpkg-divert failed\n";
		$errorexit=1;
		return;
	}

	Log "\t$fn\n";
}

# Add a wrapper to the system, and set up diversion.
sub AddWrapper { my $fn=shift;
	# This should no longer happen, but I've left the fix in out of paranoia.
	# --fixup makes us correct it.
	if (-e $fn and ! -l $fn and -e "$fn.real" and $fixup) {
		print "\n";
		print "** $fn was doubled; fixing.\n";
		print "   The author of this program still doesn't understand how\n";
		print "   we got into this state. If you would, please contact\n";
		print "   <xaw-wrappers\@packages.debian.org>, and tell me you\n";
		print "   experienced this bug. If possible, provide a transcript of\n";
		print "   this dpkg run.\n";
		print "[Press Return to continue]";
		<>;
		print "\n";
		unlink "$fn.real";
	}

	my $ret=system "/usr/sbin/dpkg-divert","--package","xaw-wrappers","--add",
		"--quiet","--rename","--divert","$fn.real","$fn";
	if (int($ret/256) ne 0) {
		print "\t$fn: dpkg-divert failed\n";
		$errorexit=1;
		return;
	}

	if (!-e $fn and ! -l $fn)  {
		if (symlink($wrapperfile,$fn) ne 1) {
			print "\t$fn: symlink failed: $!\n";
			$errorexit=1;
			return;
		}
	}
	elsif (!-l $fn) {
		print "\t$fn: unable to symlink\n";
		$errorexit=1;
		return;
	}

	Log "\t$fn\n";
}

# Parse parameters.
use Getopt::Long;
$ret=&GetOptions(
	"help|h", \$help,
	"verbose|v", \$verbose,
	"force|f", \$force,
	"off|o", \$off,
	"fixup",\$fixup,
);

# Usage help.
if ($help) {
	print <<eof;
update-xaw-wrappers sets up wrapper scripts around programs that do not
work well with some xaw replacement libraries.

Usage: update-xaw-wrappers [options ...]
  -h, --help      Display this help text
  -v, --verbose   Be verbose about what changes are being made
  -f, --force     Force removal and reset up all wrappers
  -o, --off       Only remove exitsting wrappers, do not add new
eof
	exit;
}

# Make sure I have root privs.
if ($> ne 0) {
  print STDERR "$0 must be run as root.\n";
  exit 1;
}

# Loading this package causes all config files to be read.
use XawWrapper;
Log "Updating xaw wrappers..\n";

# Load up the list of what wrappers existed when this was run last, and
# if any of those are not needed, get rid of them.
# The format of the history file is simply one filename per line.
Log "Removing wrappers:\n";
open (HISTORY,"<$histfile");
while (<HISTORY>) {
	chomp;
	if ($force || !defined($XawWrapper::files{$_})) {
		RemoveWrapper($_);
	}
}
close HISTORY;

# Create new wrappers, and write out the history file.
if (!$off) {
	Log "Adding wrappers:\n";
	open (HISTORY,">$histfile") || die "open $histfile: $!\n";
	foreach $fn (keys(%XawWrapper::files)) {
		print HISTORY "$fn\n";
		AddWrapper($fn);
	}
	close HISTORY;
}

exit $errorexit if $errorexit;
