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.
7 # [Other people may have contributed to this file; their copyrights
9 # Copyright 2004 by Collin Watson <cjwatson@debian.org>
10 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>
20 expire - Expires archiveable bugs by copying to archive or deleting
27 --debug, -d debugging level (Default 0)
28 --help, -h display this help
29 --man, -m display manual
37 Debug verbosity. (Default 0)
41 Display brief useage information.
54 my %options = (debug => 0,
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};
66 my $verbose = $options{debug};
68 use Debbugs::Control qw(bug_archive);
69 use Debbugs::Status qw(bug_archiveable);
71 use Debbugs::Config qw(:config);
72 use Debbugs::Common qw(:lock);
74 # No $gRemoveAge means "never expire".
75 exit 0 unless $config{remove_age};
77 chdir($config{spool_dir}) || die "chdir $config{spool_dir} failed: $!\n";
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)));
84 foreach my $dir (@dirs) {
86 push @list, sort { $a <=> $b } grep(s/\.summary$//,grep(m/^\d+\.summary$/,readdir(DIR)));
93 #process each bug (ie, status file)
94 my @bugs_to_archive = ();
97 print "Examining $bug\n" if $verbose;
98 next unless bug_archiveable(bug=>$bug);
99 push @bugs_to_archive,$bug;
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')) {
107 # We'll also double check that the bug can be archived
108 for my $bug (@bugs_to_archive) {
110 print "Reexamining $bug\n" if $verbose;
111 next unless bug_archiveable(bug=>$bug);
113 print "Bug $bug can be archived: " if $verbose;
115 bug_archive(bug=>$bug,
117 print "archived.\n" if $verbose;
121 print "failed.\n" if $verbose;
122 print STDERR "Unable to archive bug# $bug which I thought I could archive:\n$@\n";
126 unlink($config{spool_dir}.'/lock/expire.pid');