/[qa]/trunk/pts/bin/control.pl
ViewVC logotype

Diff of /trunk/pts/bin/control.pl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 294 by hertzog, Fri Feb 1 07:00:57 2002 UTC revision 295 by hertzog, Tue Feb 12 12:09:58 2002 UTC
# Line 5  Line 5 
5  # or (at your option) any later version  # or (at your option) any later version
6    
7  use lib '/org/packages.qa.debian.org/perl';  use lib '/org/packages.qa.debian.org/perl';
8    use lib '/home/rhertzog/cvs/pts/perl';
9    
10  use ConfirmationSpool;  use ConfirmationSpool;
11  use MIME::Parser;  use MIME::Parser;
# Line 13  use Mail::Address; Line 14  use Mail::Address;
14  use DB_File;  use DB_File;
15    
16  use strict;  use strict;
17    use vars qw($spool_dir $conf_template $sendmail);
18    
19  =head1 Mailbot for pts@qa.debian.org  =head1 Mailbot for pts@qa.debian.org
20    
# Line 33  This script needs libmime-perl and libma Line 35  This script needs libmime-perl and libma
35    
36  =cut  =cut
37    
38  # Configuration variables  require "common.pl";
 my $spool_dir = "/org/packages.qa.debian.org/spool";  
 my $conf_template = "/org/packages.qa.debian.org/etc/conf_tpl.txt";  
 my $db_filename = "/org/packages.qa.debian.org/db/subscription.db";  
 my $sendmail = '/usr/sbin/sendmail -f owner@packages.qa.debian.org';  
 my $sources = "/org/bugs.debian.org/etc/indices/sources";  
   
 # Global variables  
 my %db_content;  
 my $db;  
 my %bin2src;  
 my %src;  
