]> git.donarmstrong.com Git - debbugs.git/blob - scripts/expire
fix plural of {src,bin}packages? in updatesql
[debbugs.git] / scripts / expire
1 #!/usr/bin/perl
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.
6 #
7 # [Other people may have contributed to this file; their copyrights
8 # should go here too.]
9 # Copyright 2004 by Collin Watson <cjwatson@debian.org>
10 # Copyright 2007 by Don Armstrong <don@donarmstrong.com>
11
12 use Getopt::Long;
13 use Pod::Usage;
14
15 use warnings;
16 use strict;
17
18 =head1 NAME
19
20 expire - Expires archiveable bugs by copying to archive or deleting
21
22 =head1 SYNOPSIS
23
24  expire [options]
25
26  Options:
27   --debug, -d debugging level (Default 0)
28   --help, -h display this help
29   --man, -m display manual
30
31 =head1 OPTIONS
32
33 =over
34
35 =item B<--debug, -d>
36
37 Debug verbosity. (Default 0)
38
39 =item B<--help, -h>
40
41 Display brief useage information.
42
43 =item B<--man, -m>
44
45 Display this manual.
46
47 =back
48
49 =head1 EXAMPLES
50
51
52 =cut
53
54 my %options = (debug           => 0,
55                help            => 0,
56                man             => 0,
57                quick           => 0,
58                index_path      => undef,
59                );
60
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};
64
65
66 my $verbose = $options{debug};
67
68 use Debbugs::Control qw(bug_archive);
69 use Debbugs::Status qw(bug_archiveable);
70
71 use Debbugs::Config qw(:config);
72 use Debbugs::Common qw(:lock);
73
74 # No $gRemoveAge means "never expire".
75 exit 0 unless $config{remove_age};
76
77 chdir($config{spool_dir}) || die "chdir $config{spool_dir} failed: $!\n";
78
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)));
82 close(DIR);
83 my @list;
84 foreach my $dir (@dirs) {
85     opendir(DIR,$dir);
86     push @list, sort { $a <=> $b } grep(s/\.summary$//,grep(m/^\d+\.summary$/,readdir(DIR)));
87     close(DIR);
88 }
89
90 my $bug;
91 my $errors=0;
92 our $exit_now = 0;
93 #process each bug (ie, status file)
94 my @bugs_to_archive = ();
95 for my $bug (@list) {
96      # Weeeee.
97      print "Examining $bug\n" if $verbose;
98      next unless bug_archiveable(bug=>$bug);
99      push @bugs_to_archive,$bug;
100 }
101
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')) {
105      exit 1;
106 }
107 # We'll also double check that the bug can be archived
108 for my $bug (@bugs_to_archive) {
109      last if $exit_now;
110      print "Reexamining $bug\n" if $verbose;
111      next unless bug_archiveable(bug=>$bug);
112      last if $exit_now;
113      print "Bug $bug can be archived: " if $verbose;
114      eval {
115           bug_archive(bug=>$bug,
116                      );
117           print "archived.\n" if $verbose;
118      };
119      if ($@) {
120           $errors=1;
121           print "failed.\n" if $verbose;
122           print STDERR "Unable to archive bug# $bug which I thought I could archive:\n$@\n";
123      }
124      last if $exit_now;
125 }
126 unlink($config{spool_dir}.'/lock/expire.pid');
127
128
129 exit $errors;