/usr/lib/debbugs/expire is in debbugs 2.6.0.
This file is owned by root:root, with mode 0o755.
The actual contents of the file can be viewed below.
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 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;
|