39    
40  # Create a ConfirmationSpool object to handle the email authentication  # Create a ConfirmationSpool object to handle the email authentication
41  my $cs = ConfirmationSpool->new($spool_dir);  my $cs = ConfirmationSpool->new($spool_dir);
# Line 164  foreach my $line (@lines) { Line 155  foreach my $line (@lines) {
155          push @ans, map { $_ . "\n" } (list($package));          push @ans, map { $_ . "\n" } (list($package));
156          push @ans, "\n";          push @ans, "\n";
157    
158        } elsif ($line =~ /^\s*(?:keyword|tag)s?(?:\s+(\S+@\S+))?\s*$/i) {
159    
160            my $address = lc($1);
161            $address = $email if (! (defined($address) && $address));
162            $done{"KEYWORD $address"} = 1;
163            push @ans, "Here's the default list of accepted keywords " .
164                       "for $address :\n";
165            push @ans, map { "* " . $_ . "\n" } (get_default_tags($address));
166            push @ans, "\n";
167    
168        } elsif ($line =~ /^\s*(?:keyword|tag)s?\s+(\S+)(?:\s+(\S+@\S+)?)\s*$/i) {
169    
170            my $package = lc($1);
171            my $address = lc($2);
172            $address = $email if (! (defined($address) && $address));
173            $done{"KEYWORD $package $address"} = 1;
174            push @ans, "Here's the list of accepted keywords associated to " .
175                       "package\n";
176            push @ans, "$package for $address :\n";
177            push @ans, map { "* " . $_ . "\n" } (get_tags($address, $package));
178            push @ans, "\n";
179    
180        } elsif ($line =~ /^\s*(?:keyword|tag)s?(?:\s+(\S+@\S+))?\s+([-+=])\s+(\S+(?:\s+\S+)*)\s*$/i) {
181    
182            my $address = lc($1);
183            $address = $email if (! (defined($address) && $address));
184            my $cmd = $2;
185            my @t = split(/[,\s]+/, lc($3));
186            $done{"KEYWORD $address $cmd @t"} = 1;
187            foreach (@t) {
188                push @ans, "WARNING: $_ is not a valid keyword.\n"
189                                                        if (! is_valid_tag($_));
190            }
191            open_db_write();
192            if ($cmd eq "=") {
193                set_default_tags($address, @t);
194            } elsif ($cmd eq "+") {
195                my @tags = get_default_tags($address);
196                push @tags, @t;
197                set_default_tags($address, @tags);
198            } elsif ($cmd eq "-") {
199                my $check = sub {
200                                    foreach my $t (@t) {
201                                        return 0 if ($_[0] eq $t);
202                                    }
203                                    return 1;
204                                };
205                my @tags = grep { &$check($_) } (get_default_tags($address));
206                set_default_tags($address, @tags);
207            }
208            push @ans, "Here's the new default list of accepted keywords " .
209                       "for $address :\n";
210            push @ans, map { "* " . $_ . "\n" } (get_default_tags($address));
211            push @ans, "\n";
212            close_db();
213            push @cc, $address if ($address ne $email);
214    
215    
216        } elsif ($line =~ /^\s*(?:keyword|tag)s?\s+(\S+)(?:\s+(\S+@\S+))?\s+([-+=])\s+(\S+(?:\s+\S+)*)\s*$/i) {
217    
218            my $package = lc($1);
219            my $address = lc($2);
220            $address = $email if (! (defined($address) && $address));
221            my $cmd = $3;
222            my @t = split(/[,\s]+/, lc($4));
223            $done{"KEYWORD $package $address $cmd @t"} = 1;
224            foreach (@t) {
225                push @ans, "$_ is not a valid keyword.\n" if (! is_valid_tag($_));
226            }
227            open_db_write();
228            if ($cmd eq "=") {
229                set_tags($address, $package, @t);
230            } elsif ($cmd eq "+") {
231                my @tags = get_tags($address, $package);
232                push @tags, @t;
233                set_tags($address, $package, @tags);
234            } elsif ($cmd eq "-") {
235                my $check = sub {
236                                    foreach my $t (@t) {
237                                        return 0 if ($_[0] eq $t);
238                                    }
239                                    return 1;
240                                };
241                my @tags = grep { &$check($_) } (get_tags($address, $package));
242                set_tags($address, $package, @tags);
243            }
244            push @ans, "Here's the new list of accepted keywords associated to " .
245                       "package\n";
246            push @ans, "$package for $address :\n";
247            push @ans, map { "* " . $_ . "\n" } (get_tags($address, $package));
248            push @ans, "\n";
249            close_db();
250            push @cc, $address if ($address ne $email);
251    
252      } elsif ($line =~ /^\s*help/i) {      } elsif ($line =~ /^\s*help/i) {
253          push @ans, <DATA>;          push @ans, <DATA>;
254          $done{"HELP"} = 1;          $done{"HELP"} = 1;
# Line 207  open(MAIL, "| $sendmail -oi -t") || die Line 292  open(MAIL, "| $sendmail -oi -t") || die
292  $answer->print(\*MAIL);  $answer->print(\*MAIL);
293  close MAIL or die "Problem happened with sendmail: $!\n";  close MAIL or die "Problem happened with sendmail: $!\n";
294    
 sub open_db {  
     $DB_BTREE->{'flags'} = R_DUP;  
     $db = tie %db_content, "DB_File", $db_filename, O_RDWR|O_CREAT,  
                   0660, $DB_BTREE  
         or die "Can't open database $db_filename : $!\n";  
 }  
 sub close_db {  
     undef $db;  
     untie %db_content;  
 }  
 sub subscribe {  
     my ($address, $package) = @_;  
     open_db();  
     my @emails = $db->get_dup($package);  
     my $found = 0;  
     foreach (@emails) {  
         $found = 1 if ($_ eq $address);  
     }  
     $db_content{$package} = $address if (! $found);  
     close_db();  
     return ! $found;  
 }  
 sub unsubscribe {  
     my ($address, $package) = @_;  
     my $ok = 1;  
     open_db();  
     if ($db->find_dup($package, $address) == 0) {  
         $db->del_dup($package, $address);  
     } else {  
         $ok = 0;  
     }  
     close_db();  
     return $ok;  
 }  
 sub which {  
     my ($address) = @_;  
     my @l;  
     open_db();  
     foreach my $p (keys %db_content) {  
         if ($db->find_dup($p, $address) == 0) {  
             push @l, $p;  
         }  
     }  
     close_db();  
     return @l;  
 }  
 sub list {  
     my ($package) = @_;  
     open_db();  
     my @l = $db->get_dup($package);  
     close_db();  
     return @l;  
 }  
 sub load_sources {  
     return if (scalar(keys %bin2src));  
     open(SOURCES, "< $sources") || warn "Can't open $sources: $!\n";  
     while(defined($_=<SOURCES>)) {  
         my ($bin, $src) = (split(/\s+/));  
         $bin2src{lc($bin)} = lc($src);  
         $src{lc($src)} = 1;  
     }  
     close(SOURCES);  
 }  
 sub map_package {  
     my ($pkg) = @_;  
     my ($package, @msg);  
     load_sources();  
     if (exists $src{$pkg}) {  
         $package = $pkg;  
     } elsif (exists $bin2src{$pkg}) {  
         $package = $bin2src{$pkg};  
         push @msg, "$pkg is not a source package. However $package is \n";  
         push @msg, "the source package for the $pkg binary package.\n";  
         push @msg, "\n";  
     } else {  
         $package = $pkg;  
         push @msg, "$pkg is neither a source package nor a binary package. \n";  
         push @msg, "It may be a 'virtual package' or a mistake...\n";  
         push @msg, "\n";  
     }  
     return ($package, @msg);  
 }  
295    
296  __DATA__  __DATA__
297    
# Line 298  Debian Package Tracking System Line 301  Debian Package Tracking System
301  The Package Tracking System (PTS) has the following commands:  The Package Tracking System (PTS) has the following commands:
302    
303  subscribe <srcpackage> [<email>]  subscribe <srcpackage> [<email>]
304    Subscribes <email> to all messages regarding <srcpackage>.  If    Subscribes <email> to all messages regarding <srcpackage>. If
305    <email> is not given, it subscribes the From address.  If the    <email> is not given, it subscribes the From address. If the
306    <srcpackage> is not a valid source package, you'll get a warning.    <srcpackage> is not a valid source package, you'll get a warning.
307    If it's a valid binary package, the mapping will automatically be    If it's a valid binary package, the mapping will automatically be
308    done for you.    done for you.
309    
310  unsubscribe <srcpackage> [<email>]  unsubscribe <srcpackage> [<email>]
311    Unsubscribes <email> from <srcpackage>.  Like the subscribe command,    Unsubscribes <email> from <srcpackage>. Like the subscribe command,
312    it will use the From address if <email> is not given.    it will use the From address if <email> is not given.
313    
314  which [<email>]  which [<email>]
315    Tells you which packages <email> is subscribed to.    Tells you which packages <email> is subscribed to.
316    
317    keyword [<email>]
318      Tells you the keywords that you are accepting. Each mail sent through
319      the Package Tracking System is associated to a keyword and you receive
320      only the mails associated to keywords that you are accepting. Here is
321      the list of available keywords :
322      * bts : mails coming from the Debian Bug Tracking System
323      * bts-control : mails sent to control@bugs.debian.org
324      * buildd : failed build logs generated by build daemons
325      * summary : automatic summary mails about the state of a package
326      * upload-source : announce of a new source upload that has been installed
327      * upload-binary : announce of a new binary-only upload (porting)
328      * katie-other : other mails from ftpmasters (override disparity, etc.)
329    
330    keyword <srcpackage> [<email>]
331      Same as previous item but for the given source package since
332      you may select a different set of keywords for each source package.
333    
334    keyword [<email>] {+|-|=} <list of keywords>
335      Accept (+) or refuse (-) mails associated to the given keyword(s).
336      Define the list (=) of accepted keywords.
337    
338    keyword <srcpackage> [<email>] {+|-|=} <list of keywords>
339      Same as previous item but overrides the keywords list for the indicated
340      source package.
341    
342  quit  quit
343  thanks  thanks
344    Stops processing commands.    Stops processing commands.
Legend:
Removed from v.294  
changed lines
  Added in v.295
  ViewVC Help
Powered by ViewVC 1.1.5