258 lines
7.9 KiB
Perl
Executable File
258 lines
7.9 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
#
|
|
########################################################################
|
|
#
|
|
# prtwash
|
|
# ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
|
|
# This is a script for removing rubbish from a CRUX port tree.
|
|
# Distributed under the terms of the GPL license.
|
|
#
|
|
# ChangeLog and author information available in the prt-utils tarball.
|
|
#
|
|
########################################################################
|
|
|
|
use strict;
|
|
use File::Basename;
|
|
use File::Path;
|
|
our @portdirs;
|
|
our $argports;
|
|
my $version = 1.2.1;
|
|
our %options = ( oldver=>0, pkgtoo=>0, srctoo=>0, addons=>0,
|
|
dryrun=>0, auto=>0, quiet=>0, parse_pkgmk=>0 );
|
|
|
|
#################### main routine ################################
|
|
parse_args();
|
|
print_usage() if ((2*$argports-1)*(1-2*$options{auto}) < 0);
|
|
our $compression_mode = get_compress();
|
|
|
|
if ($options{auto} == 1) {
|
|
my @bldirs = getportdirs();
|
|
my @basedirs = @{$bldirs[0]}; my @localports = @{$bldirs[1]};
|
|
my $port;
|
|
foreach my $collection (@basedirs) {
|
|
print "====> Washing port collection $collection\n";
|
|
foreach $port (list_subdirs($collection)) {
|
|
do_wash($port);
|
|
}
|
|
}
|
|
foreach $port (@localports) {
|
|
do_wash($port);
|
|
}
|
|
} else {
|
|
foreach my $port (@portdirs) {
|
|
do_wash($port);
|
|
}
|
|
}
|
|
|
|
#################### subroutines #################################
|
|
sub parse_args {
|
|
foreach my $arg (@ARGV) {
|
|
if ($arg eq "-b") {
|
|
$options{oldver} = 1;
|
|
} elsif ($arg eq "-p") {
|
|
$options{pkgtoo} = 1;
|
|
} elsif ($arg eq "-s") {
|
|
$options{srctoo} = 1;
|
|
} elsif ($arg eq "-d") {
|
|
$options{addons} = 1;
|
|
} elsif ($arg eq "-t") {
|
|
$options{dryrun} = 1;
|
|
} elsif ($arg eq "-a") {
|
|
$options{auto} = 1;
|
|
} elsif ($arg eq "-q") {
|
|
$options{quiet} = 1;
|
|
} elsif ($arg eq "--parse-pkgmk-conf") {
|
|
$options{parse_pkgmk} = 1;
|
|
} elsif ($arg eq "-v") {
|
|
print "$version\n";
|
|
exit(0);
|
|
} elsif ((-d $arg) || # false for symlink to a portdir, so a
|
|
(-f "$arg/Pkgfile")) { # followup test is performed to catch those
|
|
push (@portdirs, $arg);
|
|
} elsif (-f $arg) {
|
|
print "WARN: ignoring invalid port directory $arg\n";
|
|
} else {
|
|
print_usage();
|
|
}
|
|
}
|
|
$argports = @portdirs;
|
|
}
|
|
|
|
sub print_usage {
|
|
print <<EOT;
|
|
Usage: prtwash [OPTION]... [PORTDIRS]...
|
|
|
|
-a automatic mode, only valid when [PORTDIRS] are omitted
|
|
-p delete the built package (current version)
|
|
-b delete older versions of the built package
|
|
-s remove upstream tarballs (those NOT obtained by ports -u)
|
|
-d remove add-on files (sources obtained by ports -u)
|
|
-t test mode, don't actually delete anything
|
|
-q quiet mode, don't report files that are kept
|
|
-h print this message and exit
|
|
-v show version information and exit
|
|
|
|
Report bugs on libera.chat #crux-devel
|
|
EOT
|
|
exit(0);
|
|
}
|
|
|
|
sub parse_pkgfile {
|
|
my $pkgfile = shift;
|
|
my $name; my $version; my $release=1; my @source; my @renames;
|
|
my $cmd = "bash -c \'source $pkgfile; ";
|
|
$cmd = $cmd.'sa=(_name _version _release ${source[@]}); ';
|
|
$cmd = $cmd.'ra=($name $version $release ${renames[@]}); ';
|
|
$cmd = $cmd.'for ((s=0; s<${#sa[@]}; s++)); do ';
|
|
$cmd = $cmd.'echo "${sa[$s]} ==> ${ra[$s]}"; done'."\' |";
|
|
open(PIPE,$cmd) or return;
|
|
while (<PIPE>) {
|
|
chomp;
|
|
my @a = split(/ ==> /,$_);
|
|
if ($a[0] eq "_name") {
|
|
$name = $a[1];
|
|
} elsif ($a[0] eq "_version") {
|
|
$version = $a[1];
|
|
} elsif ($a[0] eq "_release") {
|
|
$release = $a[1];
|
|
} elsif ($a[0] =~ /^(ftp|http|https):/) {
|
|
$a[0] =~ s/^(ftp|http|https):.*\/(.*)$/remote:\/$2/ ;
|
|
push (@source, $a[0]);
|
|
push (@renames, $a[1]);
|
|
} else {
|
|
push (@source, $a[0]);
|
|
push (@renames, $a[1]);
|
|
}
|
|
}
|
|
close(PIPE);
|
|
return \$name, \$version, \$release, \@source, \@renames;
|
|
}
|
|
|
|
sub keeplist { # remember to pop off the last two elements for regex purposes
|
|
my $port = shift;
|
|
my @keepers = ("Pkgfile",".footprint",".signature");
|
|
push (@keepers,"pre-install","post-install","README","README.md",
|
|
".32bit",".nostrip") if $options{addons}==0;
|
|
|
|
my @parsed = parse_pkgfile("$port/Pkgfile"); # file existence already tested
|
|
my $name = ${$parsed[0]}; # by the caller. But if Pkgfile
|
|
my $version = ${$parsed[1]}; # is unreadable (and these vars
|
|
my $release = ${$parsed[2]}; # are initialized empty), then
|
|
my @source = @{$parsed[3]}; # the user probably doesn't have
|
|
my @renames = @{$parsed[4]}; # permissions to do much damage,
|
|
# even with a minimal keeplist.
|
|
my $i; my $si; my $ki;
|
|
ENTRY: for ($i=0; $i<=$#source; $i++) {
|
|
$si = $source[$i];
|
|
$ki = ("$renames[$i]" eq "SKIP" or "$renames[$i]" eq "") ? basename($si) :
|
|
$renames[$i];
|
|
if ($si =~ /^remote:/) {
|
|
next ENTRY if ($options{srctoo}==1);
|
|
push(@keepers, $ki);
|
|
} else {
|
|
next ENTRY if ($options{addons}==1);
|
|
push(@keepers, $ki);
|
|
}
|
|
}
|
|
push (@keepers, "$name#$version.*\.pkg\.tar\.$compression_mode");
|
|
push (@keepers, "$name#.*\.pkg\.tar\.$compression_mode");
|
|
return @keepers;
|
|
}
|
|
|
|
sub get_compress {
|
|
my $suffix = "(gz|lz|xz|bz2)";
|
|
if ($options{parse_pkgmk} == 1) {
|
|
my $conf = "/etc/pkgmk.conf";
|
|
open(CONFIG,$conf) or return $suffix;
|
|
while(<CONFIG>) {
|
|
$suffix = $1 if m/^[\t ]*PKGMK_COMPRESSION_MODE=(.*)\n/;
|
|
}
|
|
close(CONFIG);
|
|
$suffix =~ s/"//g; # ensure no double-quotes remain (thanks jaeger)
|
|
}
|
|
return $suffix;
|
|
}
|
|
|
|
sub do_wash {
|
|
my $port = shift;
|
|
while ($port =~ s/\/+$//) {}; # ensure the path contains no trailing slash
|
|
if ( ! -f "$port/Pkgfile" ) {
|
|
print "WARN: no Pkgfile found in $port. Skipping.\n";
|
|
return;
|
|
} else {
|
|
my @keepers = keeplist($port); my $iswanted;
|
|
my $allbuilds = pop(@keepers);
|
|
my $currbuild = pop(@keepers);
|
|
|
|
opendir (DIR,$port) or return;
|
|
print "=====> washing $port\n" unless $options{quiet} == 1;
|
|
foreach my $f (sort(readdir(DIR))) {
|
|
next if ($f eq '.' or $f eq '..');
|
|
$f =~ s/\+/\\\+/g; # plus sign in filenames interferes with regex search
|
|
$iswanted = ( grep (/$f/, @keepers ) >= 1 );
|
|
if ($iswanted or ($options{pkgtoo}==0)*($f =~ /$currbuild/)
|
|
or ($options{oldver}==0)*($f =~ /$allbuilds/)*($f !~ /$currbuild/)) {
|
|
print "... keeping file $port/$f.\n" unless $options{quiet} == 1;
|
|
} else {
|
|
remove ("$port/$f");
|
|
}
|
|
}
|
|
closedir (DIR);
|
|
}
|
|
}
|
|
|
|
sub getportdirs { # returns scalar references to two arrays
|
|
my @basedirs; my @localports;
|
|
my $conf = "/etc/prt-get.conf";
|
|
|
|
open(PORTS, $conf) or die "could not open $conf";
|
|
while (<PORTS>) {
|
|
chomp;
|
|
if ( /^prtdir\s+/ ) {
|
|
my $line = $_;
|
|
$line =~ s/^prtdir\s+//; #remove the leading directive
|
|
$line =~ s/#.*$//; #strip inline comments like this one
|
|
$line =~ s/\s+//g; #collapse all whitespace, even if in a path!
|
|
#(not that we ever put spaces or commas in repo names anyway)
|
|
if ( $line !~ /:/ ) {
|
|
push @basedirs, $line if (-d $line);
|
|
} else {
|
|
my @a = split(/:/, $line);
|
|
my @b = split(/,/, $a[1]);
|
|
while ( my $c = pop @b ) {
|
|
my $port = $a[0] . "/" . $c;
|
|
push @localports, $port if (-d $port);
|
|
}
|
|
}
|
|
}
|
|
}
|
|
close(PORTS);
|
|
return \@basedirs, \@localports;
|
|
}
|
|
|
|
sub list_subdirs { # roughly equivalent to `find $1 -maxdepth 1 -type d`
|
|
my $path = shift;
|
|
my @list;
|
|
while ($path =~ s/\/\//\//g) {}
|
|
$path =~ s/\/$//;
|
|
opendir(DIR, $path) or return;
|
|
foreach my $entry(sort(readdir(DIR))) {
|
|
next if ( substr($entry,0,1) eq '.' );
|
|
push (@list, "$path/$entry") if -d "$path/$entry";
|
|
}
|
|
closedir(DIR);
|
|
return @list;
|
|
}
|
|
|
|
sub remove {
|
|
my $path=shift;
|
|
my $prepend = ($options{dryrun}==1) ? "+ (t) " : "+ ";
|
|
if (-d $path) {
|
|
print "$prepend removing directory $path\n";
|
|
rmtree ($path,0,1) if ($options{dryrun}==0);
|
|
} else {
|
|
print "$prepend removing file $path\n";
|
|
if ($options{dryrun}==0) { unlink "$path" or return };
|
|
}
|
|
}
|