expire-8601: wip new version

Signed-off-by: Ian Jackson <ijackson@chiark.greenend.org.uk>

diff --git a/scripts/expire-iso8601.new b/scripts/expire-iso8601.new
new file mode 100755 (executable)
index 0000000..25a4cd7
--- /dev/null
+++ b/scripts/expire-iso8601.new
@@ -0,0 +1,167 @@
+#!/usr/bin/perl -w
+#
+# Copyright 2006 Ian Jackson <ijackson@chiark.greenend.org.uk>
+#
+# This script and its documentation (if any) are free software; you
+# can redistribute it and/or modify them under the terms of the GNU
+# General Public License as published by the Free Software Foundation;
+# either version 3, or (at your option) any later version.
+# 
+# chiark-named-conf and its manpage are distributed in the hope that
+# it will be useful, but WITHOUT ANY WARRANTY; without even the
+# implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+# PURPOSE.  See the GNU General Public License for more details.
+# 
+# You should have received a copy of the GNU General Public License along
+# with this program; if not, consult the Free Software Foundation's
+# website at www.fsf.org, or the GNU Project website at www.gnu.org.
+
+use strict;
+
+our $usage = <<'END';
+usage:
+  expire-iso8601 [<options>] <number>x<interval> [<number>x<interval> ...]
+options:
+   -u<unitlen>  <interval> is measured in units of <unitlen> seconds
+                   (default is 86400, so <interval> is in days)
+   -s<slop>     allow kept items to be <slop> seconds shorter apart than
+                   specified; default is 10% of <unitlen>
+   -n           do not really delete
+   -r           recursive removal (rm -r)
+example:
+   /home/ian/junk/expire-iso8601 14x1 4x7
+      uses units of 86400s (1 day) with a slop of 8640
+      it keeps 14 daily items
+       (that is 14 items, dated no less than 86400-8640 apart)
+      and 4 weekly items
+       (that is 4 items, dated no less than 7*86400-8640 apart)
+      the 14 daily and 7 weekly items may be the same, or not
+   There is no need to sort the list of <number>x<interval> pairs.
+exit status:
+   0                   ok
+   4                   rm failed
+   8                   bad usage
+   16                  catastrophic failure
+END
+
+use Carp;
+use DateTime::Format::ISO8601;
+
+our @files;
+our $rm = 1;
+our $recurse = 1;
+our $unit = 86400;
+our $slop;
+our @intervals;
+
+sub scan () {
+  my $parser = DateTime::Format::ISO8601->new;
+
+  foreach my $f (<[0-9]*>) {
+    if ($f  !~ m/^ \d\d\d\d - \d\d - \d\d 
+                (?: T \d\d \: \d\d (?: \: \d\d )?
+                  (?: [-+] \d{1,2} \:? \d\d )? )? /x) {
+      print STDERR "ignoring $f\n";
+    }
+    my $t = $parser->parse_time($f) // confess;
+    my $t = $t->epoch() // confess;
+    push @files, { F => $f, T => $t, U => [] ];
+  }
+}
+
+sub precomp () {
+  if (!@files) {
+    print STDERR "none at all yet!\n";
+    exit 0;
+  }
+
+  # newest first, which means biggest T
+  @files = sort { $b->{T} <=> $a->{T} || $b->{F} cmp $a->{F} } @files;
+  my $newest_t = $files[0]{T};
+  $_->{A} = ($newest_t - $_->{T}) / $unit foreach @files;
+  $slop /= $unit;
+}
+
+sub flag ($) {
+  my ($int) = @_;
+  my $n = $int->{Number};
+  my $d = $int->{Interval};
+  my $spec = $int->{Spec};
+  my $start_age = $int->{Number+1) * $interval;
+  my $i = 0;
+
+  # find $i, the youngest which is at least $number x $interval
+  for (;;) {
+    last if $files[$i]{A} > $start_age;
+    if ($i == $#files) {
+      print STDERR "insufficient for $spec\n";
+    }
+    $i++;
+  }
+
+  for (;;) {
+    push $files[$i]{U}, $spec;
+
+    # find $j, the closest to $i which is at least $d-slop younger
+    my $j = $i;
+    for (;;) {
+      $j--;
+      last if $j < 0;
+      last if $files[$j];
+      my $dt = $files[$i]{A} - $files[$j]{A};
+      last if $dt >= $d - $slop;
+    }
+    last if $j < 0;
+
+    $i = $j;
+  }
+}
+
+sub implement () {
+  foreach (@files) {
+    next unless @{$_->{U}};
+    print "keep $_->{F} for @{$_->{U}}\n";
+  }
+  foreach (@files) {
+    next if @{$_->{U}};
+    print "remove $_>{F}\n";
+    if ($rm) {
+      my $r= system 'rm', ($recurse ? ('-r') : ()), "--", $_->{F};
+      die "run rm: $!\n" unless defined($r) && $r >= 0;
+      exit 16 if $r;
+    }
+  }
+}
+
+while (@ARGV && $ARGV[0] =~ m/^-/) {
+  $_ = shift @ARGV;
+  last if $_ eq '-' || $_ eq '--';
+  if (m/^-[^-]/) {
+    while (m/^-./) {
+      if (s/^-n/-/) { $rm=0; }
+      elsif (s/-r/-/) { $recurse=1; }
+      elsif (s/-u(\d+)$//) { $unit=$1; }
+      elsif (s/-s(\d+)$//) { $slop=$1; }
+      else { badusage "unknown short option $_" }
+    }
+  } elsif (m/^--help$/) {
+    print $usage or die $!;
+    exit 0;
+  } else {
+    badusage "unknown long option $_"
+  }
+}
+
+badusage "too few arguments" unless @ARGV;
+
+$slop //= $unit * 0.1;
+
+foreach (@ARGV) {
+  m/^(\d+)x(\d+)$/ or badusage "bad <number>x<interval> $_";
+  push @intervals, { Spec => $&, N => $1, I => $2 ];
+}
+
+scan();
+precomp();
+foreach $int (@intervals) { flag $int }
+implement();