1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
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 Colin 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;
|
