examples/debian/versions/versions_time_cleanup

   1 #! /usr/bin/perl
   2
   3 # This script's job is to clean up the version file and remove old
   4 # versions when there are multiple versions older than the archive
   5 # date.
   6
   7 use warnings;
   8 use strict;
   9
  10 use Debbugs::Config qw(:config);
  11 use MLDBM qw(DB_File Storable);
  12 use Fcntl;
  13
  14 $MLDBM::DumpMeth=q(portable);
  15
  16 my %db;
  17 tie %db, "MLDBM", "versions_time.idx.new",O_CREAT|O_RDWR, 0664
  18      or die "tie versions_time.idx.new failed: $!";
  19
  20 my $time = time;
  21 for my $package (keys %db) {
  22      my $temp = $db{$package};
  23      for my $dist (keys %{$temp}) {
  24           for my $arch (keys %{$temp->{$dist}}) {
  25                my @versions =  (sort {$temp->{$dist}{$arch}{$a} <=>
  26                                            $temp->{$dist}{$arch}{$a}
  27                                       }
  28                                 keys %{$temp->{$dist}{$arch}});
  29                next unless @versions > 1;
  30                for my $i (0 .. ($#versions-1)) {
  31                     last if $temp->{$dist}{$arch}{$versions[$i+1]} > ($time - $config{remove_age}*60*60*24);
  32                     last if keys %{$temp->{$dist}{$arch}} <= 1;
  33                     delete $temp->{$dist}{$arch}{$versions[$i+1]};
  34                }
  35           }
  36      }
  37      $db{$package} = $temp;
  38 }