3 # Copyright 2006 Ian Jackson <ijackson@chiark.greenend.org.uk>
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.
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.
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.
23 expire-iso8601 [<options>] <number>x<interval> [<number>x<interval> ...]
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
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)
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.
46 -1 catastrophic failure
53 use DateTime::Format::Strptime;
67 print STDERR "bad usage: $_[0]\n$usage" or die $!;
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 )? )?
78 print STDERR "ignoring $f\n";
86 my @t = Date::Parse::strptime($f);
87 @t = map { $_ // 0 } @t;
90 # my $t = $strp->parse_datetime($f);
92 # my @t = Date::Parse::strptime($f);
93 #print STDERR Dumper(\@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 => [] };
104 print STDERR "none at all yet!\n";
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;
114 push @{$files[0]{U}}, "newest";
116 print DEBUG Dumper(scalar(@files), \@files, \@intervals) if $debug >= 2;
123 my $dmin = $d - $slop;
124 my $dmax = $d + $slop;
125 my $spec = $int->{Spec};
126 my $start_age = ($n-1) * $d - $slop;
128 my $insufficiently_old = 0;
130 print DEBUG "FLAG $spec sa=$start_age dmin=$dmin dmax=$dmax\n";
132 # find $i, the youngest which is at least $start_age
134 print DEBUG "i #$i $files[$i]{A}\n";
135 last if $files[$i]{A} >= $start_age;
137 $insufficiently_old = 1;
138 print STDERR "insufficiently old for $spec\n";
149 push @{ $files[$i]{U} }, $spec;
156 # find $j, the closest to $i, preferably no more than $dmax younger
160 # at each point in this loop $j is the next candidate
162 my $dt = $files[$i]{A} - $files[$j]{A};
163 print DEBUG "j #$j $files[$j]{A} dt=$dt\n";
170 print STDERR "insufficiently dense for $spec before $files[$j]{F}\n";
172 print DEBUG "i #$j\n";
178 while ($count < $n) {
182 if (!$insufficiently_old) {
184 "insufficiently old for $spec (density compensation)\n";
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;
192 $use->($i, "$spec+");
199 my $r= system 'rm', ($recurse ? ('-r') : ()), "--", $fn;
200 die "run rm: $!\n" unless defined($r) && $r >= 0;
206 foreach (reverse sort @oldfiles) {
207 printf "remove %s - old\n", $_;
210 foreach (reverse @files) {
211 next unless @{$_->{U}};
212 printf "keep %s for %s - age %.1f\n",
213 $_->{F}, "@{$_->{U}}", $_->{A};
215 foreach (reverse @files) {
217 printf "remove %s - age %.1f\n",
220 my $tmp = "$_->{F}.rm";
221 rename $_->{F}, $tmp or die "rename $_->{F} to $tmp: $!\n";
227 open DEBUG, ">/dev/null" or die $!;
229 while (@ARGV && $ARGV[0] =~ m/^-/) {
231 last if $_ eq '-' || $_ eq '--';
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 $_" }
241 } elsif (m/^--rename-only$/) {
243 } elsif (m/^--help$/) {
244 print $usage or die $!;
247 badusage "unknown long option $_"
251 badusage "too few arguments" unless @ARGV;
254 open DEBUG, ">&STDERR" or die $!;
258 $slop //= $unit * 0.1;
261 m/^(\d+)x(\d+)$/ or badusage "bad <number>x<interval> $_";
262 push @intervals, { Spec => $&, N => $1, D => $2 };
267 foreach (@intervals) { flag $_ }