Merge from vendor branch LIBSTDC++:
[dragonfly.git] / contrib / sendmail / contrib / movemail.pl
1 #!/usr/bin/perl -w
2 #
3 # Move old mail messages between queues by calling re-mqueue.pl.
4 #
5 # movemail.pl [config-script]
6 #
7 # Default config script is /usr/local/etc/movemail.conf.
8 #
9 # Graeme Hewson <graeme.hewson@oracle.com>, June 2000
10 #
11
12 use strict;
13
14 # Load external program as subroutine to avoid
15 # compilation overhead on each call
16
17 sub loadsub {
18     my $fn = shift
19         or die "Filename not specified";
20     my $len = (stat($fn))[7]
21         or die "Can't stat $fn: $!";
22     open PROG, "< $fn"
23         or die "Can't open $fn: $!";
24     my $prog;
25     read PROG, $prog, $len
26         or die "Can't read $fn: $!";
27     close PROG;
28     eval join "",
29         'return sub { my @ARGV = @_; $0 = $fn; no strict;',
30         "$prog",
31         '};';
32 }
33
34 my $progname = $0;
35 my $lastage = -1;
36 my $LOCK_EX = 2;
37 my $LOCK_NB = 4;
38
39 # Load and eval config script
40
41 my $conffile = shift || "/usr/local/etc/movemail.conf";
42 my $len = (stat($conffile))[7]
43     or die "Can't stat $conffile: $!";
44 open CONF, "< $conffile"
45     or die "Can't open $conffile: $!";
46 my $conf;
47 read CONF, $conf, $len
48     or die "Can't read $conffile: $!";
49 close CONF;
50 use vars qw(@queues $subqbase @ages $remqueue $lockfile);
51 eval $conf;
52
53 if ($#queues < 1) {
54     print "$progname: there must be at least two queues\n";
55     exit 1;
56 }
57
58 if ($#ages != ($#queues - 1)) {
59     print "$progname: wrong number of ages (should be one less than number of queues)\n";
60     exit 1;
61 }
62
63 # Get lock or exit quietly.  Useful when running from cron.
64
65 if ($lockfile) {
66     open LOCK, ">>$lockfile"
67         or die "Can't open lock file: $!";
68     unless (flock LOCK, $LOCK_EX|$LOCK_NB) {
69         close LOCK;
70         exit 0;
71     }
72 }
73
74 my $remsub = loadsub($remqueue);
75
76 # Go through directories in reverse order so as to check spool files only once
77
78 for (my $n = $#queues - 1; $n >= 0; $n--) {
79     unless ($ages[$n] =~ /^\d+$/) {
80         print "$progname: invalid number $ages[$n] in ages array\n";
81         exit 1;
82     }
83     unless ($lastage < 0 || $ages[$n] < $lastage) {
84         print "$progname: age $lastage is not > previous value $ages[$n]\n";
85         exit 1;
86     }
87     $lastage = $ages[$n];
88     if ($subqbase) {
89         my $subdir;
90         opendir(DIR, $queues[$n])
91             or die "Can't open $queues[$n]: $!";
92         foreach $subdir ( grep { /^$subqbase/ } readdir DIR) {
93             &$remsub("$queues[$n]/$subdir", "$queues[$n+1]/$subdir",
94                 $ages[$n]);
95         }
96         closedir(DIR);
97     } else {
98         # Not using subdirectories
99         &$remsub($queues[$n], $queues[$n+1], $ages[$n]);
100     }
101 }
102
103 if ($lockfile) {
104     unlink $lockfile;
105     close LOCK;
106 }