scripts/expire-iso8601

   1 #!/usr/bin/perl -w
   2 #
   3 # Copyright 2006 Ian Jackson <ijackson@chiark.greenend.org.uk>
   4 #
   5 # This script and its documentation (if any) are free software; you
   6 # can redistribute it and/or modify them under the terms of the GNU
   7 # General Public License as published by the Free Software Foundation;
   8 # either version 3, or (at your option) any later version.
   9 #
  10 # chiark-named-conf and its manpage are distributed in the hope that
  11 # it will be useful, but WITHOUT ANY WARRANTY; without even the
  12 # implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
  13 # PURPOSE.  See the GNU General Public License for more details.
  14 #
  15 # You should have received a copy of the GNU General Public License along
  16 # with this program; if not, consult the Free Software Foundation's
  17 # website at www.fsf.org, or the GNU Project website at www.gnu.org.
  18
  19 use strict;
  20
  21 our $usage = <<'END';
  22 usage:
  23   expire-iso8601 [<options>] <number>x<interval> [<number>x<interval> ...]
  24 options:
  25    -u<unitlen>  <interval> is measured in units of <unitlen> seconds
  26                    (default is 86400, so <interval> is in days)
  27    -s<slop>       allow kept items to be <slop> seconds shorter or
  28                    longer apart than specified; default is 0.1 unit
  29    -n             do not really delete
  30    -r             recursive removal (rm -r)
  31    --rename-only  rename to *.rm, but do not delete
  32    --help
  33 example:
  34    /home/ian/junk/expire-iso8601 14x1 4x7
  35       uses units of 86400s (1 day) with a slop of 8640
  36       it keeps 14 daily items
  37        (that is 14 items, dated no less than 86400-8640 apart)
  38       and 4 weekly items
  39        (that is 4 items, dated no less than 7*86400-8640 apart)
  40       the 14 daily and 7 weekly items may be the same, or not
  41    There is no need to sort the list of <number>x<interval> pairs.
  42 exit status:
  43    0                   ok
  44    4                   rm failed
  45    8                   bad usage
  46   -1                   catastrophic failure
  47 END
  48
  49 use POSIX;
  50 use Carp;
  51 use Data::Dumper;
  52 use Date::Parse;
  53 use DateTime::Format::Strptime;
  54
  55 $|=1;
  56
  57 our @oldfiles;
  58 our @files;
  59 our $enable = 2;
  60 our $recurse = 1;
  61 our $unit = 86400;
  62 our $slop;
  63 our $debug = 0;
  64 our @intervals;
  65
  66 sub badusage ($) {
  67   print STDERR "bad usage: $_[0]\n$usage" or die $!;
  68   exit 8;
  69 }
  70
  71 sub scan () {
  72 #  my $strp = DateTime::Format::Strptime->new();
  73   foreach my $f (<[0-9]*>) {
  74     if ($f  !~ m/^ \d\d\d\d - \d\d - \d\d
  75                  (?: T \d\d \: \d\d (?: \: \d\d )?
  76                    (?: [-+] \d{1,2} \:? \d\d )? )?
  77                  ( \.rm )? $/x) {
  78       print STDERR "ignoring $f\n";
  79     }
  80
  81     if ($1) {
  82       push @oldfiles, $f;
  83       next;
  84     }
  85
  86     my @t = Date::Parse::strptime($f);
  87     @t = map { $_ // 0 } @t;
  88     my $t = mktime @t;
  89 #    m
  90 #    my $t = $strp->parse_datetime($f);
  91 #    $t = $t->epoch();
  92 #    my @t = Date::Parse::strptime($f);
  93 #print STDERR Dumper(\@t);
  94 #    my $t = mktime(@t);
  95 #    $!=0; $?=0; my $t = `date -d '$&' +%s`;
  96 #    die "date(!) failed on $&: $? $!" if $! || $?;
  97 #    chomp $t or confess;
  98     push @files, { F => $f, T => $t, U => [] };
  99   }
 100 }
 101
 102 sub precomp () {
 103   if (!@files) {
 104     print STDERR "none at all yet!\n";
 105     exit 0;
 106   }
 107
 108   # newest first, which means biggest T
 109   @files = sort { $b->{T} <=> $a->{T} || $b->{F} cmp $a->{F} } @files;
 110   my $newest_t = $files[0]{T};
 111   $_->{A} = ($newest_t - $_->{T}) / $unit foreach @files;
 112   $slop /= $unit;
 113
 114   push @{$files[0]{U}}, "newest";
 115
 116   print DEBUG Dumper(scalar(@files), \@files, \@intervals) if $debug >= 2;
 117 }
 118
 119 sub flag ($) {
 120   my ($int) = @_;
 121   my $n = $int->{N};
 122   my $d = $int->{D};
 123   my $dmin = $d - $slop;
 124   my $dmax = $d + $slop;
 125   my $spec = $int->{Spec};
 126   my $start_age = ($n-1) * $d - $slop;
 127   my $i = 0;
 128   my $insufficiently_old = 0;
 129
 130   print DEBUG "FLAG $spec sa=$start_age dmin=$dmin dmax=$dmax\n";
 131
 132   # find $i, the youngest which is at least $start_age
 133   for (;;) {
 134     print DEBUG "i #$i $files[$i]{A}\n";
 135     last if $files[$i]{A} >= $start_age;
 136     if ($i == $#files) {
 137       $insufficiently_old = 1;
 138       print STDERR "insufficiently old for $spec\n";
 139       last;
 140     }
 141     $i++;
 142   }
 143
 144   my $oldest = $i;
 145   my $count = 0;
 146
 147   my $use = sub {
 148     my ($i, $spec) = @_;
 149     push @{ $files[$i]{U} }, $spec;
 150     $count++;
 151   };
 152
 153   for (;;) {
 154     $use->($i, $spec);
 155
 156     # find $j, the closest to $i, preferably no more than $dmax younger
 157     my $j = $i;
 158     for (;;) {
 159       $j--;
 160       # at each point in this loop $j is the next candidate
 161       last if $j < 0;
 162       my $dt = $files[$i]{A} - $files[$j]{A};
 163       print DEBUG "j #$j $files[$j]{A} dt=$dt\n";
 164       last if $dt > $dmax;
 165     }
 166     $j++;
 167     if ($j == $i) {
 168       $j--;
 169       last if $j < 0;
 170       print STDERR "insufficiently dense for $spec before $files[$j]{F}\n";
 171     }
 172     print DEBUG "i #$j\n";
 173
 174     $i = $j;
 175   }
 176
 177   $i = $oldest;
 178   while ($count < $n) {
 179     for (;;) {
 180       $i++;
 181       if ($i > $#files) {
 182         if (!$insufficiently_old) {
 183           print STDERR
 184             "insufficiently old for $spec (density compensation)\n";
 185         }
 186         return;
 187       }
 188       my $dt = $files[$i]{A} - $files[$oldest]{A};
 189       print DEBUG "o #$i $files[$i]{A} dt=$dt\n";
 190       last if $dt >= $dmin;
 191     }
 192     $use->($i, "$spec+");
 193   }
 194 }
 195
 196 sub do_rm ($) {
 197   my ($fn) = @_;
 198   if ($enable >= 2) {
 199     my $r= system 'rm', ($recurse ? ('-r') : ()), "--", $fn;
 200     die "run rm: $!\n" unless defined($r) && $r >= 0;
 201     exit 4 if $r;
 202   }
 203 }
 204
 205 sub implement () {
 206   foreach (reverse sort @oldfiles) {
 207     printf "remove %s - old\n", $_;
 208     do_rm($_);
 209   }
 210   foreach (reverse @files) {
 211     next unless @{$_->{U}};
 212     printf "keep %s for %s - age %.1f\n",
 213       $_->{F}, "@{$_->{U}}", $_->{A};
 214   }
 215   foreach (reverse @files) {
 216     next if @{$_->{U}};
 217     printf "remove %s - age %.1f\n",
 218       $_->{F}, $_->{A};
 219     if ($enable >= 1) {
 220       my $tmp = "$_->{F}.rm";
 221       rename $_->{F}, $tmp or die "rename $_->{F} to $tmp: $!\n";
 222       do_rm($tmp);
 223     }
 224   }
 225 }
 226
 227 open DEBUG, ">/dev/null" or die $!;
 228
 229 while (@ARGV && $ARGV[0] =~ m/^-/) {
 230   $_ = shift @ARGV;
 231   last if $_ eq '-' || $_ eq '--';
 232   if (m/^-[^-]/) {
 233     while (m/^-./) {
 234       if (s/^-n/-/) { $enable=0; }
 235       elsif (s/-r/-/) { $recurse=1; }
 236       elsif (s/-D/-/) { $debug++; }
 237       elsif (s/-u(\d+)$//) { $unit=$1; }
 238       elsif (s/-s(\d+)$//) { $slop=$1; }
 239       else { badusage "unknown short option $_" }
 240     }
 241   } elsif (m/^--rename-only$/) {
 242     $enable=1;
 243   } elsif (m/^--help$/) {
 244     print $usage or die $!;
 245     exit 0;
 246   } else {
 247     badusage "unknown long option $_"
 248   }
 249 }
 250
 251 badusage "too few arguments" unless @ARGV;
 252
 253 if ($debug) {
 254   open DEBUG, ">&STDERR" or die $!;
 255   DEBUG->autoflush(1);
 256 }
 257
 258 $slop //= $unit * 0.1;
 259
 260 foreach (@ARGV) {
 261   m/^(\d+)x(\d+)$/ or badusage "bad <number>x<interval> $_";
 262   push @intervals, { Spec => $&, N => $1, D => $2 };
 263 }
 264
 265 scan();
 266 precomp();
 267 foreach (@intervals) { flag $_ }
 268 implement();