merge changes from dla source branch

[debbugs.git] / scripts / expire.in

diff --git a/scripts/expire.in b/scripts/expire.in
index 2fbdcb77067beb74b23e85d3577ba70d9dddd55f..d5149e945021220b5860e3535062ef5e9c78cb3f 100755 (executable)
--- a/scripts/expire.in
+++ b/scripts/expire.in
@@ -9,12 +9,67 @@
 # Copyright 2004 by Collin Watson <cjwatson@debian.org>
 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>
 
+use Getopt::Long;
+use Pod::Usage;
 
+use warnings;
+use strict;
+
+=head1 NAME
+
+expire - Expires archiveable bugs by copying to archive or deleting
+
+=head1 SYNOPSIS
+
+ expire [options]
+
+ Options:
+  --debug, -d debugging level (Default 0)
+  --help, -h display this help
+  --man, -m display manual
+
+=head1 OPTIONS
+
+=over
+
+=item B<--debug, -d>
+
+Debug verbosity. (Default 0)
+
+=item B<--help, -h>
+
+Display brief useage information.
+
+=item B<--man, -m>
+
+Display this manual.
+
+=back
+
+=head1 EXAMPLES
+
+
+=cut
+
+my %options = (debug           => 0,
+              help            => 0,
+              man             => 0,
+              quick           => 0,
+              index_path      => undef,
+              );
+
+GetOptions(\%options,'debug|d+','help|h|?','man|m') or pod2usage(2);
+pod2usage(1) if $options{help};
+pod2usage(-verbose=>2) if $options{man};
+
+
+my $verbose = $options{debug};
 
 use Debbugs::Control qw(bug_archive);
 use Debbugs::Status qw(bug_archiveable);
 
 use Debbugs::Config qw(:config);
+use Debbugs::Common qw(:lock);
 
 # No $gRemoveAge means "never expire".
 exit 0 unless $config{remove_age};
@@ -23,8 +78,9 @@ chdir($config{spool_dir}) || die "chdir $config{spool_dir} failed: $!\n";
 
 #get list of bugs (ie, status files)
 opendir(DIR,"db-h") or die "Unable to open dir db-h: $!";
-@dirs = sort { $a <=> $b } grep(s,^,db-h/,, grep(m/^\d+$/,readdir(DIR)));
+my @dirs = sort { $a cmp $b } grep(s,^,db-h/,, grep(m/^\d+$/,readdir(DIR)));
 close(DIR);
+my @list;
 foreach my $dir (@dirs) {
     opendir(DIR,$dir);
     push @list, sort { $a <=> $b } grep(s/\.summary$//,grep(m/^\d+\.summary$/,readdir(DIR)));
@@ -33,17 +89,41 @@ foreach my $dir (@dirs) {
 
 my $bug;
 my $errors=0;
+our $exit_now = 0;
 #process each bug (ie, status file)
-while (length($bug=shift(@list))) {
+my @bugs_to_archive = ();
+for my $bug (@list) {
      # Weeeee.
+     print "Examining $bug\n" if $verbose;
+     next unless bug_archiveable(bug=>$bug);
+     push @bugs_to_archive,$bug;
+}
+
+$SIG{INT} = sub {$exit_now=1;};
+# At this point we want to block control
+if (not lockpid($config{spool_dir}.'/lock/expire.pid')) {
+     exit 1;
+}
+# We'll also double check that the bug can be archived
+for my $bug (@bugs_to_archive) {
+     last if $exit_now;
+     print "Reexamining $bug\n" if $verbose;
      next unless bug_archiveable(bug=>$bug);
+     last if $exit_now;
+     print "Bug $bug can be archived: " if $verbose;
      eval {
-         bug_archive(bug=>$bug);
+         bug_archive(bug=>$bug,
+                    );
+         print "archived.\n" if $verbose;
      };
      if ($@) {
          $errors=1;
+         print "failed.\n" if $verbose;
          print STDERR "Unable to archive bug# $bug which I thought I could archive:\n$@\n";
      }
+     last if $exit_now;
 }
+unlink($config{spool_dir}.'/lock/expire.pid');
+
 
 exit $errors;