]> git.donarmstrong.com Git - debbugs.git/blob - scripts/expire.in
* Add more debugging information to expire.in that can be turned
[debbugs.git] / scripts / expire.in
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
73 # No $gRemoveAge means "never expire".
74 exit 0 unless $config{remove_age};
75
76 chdir($config{spool_dir}) || die "chdir $config{spool_dir} failed: $!\n";
77
78 #get list of bugs (ie, status files)
79 opendir(DIR,"db-h") or die "Unable to open dir db-h: $!";
80 my @dirs = sort { $a <=> $b } grep(s,^,db-h/,, grep(m/^\d+$/,readdir(DIR)));
81 close(DIR);
82 my @list;
83 foreach my $dir (@dirs) {
84     opendir(DIR,$dir);
85     push @list, sort { $a <=> $b } grep(s/\.summary$//,grep(m/^\d+\.summary$/,readdir(DIR)));
86     close(DIR);
87 }
88
89 my $bug;
90 my $errors=0;
91 our $exit_now = 0;
92 $SIG{INT} = sub {$exit_now=1;};
93 #process each bug (ie, status file)
94 while (length($bug=shift(@list))) {
95      # Weeeee.
96      print "Examining $bug\n" if $verbose;
97      next unless bug_archiveable(bug=>$bug);
98      print "Bug $bug can be archived: " if $verbose;
99      eval {
100           bug_archive(bug=>$bug);
101           print "archived.\n" if $verbose;
102      };
103      if ($@) {
104           $errors=1;
105           print "failed.\n" if $verbose;
106           print STDERR "Unable to archive bug# $bug which I thought I could archive:\n$@\n";
107      }
108      last if $exit_now;
109 }
110
111 exit $errors;