pts/bin/dispatch.pl

#!/usr/bin/perl -w

# Copyright 2002 Raphaël Hertzog <hertzog@debian.org>
# Available under the terms of the General Public License version 2
# or (at your option) any later version

use lib '/org/packages.qa.debian.org/perl';
use lib '/home/rhertzog/cvs/pts/perl';

use Mail::Internet;
use Mail::Address;
use DB_File;

use strict;
use vars qw($db $sendmail);

=head1 Script for *@packages.qa.debian.org

=head1 INSTALLATION INSTRUCTIONS

This script needs libmailtools-perl.

=cut

require "common.pl";

# Local configuration variables
my $nb_by_group = 20; # Number of emails sent together (in the same sendmail)
my $debug = 0;

# Get the package name
my $package = lc($ENV{'LOCAL_PART'}); # Exim sets that ...
$package = lc(shift @ARGV) if ($debug && defined($ARGV[0]) && $ARGV[0]); # 
die "Aren't you exim ?" if (! (defined($package) && $package));

# Get the keyword name
my $keyword = '';
if ($package =~ /(\S+)_(\S+)/) {
    $package = $1;
    $keyword = $2;
}

# Get the list of subscribers
open_db_read();
my @emails = $db->get_dup($package);
exit 0 if (! scalar(@emails)); # Don't parse anything if nobody is subscribed

# Parse the mail
my $mail = Mail::Internet->new(\*STDIN) or die "Parse failed !\n";

# Stop if bad X-Loop
my @xloop = grep { m/$package\@packages.qa.debian.org/ } 
                 ($mail->head()->get('X-Loop'));
if (scalar(@xloop)) {
    exit 0;
}

# Find the real keyword
if (! $keyword) {
    $keyword = 'default';
    if (scalar(grep { m/owner\@bugs\.debian\.org/ } 
                    ($mail->head()->get('X-Loop'))
              )
        and $mail->head()->get('X-Debian-PR-Message')
       )
    {
        $keyword = 'bts';
    } elsif (scalar(grep { m/debbugs\@master\.debian\.org/ }
                    ($mail->head()->get('Sender'))
                   )
             and ($mail->head()->get('Subject') =~ /^Processed:/)
            )
    {
        $keyword = 'bts-control';
    } elsif ($mail->head()->get('X-Katie') and
             ($mail->head()->get('Subject') =~ /INSTALLED/) and
             (scalar(grep { /\.dsc\s*$/ } @{$mail->body()}))
            )
    {
        $keyword = 'upload-source';
    } elsif ($mail->head()->get('X-Katie') and
             ($mail->head()->get('Subject') =~ /INSTALLED/)
            )
    {
        $keyword = 'upload-binary';
    } elsif ($mail->head()->get('X-Katie'))
    {
        $keyword = 'katie-other';
    }
}

# Build the real list of interested people
my $wantmail = sub {
    my $address = shift;
    foreach (get_tags($address, $package)) {
        return 1 if ($_ eq $keyword);
    }
    return 0;
};
@emails = grep { &$wantmail($_) } @emails;
exit 0 if (! scalar(@emails));
close_db();

# Modify the mail
$mail->head()->add("X-Loop", "$package\@packages.qa.debian.org");
$mail->head()->add("X-PTS-Package", $package);
$mail->head()->add("X-PTS-Keyword", $keyword);
$mail->head()->add("X-Unsubscribe", 
        "echo 'unsubscribe $package' | mail pts\@qa.debian.org");

# Forward the mail ... by group of $nb_by_group addresses
my @send;
while (defined($_ = shift @emails)) {
    push @send, $_;
    if (scalar(@send) == $nb_by_group) {
        send_mail(@send);
        @send = ();
    }
}
send_mail(@send) if (scalar(@send));

