scripts/expire-iso8601.new

   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 apart than
  28                    specified; default is 10% of <unitlen>
  29    -n           do not really delete
  30    -r           recursive removal (rm -r)
  31 example:
  32    /home/ian/junk/expire-iso8601 14x1 4x7
  33       uses units of 86400s (1 day) with a slop of 8640
  34       it keeps 14 daily items
  35        (that is 14 items, dated no less than 86400-8640 apart)
  36       and 4 weekly items
  37        (that is 4 items, dated no less than 7*86400-8640 apart)
  38       the 14 daily and 7 weekly items may be the same, or not
  39    There is no need to sort the list of <number>x<interval> pairs.
  40 exit status:
  41    0                   ok
  42    4                   rm failed
  43    8                   bad usage
  44    16                  catastrophic failure
  45 END
  46
  47 use Carp;
  48 use DateTime::Format::RFC3339;
  49
  50 our @files;
  51 our $rm = 1;
  52 our $recurse = 1;
  53 our $unit = 86400;
  54 our $slop;
  55 our @intervals;
  56
  57 sub badusage ($) {
  58   print STDERR "bad usage: $_[0]\n$usage" or die $!;
  59   exit 8;
  60 }
  61
  62 sub scan () {
  63   my $parser = DateTime::Format::RFC3339->new;
  64
  65   foreach my $f (<[0-9]*>) {
  66     if ($f  !~ m/^ \d\d\d\d - \d\d - \d\d
  67                  (?: T \d\d \: \d\d (?: \: \d\d )?
  68                    (?: [-+] \d{1,2} \:? \d\d )? )? /x) {
  69       print STDERR "ignoring $f\n";
  70     }
  71     $!=0; $?=0; my $t = `date -d '$&' +%s`;
  72     die "date(!) failed on $&: $? $!" if $! || $?;
  73     chomp $t or confess;
  74     push @files, { F => $f, T => $t, U => [] };
  75   }
  76 }
  77
  78 sub precomp () {
  79   if (!@files) {
  80     print STDERR "none at all yet!\n";
  81     exit 0;
  82   }
  83
  84   # newest first, which means biggest T
  85   @files = sort { $b->{T} <=> $a->{T} || $b->{F} cmp $a->{F} } @files;
  86   my $newest_t = $files[0]{T};
  87   $_->{A} = ($newest_t - $_->{T}) / $unit foreach @files;
  88   $slop /= $unit;
  89 }
  90
  91 sub flag ($) {
  92   my ($int) = @_;
  93   my $n = $int->{Number};
  94   my $d = $int->{Interval};
  95   my $spec = $int->{Spec};
  96   my $start_age = ($n+1) * $d;
  97   my $i = 0;
  98
  99   # find $i, the youngest which is at least $number x $interval
 100   for (;;) {
 101     last if $files[$i]{A} > $start_age;
 102     if ($i == $#files) {
 103       print STDERR "insufficient for $spec\n";
 104     }
 105     $i++;
 106   }
 107
 108   for (;;) {
 109     push @{ $files[$i]{U} }, $spec;
 110
 111     # find $j, the closest to $i which is at least $d-slop younger
 112     my $j = $i;
 113     for (;;) {
 114       $j--;
 115       last if $j < 0;
 116       last if $files[$j];
 117       my $dt = $files[$i]{A} - $files[$j]{A};
 118       last if $dt >= $d - $slop;
 119     }
 120     last if $j < 0;
 121
 122     $i = $j;
 123   }
 124 }
 125
 126 sub implement () {
 127   foreach (@files) {
 128     next unless @{$_->{U}};
 129     print "keep $_->{F} for @{$_->{U}}\n";
 130   }
 131   foreach (@files) {
 132     next if @{$_->{U}};
 133     print "remove $_->{F}\n";
 134     if ($rm) {
 135       my $r= system 'rm', ($recurse ? ('-r') : ()), "--", $_->{F};
 136       die "run rm: $!\n" unless defined($r) && $r >= 0;
 137       exit 12 if $r;
 138     }
 139   }
 140 }
 141
 142 while (@ARGV && $ARGV[0] =~ m/^-/) {
 143   $_ = shift @ARGV;
 144   last if $_ eq '-' || $_ eq '--';
 145   if (m/^-[^-]/) {
 146     while (m/^-./) {
 147       if (s/^-n/-/) { $rm=0; }
 148       elsif (s/-r/-/) { $recurse=1; }
 149       elsif (s/-u(\d+)$//) { $unit=$1; }
 150       elsif (s/-s(\d+)$//) { $slop=$1; }
 151       else { badusage "unknown short option $_" }
 152     }
 153   } elsif (m/^--help$/) {
 154     print $usage or die $!;
 155     exit 0;
 156   } else {
 157     badusage "unknown long option $_"
 158   }
 159 }
 160
 161 badusage "too few arguments" unless @ARGV;
 162
 163 $slop //= $unit * 0.1;
 164
 165 foreach (@ARGV) {
 166   m/^(\d+)x(\d+)$/ or badusage "bad <number>x<interval> $_";
 167   push @intervals, { Spec => $&, N => $1, I => $2 };
 168 }
 169
 170 scan();
 171 precomp();
 172 foreach (@intervals) { flag $_ }
 173 implement();