File: Uninstall.pm

package info (click to toggle)
xmltv 0.5.59-1
  • links: PTS, VCS
  • area: main
  • in suites: squeeze
  • size: 9,040 kB
  • ctags: 671
  • sloc: perl: 37,820; xml: 414; makefile: 15; sh: 9
file content (59 lines) | stat: -rw-r--r-- 1,654 bytes parent folder | download | duplicates (5)
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
# Supplement to ExtUtils::MakeMaker to add back some rudimentary
# uninstall functionality.  This needs to be called with an extra
# 'uninstall' target in the Makefile, for which you will need to
# modify your Makefile.PL.  I kept well away from the deprecated and
# no-longer-working uninstall stuff in MakeMaker itself.
#
# $Id: Uninstall.pm,v 1.5 2004/01/03 14:52:53 epaepa Exp $
#
package Uninstall;
use strict;
use base 'Exporter'; our @EXPORT = qw(uninstall);
use File::Find;

sub uninstall( % ) {
    my %h = @_;
    my %seen_pl;
    foreach (qw(read write)) {
	my $pl = delete $h{$_};
	if (defined $pl and not $seen_pl{$pl}++) {
	    warn "ignoring packlist $pl\n";
	}
    }
    foreach my $from (keys %h) {
	next if not -e $from;
	my $to = $h{$from};
	print "uninstalling contents of $from from $to\n";
	find(sub { 
		 for ($File::Find::name) {
#		     return if not -f; # why doesn't this work?
		     
		     # The behaviour of File::Find seems different
		     # under 5.005.
		     #
		     s!^\Q$from\E/*!!
		       or ($[ < 5.006)
			 or die "filename '$_' doesn't start with $from/";

		     return if not length; # skip directory itself
		     return if m!(?:/|^)\.exists!;
		     my $inside_to = "$to/$_";
		     if (-e $inside_to) {
			 if (-f $inside_to) {
			     print "unlinking $inside_to\n";
			     unlink $inside_to or warn "cannot unlink $inside_to: $!";
			 }
			 elsif (-d $inside_to) {
			     print "not removing directory $inside_to\n";
			 }
			 else {
			     print "not removing special file $inside_to\n";
			 }
		     }
		     else {
			 print "$inside_to is not installed\n";
		     }
		 }
	     }, $from);
    }
}