sub send_mail {
    open(MAIL, "| $sendmail -oi @_") || die "Can't fork sendmail: $!\n";
    $mail->print(\*MAIL);
    close MAIL or warn "Problem happened with sendmail: $!\n";
}
1	hertzog	283	#!/usr/bin/perl -w
2
3			# Copyright 2002 Raphaël Hertzog <hertzog@debian.org>
4			# Available under the terms of the General Public License version 2
5			# or (at your option) any later version
6
7			use lib '/org/packages.qa.debian.org/perl';
8	hertzog	295	use lib '/home/rhertzog/cvs/pts/perl';
9	hertzog	283
10			use Mail::Internet;
11			use Mail::Address;
12			use DB_File;
13
14			use strict;
15	hertzog	295	use vars qw($db $sendmail);
16	hertzog	283
17			=head1 Script for *@packages.qa.debian.org
18
19			=head1 INSTALLATION INSTRUCTIONS
20
21			This script needs libmailtools-perl.
22
23			=cut
24
25	hertzog	295	require "common.pl";
26
27			# Local configuration variables
28	hertzog	283	my $nb_by_group = 20; # Number of emails sent together (in the same sendmail)
29			my $debug = 0;
30
31			# Get the package name
32			my $package = lc($ENV{'LOCAL_PART'}); # Exim sets that ...
33			$package = lc(shift @ARGV) if ($debug && defined($ARGV[0]) && $ARGV[0]); #
34			die "Aren't you exim ?" if (! (defined($package) && $package));
35
36	hertzog	295	# Get the keyword name
37			my $keyword = '';
38			if ($package =~ /(\S+)_(\S+)/) {
39			$package = $1;
40			$keyword = $2;
41			}
42
43	hertzog	283	# Get the list of subscribers
44	hertzog	295	open_db_read();
45	hertzog	283	my @emails = $db->get_dup($package);
46			exit 0 if (! scalar(@emails)); # Don't parse anything if nobody is subscribed
47
48			# Parse the mail
49			my $mail = Mail::Internet->new(\*STDIN) or die "Parse failed !\n";
50
51			# Stop if bad X-Loop
52			my @xloop = grep { m/$package\@packages.qa.debian.org/ }
53			($mail->head()->get('X-Loop'));
54			if (scalar(@xloop)) {
55			exit 0;
56			}
57
58	hertzog	295	# Find the real keyword
59			if (! $keyword) {
60			$keyword = 'default';
61			if (scalar(grep { m/owner\@bugs\.debian\.org/ }
62			($mail->head()->get('X-Loop'))
63			)
64			and $mail->head()->get('X-Debian-PR-Message')
65			)
66			{
67			$keyword = 'bts';
68			} elsif (scalar(grep { m/debbugs\@master\.debian\.org/ }
69			($mail->head()->get('Sender'))
70			)
71			and ($mail->head()->get('Subject') =~ /^Processed:/)
72			)
73			{
74			$keyword = 'bts-control';
75			} elsif ($mail->head()->get('X-Katie') and
76			($mail->head()->get('Subject') =~ /INSTALLED/) and
77			(scalar(grep { /\.dsc\s*$/ } @{$mail->body()}))
78			)
79			{
80			$keyword = 'upload-source';
81			} elsif ($mail->head()->get('X-Katie') and
82			($mail->head()->get('Subject') =~ /INSTALLED/)
83			)
84			{
85			$keyword = 'upload-binary';
86			} elsif ($mail->head()->get('X-Katie'))
87			{
88			$keyword = 'katie-other';
89			}
90			}
91
92			# Build the real list of interested people
93			my $wantmail = sub {
94			my $address = shift;
95			foreach (get_tags($address, $package)) {
96			return 1 if ($_ eq $keyword);
97			}
98			return 0;
99			};
100			@emails = grep { &$wantmail($_) } @emails;
101			exit 0 if (! scalar(@emails));
102			close_db();
103
104	hertzog	283	# Modify the mail
105			$mail->head()->add("X-Loop", "$package\@packages.qa.debian.org");
106	hertzog	295	$mail->head()->add("X-PTS-Package", $package);
107			$mail->head()->add("X-PTS-Keyword", $keyword);
108	hertzog	283	$mail->head()->add("X-Unsubscribe",
109			"echo 'unsubscribe $package' \| mail pts\@qa.debian.org");
110
111			# Forward the mail ... by group of $nb_by_group addresses
112			my @send;
113			while (defined($_ = shift @emails)) {
114			push @send, $_;
115			if (scalar(@send) == $nb_by_group) {
116			send_mail(@send);
117			@send = ();
118			}
119			}
120			send_mail(@send) if (scalar(@send));
121
122			sub send_mail {
123			open(MAIL, "\| $sendmail -oi @_") \|\| die "Can't fork sendmail: $!\n";
124			$mail->print(\*MAIL);
125			close MAIL or warn "Problem happened with sendmail: $!\n";
126			}
Name	Value
svn:eol-style	native
svn:executable	*
svn:keywords	Author Date Id Revision