sbotools2

Maintenance fork of the original sbotools version 2
git clone git://git.server.ky/slackcoder/sbotools2
Log | Files | Refs | README

sboclean (2467B)

      1 #!/usr/bin/perl
      2 #
      3 # vim: ts=4:noet
      4 #
      5 # sboclean
      6 # script to clean stuff left around from sbotools.
      7 #
      8 # authors: Jacob Pipkin <j@dawnrazor.net>
      9 #          Luke Williams <xocel@iquidus.org>
     10 #          Andreas Guldstrand <andreas.guldstrand@gmail.com>
     11 # maintainer: Slack Coder <slackcoder@server.ky>
     12 
     13 use 5.16.0;
     14 use strict;
     15 use warnings FATAL => 'all';
     16 use SBO::Lib qw/ _ERR_USAGE prompt usage_error script_error in show_version %config /;
     17 use File::Basename;
     18 use Getopt::Long qw(:config bundling);
     19 use File::Path qw(remove_tree);
     20 
     21 my $self = basename($0);
     22 
     23 sub show_usage {
     24 	print <<"EOF";
     25 Usage: $self (options) [package]
     26 
     27 Options:
     28   -h|--help:
     29     this screen.
     30   -v|--version:
     31     version information.
     32   -d|--dist:
     33     clean distfiles.
     34   -w|--work:
     35     clean working directories.
     36   -i|--interactive:
     37     be interactive.
     38 
     39 EOF
     40 	return 1;
     41 }
     42 
     43 my ($help, $vers, $dist, $work, $interactive);
     44 
     45 if (! GetOptions(
     46 	'help|h'            => \$help,
     47 	'version|v'         => \$vers,
     48 	'dist|clean-dist|d' => \$dist,
     49 	'work|clean-work|w' => \$work,
     50 	'interactive|i'     => \$interactive,
     51 )) {
     52   show_usage();
     53   exit 1;
     54 }
     55 
     56 if ($help) { show_usage(); exit 0 }
     57 if ($vers) { show_version(); exit 0 }
     58 
     59 usage_error("You must specify at least one of -d or -w.") unless
     60 	($dist || $work);
     61 
     62 unless ($< == 0) {
     63 	warn "This script requires root privileges.\n";
     64 	exit _ERR_USAGE;
     65 }
     66 
     67 sub rm_full {
     68 	script_error('rm_full requires an argument.') unless @_ == 1;
     69 	my $full = shift;
     70 	if ($interactive) {
     71 		return() unless prompt("Remove $full?", default => 'no');
     72 	}
     73 	unlink $full if -f $full;
     74 	remove_tree($full) if -d $full;
     75 	return 1;
     76 }
     77 
     78 sub remove_stuff {
     79 	script_error 'remove_stuff requires an argument.' unless @_ == 1;
     80 	my $dir = shift;
     81 	if (not -d $dir) {
     82 		say 'Nothing to do.';
     83 		return 0;
     84 	}
     85 	opendir(my $dh, $dir);
     86 	FIRST: while (my $ls = readdir $dh) {
     87 		next FIRST if in($ls => qw/ . .. /);
     88 		rm_full("$dir/$ls");
     89 	}
     90 	return 1
     91 }
     92 
     93 sub clean_c32 {
     94 	my $dir = $SBO::Lib::tmpd;
     95 	opendir(my $dh, $dir);
     96 	FIRST: while (my $ls = readdir $dh) {
     97 		next FIRST unless $ls =~ /^package-.+-compat32$/;
     98 		rm_full("$dir/$ls");
     99 	}
    100 	return 1;
    101 }
    102 
    103 remove_stuff($config{SBO_HOME} .'/distfiles') if $dist;
    104 
    105 if ($work) {
    106 	my $env_tmp = $SBO::Lib::env_tmp;
    107 	my $tsbo = $SBO::Lib::tmpd;
    108 	if ($env_tmp && !$interactive) {
    109 		warn "This will remove the entire contents of $env_tmp\n";
    110 		remove_stuff($tsbo) if prompt("Proceed?", default => 'yes');
    111 	} else {
    112 		remove_stuff($tsbo);
    113 	}
    114 	clean_c32();
    115 }
    116 
    117 exit 0;