Documentation/scripts/prtwash.pl

261 lines
8.0 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.
# (c) 2022, 2023 John McQuah <jmcquah at disroot dot org>
# based on the bash script by Simone Rota <sip at varlock dot com>
#
# ChangeLog 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);
# thanks GazL for the reminder to escape any metacharacters
$name =~ s/[.+]/\\$&/g;
$version =~ s/[.+]/\\$&/g;
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","maintainer_clean_footprint") 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-$release\.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 $allbuilds = pop(@keepers);
my $currbuild = pop(@keepers);
my %iswanted = map { $_ => 1 } @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 '..');
if ($iswanted{$f} 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!
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 };
}
}