ditch using .in naming of scripts

[debbugs.git] / scripts / expire

diff --git a/scripts/expire b/scripts/expire
new file mode 100755 (executable)
index 0000000..d5149e9
--- /dev/null
+++ b/scripts/expire
@@ -0,0 +1,129 @@
+#!/usr/bin/perl
+# This script is part of debbugs, and is released
+# under the terms of the GPL version 2, or any later
+# version at your option.
+# See the file README and COPYING for more information.
+#
+# [Other people may have contributed to this file; their copyrights
+# should go here too.]
+# 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};
+
+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: $!";
+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)));
+    close(DIR);
+}
+
+my $bug;
+my $errors=0;
+our $exit_now = 0;
+#process each bug (ie, status file)
+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,
+                    );
+         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;