File: update-xaw-wrappers.pl

package info (click to toggle)
xaw-wrappers 0.21
  • links: PTS
  • area: main
  • in suites: hamm
  • size: 72 kB
  • ctags: 14
  • sloc: perl: 237; makefile: 35; sh: 31
file content (136 lines) | stat: -rwxr-xr-x 3,504 bytes parent folder | download | duplicates (2)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
#!/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;