scripts/expire

   1 #!/usr/bin/perl
   2 # This script is part of debbugs, and is released
   3 # under the terms of the GPL version 2, or any later
   4 # version at your option.
   5 # See the file README and COPYING for more information.
   6 #
   7 # [Other people may have contributed to this file; their copyrights
   8 # should go here too.]
   9 # Copyright 2004 by Collin Watson <cjwatson@debian.org>
  10 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>
  11
  12 use Getopt::Long;
  13 use Pod::Usage;
  14
  15 use warnings;
  16 use strict;
  17
  18 =head1 NAME
  19
  20 expire - Expires archiveable bugs by copying to archive or deleting
  21
  22 =head1 SYNOPSIS
  23
  24  expire [options]
  25
  26  Options:
  27   --debug, -d debugging level (Default 0)
  28   --help, -h display this help
  29   --man, -m display manual
  30
  31 =head1 OPTIONS
  32
  33 =over
  34
  35 =item B<--debug, -d>
  36
  37 Debug verbosity. (Default 0)
  38
  39 =item B<--help, -h>
  40
  41 Display brief useage information.
  42
  43 =item B<--man, -m>
  44
  45 Display this manual.
  46
  47 =back
  48
  49 =head1 EXAMPLES
  50
  51
  52 =cut
  53
  54 my %options = (debug           => 0,
  55                help            => 0,
  56                man             => 0,
  57                quick           => 0,
  58                index_path      => undef,
  59                );
  60
  61 GetOptions(\%options,'debug|d+','help|h|?','man|m') or pod2usage(2);
  62 pod2usage(1) if $options{help};
  63 pod2usage(-verbose=>2) if $options{man};
  64
  65
  66 my $verbose = $options{debug};
  67
  68 use Debbugs::Control qw(bug_archive);
  69 use Debbugs::Status qw(bug_archiveable);
  70
  71 use Debbugs::Config qw(:config);
  72 use Debbugs::Common qw(:lock);
  73
  74 # No $gRemoveAge means "never expire".
  75 exit 0 unless $config{remove_age};
  76
  77 chdir($config{spool_dir}) || die "chdir $config{spool_dir} failed: $!\n";
  78
  79 #get list of bugs (ie, status files)
  80 opendir(DIR,"db-h") or die "Unable to open dir db-h: $!";
  81 my @dirs = sort { $a cmp $b } grep(s,^,db-h/,, grep(m/^\d+$/,readdir(DIR)));
  82 close(DIR);
  83 my @list;
  84 foreach my $dir (@dirs) {
  85     opendir(DIR,$dir);
  86     push @list, sort { $a <=> $b } grep(s/\.summary$//,grep(m/^\d+\.summary$/,readdir(DIR)));
  87     close(DIR);
  88 }
  89
  90 my $bug;
  91 my $errors=0;
  92 our $exit_now = 0;
  93 #process each bug (ie, status file)
  94 my @bugs_to_archive = ();
  95 for my $bug (@list) {
  96      # Weeeee.
  97      print "Examining $bug\n" if $verbose;
  98      next unless bug_archiveable(bug=>$bug);
  99      push @bugs_to_archive,$bug;
 100 }
 101
 102 $SIG{INT} = sub {$exit_now=1;};
 103 # At this point we want to block control
 104 if (not lockpid($config{spool_dir}.'/lock/expire.pid')) {
 105      exit 1;
 106 }
 107 # We'll also double check that the bug can be archived
 108 for my $bug (@bugs_to_archive) {
 109      last if $exit_now;
 110      print "Reexamining $bug\n" if $verbose;
 111      next unless bug_archiveable(bug=>$bug);
 112      last if $exit_now;
 113      print "Bug $bug can be archived: " if $verbose;
 114      eval {
 115           bug_archive(bug=>$bug,
 116                      );
 117           print "archived.\n" if $verbose;
 118      };
 119      if ($@) {
 120           $errors=1;
 121           print "failed.\n" if $verbose;
 122           print STDERR "Unable to archive bug# $bug which I thought I could archive:\n$@\n";
 123      }
 124      last if $exit_now;
 125 }
 126 unlink($config{spool_dir}.'/lock/expire.pid');
 127
 128
 129 exit $errors;