Documentation/scripts/prtwash.pl

#!/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 };
  }
}