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
|
#!/usr/bin/perl
#
# vim: ts=4:noet
#
# sboclean
# script to clean stuff left around from sbotools.
#
# authors: Jacob Pipkin <j@dawnrazor.net>
# Luke Williams <xocel@iquidus.org>
# Andreas Guldstrand <andreas.guldstrand@gmail.com>
# license: WTFPL <http://sam.zoy.org/wtfpl/COPYING>
use 5.16.0;
use strict;
use warnings FATAL => 'all';
use SBO::Lib qw/ prompt usage_error script_error in show_version %config /;
use File::Basename;
use Getopt::Long qw(:config bundling);
use File::Path qw(remove_tree);
my $self = basename($0);
sub show_usage {
print <<"EOF";
Usage: $self (options) [package]
Options:
-h|--help:
this screen.
-v|--version:
version information.
-d|--dist:
clean distfiles.
-w|--work:
clean working directories.
-i|--interactive:
be interactive.
EOF
return 1;
}
my ($help, $vers, $dist, $work, $interactive);
GetOptions(
'help|h' => \$help,
'version|v' => \$vers,
'dist|clean-dist|d' => \$dist,
'work|clean-work|w' => \$work,
'interactive|i' => \$interactive,
);
if ($help) { show_usage(); exit 0 }
if ($vers) { show_version(); exit 0 }
usage_error("You must specify at least one of -d or -w.") unless
($dist || $work);
sub rm_full {
script_error('rm_full requires an argument.') unless @_ == 1;
my $full = shift;
if ($interactive) {
return() unless prompt("Remove $full?", default => 'no');
}
unlink $full if -f $full;
remove_tree($full) if -d $full;
return 1;
}
sub remove_stuff {
script_error 'remove_stuff requires an argument.' unless @_ == 1;
my $dir = shift;
if (not -d $dir) {
say 'Nothing to do.';
return 0;
}
opendir(my $dh, $dir);
FIRST: while (my $ls = readdir $dh) {
next FIRST if in($ls => qw/ . .. /);
rm_full("$dir/$ls");
}
return 1
}
sub clean_c32 {
my $dir = $SBO::Lib::tmpd;
opendir(my $dh, $dir);
FIRST: while (my $ls = readdir $dh) {
next FIRST unless $ls =~ /^package-.+-compat32$/;
rm_full("$dir/$ls");
}
return 1;
}
remove_stuff($config{SBO_HOME} .'/distfiles') if $dist;
if ($work) {
my $env_tmp = $SBO::Lib::env_tmp;
my $tsbo = $SBO::Lib::tmpd;
if ($env_tmp && !$interactive) {
warn "This will remove the entire contents of $env_tmp\n";
remove_stuff($tsbo) if prompt("Proceed?", default => 'yes');
} else {
remove_stuff($tsbo);
}
clean_c32();
}
exit 0;
|
