bin/quick-tmp-cleanup.pl

   1 #!/usr/bin/perl
   2
   3 # use 5.010;
   4 use strict;
   5 use warnings;
   6
   7 =head1 NAME
   8
   9
  10
  11 =head1 SYNOPSIS
  12
  13
  14
  15 =head1 OPTIONS
  16
  17 =over 8
  18
  19 =cut
  20
  21 my @opt = <<'=back' =~ /B<--(\S+)>/g;
  22
  23 =item B<--help|h!>
  24
  25 This help
  26
  27 =back
  28
  29 =head1 DESCRIPTION
  30
  31 First attempt believed that one would remove old files and then remove
  32 directories. But we have plenty of old files that must not be deleted:
  33 whenever a cpan shell has just unpacked a tarball, all these files
  34 must be preserved.
  35
  36 Second attempt used find instead of finddepth and pruned directories
  37 that were in use according to fuser. Additionally it required them to
  38 be older than a day. And required files too to be older than a day to
  39 be deleted. BUT: I forgot reloperl which must be kept intact
  40 completely. E.g. /tmp/basesmoker-reloperl-cGFh
  41
  42 =cut
  43
  44 # die "BROKEN, DO NOT USE";
  45
  46 use English qw( -no_match_vars ) ;
  47
  48 die sprintf "ALERT: effective uid %d not allowed\n", $EFFECTIVE_USER_ID if $EFFECTIVE_USER_ID==0;
  49
  50 use Time::HiRes qw(sleep);
  51
  52 use FindBin;
  53 use lib "$FindBin::Bin/../lib";
  54 BEGIN {
  55     push @INC, qw(       );
  56 }
  57
  58 use Dumpvalue;
  59 use File::Basename qw(dirname);
  60 use File::Path qw(mkpath);
  61 use File::ReadBackwards;
  62 use File::Spec;
  63 use File::Temp;
  64 use Getopt::Long;
  65 use Hash::Util qw(lock_keys);
  66 use List::Util qw(reduce);
  67 use Pod::Usage qw(pod2usage);
  68 use Proc::ProcessTable;
  69
  70 our %Opt;
  71 lock_keys %Opt, map { /([^=!\|]+)/ } @opt;
  72 GetOptions(\%Opt,
  73            @opt,
  74           ) or pod2usage(1);
  75
  76 if ($Opt{help}) {
  77     pod2usage(0);
  78     exit;
  79 }
  80
  81 use File::Find;
  82 find
  83     ({
  84       wanted => sub {
  85           my($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size, $atime, $mtime) = lstat($File::Find::name);
  86           if (-l _) {
  87               my($r) = readlink $File::Find::name;
  88               warn "symlink: $File::Find::name => $r\n";
  89           } elsif (! defined $mtime) {
  90               # skip
  91           } elsif ("/tmp" eq $File::Find::name) {
  92               # skip
  93           } elsif ( $File::Find::name =~ /tmp\/basesmoker-reloperl/ ) {
  94               # skip
  95               $File::Find::prune = 1;
  96           } elsif ( $File::Find::name =~ /tmp\/loop_over_bdir/ ) {
  97               # skip
  98               $File::Find::prune = 1;
  99           } elsif ( $File::Find::name =~ /tmp\/perl-clone-\d/ ) {
 100               # skip
 101               $File::Find::prune = 1;
 102           } elsif ( $File::Find::name =~ /tmp\/CPAN-Reporter-/ ) {
 103               # skip
 104               $File::Find::prune = 1;
 105           } elsif (-d _) {
 106               warn "About to run fuser on directory '$File::Find::name'\n";
 107               open my $fh, "-|", fuser => $File::Find::name or die;
 108               my $inuse = 0;
 109               while (<$fh>) {
 110                   my($file, $proc) = split " ", $_;
 111                   if ($proc){
 112                       $inuse = 1;
 113                       $File::Find::prune = 1;
 114                   }
 115               }
 116               if ($mtime+86400 < $^T) {
 117                   warn "keeping fresh directory: $File::Find::name ($^T)";
 118               } elsif ($inuse){
 119                   warn "directory in use: $File::Find::name\n";
 120               } elsif (rmdir($File::Find::name)) {
 121                   warn "rmdir: $File::Find::name\n";
 122                   $File::Find::prune = 1;
 123               } else {
 124                   warn "no rmdir: $File::Find::name ($!)";
 125                   return;
 126               }
 127           } elsif ($mtime+86400 < $^T) {
 128               warn "About to run fuser on day old file '$File::Find::name'\n";
 129               open my $fh, "-|", fuser => $File::Find::name or die;
 130               my $inuse = 0;
 131               while (<$fh>) {
 132                   my($file, $proc) = split " ", $_;
 133                   $inuse = 1 if $proc;
 134               }
 135               if ($inuse){
 136                   warn "file in use: $File::Find::name\n";
 137               } elsif (unlink($File::Find::name)) {
 138                   warn "unlink: $File::Find::name\n";
 139               } else {
 140                   warn "no unlink: $File::Find::name ($!)";
 141               }
 142           } else {
 143               my $secs_old = $^T-$mtime;
 144               # warn "keeping too young file: $File::Find::name ($secs_old seconds old)\n";
 145               return;
 146           }
 147           sleep 0.02;
 148       },
 149       no_chdir => 1,
 150      },
 151      "/tmp");