2 # $Id: service.in,v 1.117 2005/10/09 14:17:41 ajt Exp $
4 # Usage: service <code>.nn
5 # Temps: incoming/P<code>.nn
9 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
10 use Debbugs::Mail qw(send_mail_message);
13 $config_path = '/etc/debbugs';
14 $lib_path = '/usr/lib/debbugs';
16 require "$config_path/config";
17 require "$lib_path/errorlib";
18 $ENV{'PATH'} = $lib_path.':'.$ENV{'PATH'};
20 chdir("$gSpoolDir") || die "chdir spool: $!\n";
23 open DEBUG, ">/dev/null";
28 m/^[RC]\.\d+$/ || &quit("bad argument");
31 if (!rename("incoming/G$nn","incoming/P$nn")) {
32 $_=$!.''; m/no such file or directory/i && exit 0;
33 &quit("renaming to lock: $!");
36 open(M,"incoming/P$nn");
43 print "###\n",join("##\n",@msg),"\n###\n" if $debug;
45 my $parser = new MIME::Parser;
46 mkdir "$gSpoolDir/mime.tmp", 0777;
47 $parser->output_under("$gSpoolDir/mime.tmp");
48 my $entity = eval { $parser->parse_data(join('',@log)) };
50 # header and decoded body respectively
51 my (@headerlines, @bodylines);
52 # Bug numbers to send e-mail to, hash so that we don't send to the
56 if ($entity and $entity->head->tags) {
57 @headerlines = @{$entity->head->header};
60 my $entity_body = getmailbody($entity);
61 @bodylines = $entity_body ? $entity_body->as_lines() : ();
64 # Legacy pre-MIME code, kept around in case MIME::Parser fails.
66 for ($i = 0; $i <= $#msg; $i++) {
68 last unless length($_);
69 while ($msg[$i+1] =~ m/^\s/) {
73 push @headerlines, $_;
76 @bodylines = @msg[$i..$#msg];
80 $_ = decode_rfc1522($_);
82 print ">$_<\n" if $debug;
85 print ">$v=$_<\n" if $debug;
88 print "!>$_<\n" if $debug;
92 # Strip off RFC2440-style PGP clearsigning.
93 if (@bodylines and $bodylines[0] =~ /^-----BEGIN PGP SIGNED/) {
94 shift @bodylines while @bodylines and length $bodylines[0];
95 shift @bodylines while @bodylines and $bodylines[0] !~ /\S/;
96 for my $findsig (0 .. $#bodylines) {
97 if ($bodylines[$findsig] =~ /^-----BEGIN PGP SIGNATURE/) {
98 $#bodylines = $findsig - 1;
102 map { s/^- // } @bodylines;
105 grep(s/\s+$//,@bodylines);
107 print "***\n",join("\n",@bodylines),"\n***\n" if $debug;
109 if (defined $header{'resent-from'} && !defined $header{'from'}) {
110 $header{'from'} = $header{'resent-from'};
113 defined($header{'from'}) || &quit("no From header");
115 delete $header{'reply-to'}
116 if ( defined($header{'reply-to'}) && $header{'reply-to'} =~ m/^\s*$/ );
118 if ( defined($header{'reply-to'}) && $header{'reply-to'} ne "" ) {
119 $replyto = $header{'reply-to'};
121 $replyto = $header{'from'};
124 $controlrequestaddr= $control ? "control\@$gEmailDomain" : "request\@$gEmailDomain";
126 &transcript("Processing commands for $controlrequestaddr:\n\n");
131 $mergelowstate= 'idle';
137 $user =~ s/^.*<(.*)>.*$/$1/;
138 $user =~ s/[(].*[)]//;
139 $user =~ s/^\s*(\S+)\s+.*$/$1/;
140 $user = "" unless (Debbugs::User::is_valid_user($user));
144 my $fuckheads = "(" . join("|", @gFuckheads) . ")";
145 if (@gFuckheads and $replyto =~ m/$fuckheads/) {
146 &transcript("This service is unavailable.\n\n");
155 push @bcc, $_[0] unless grep { $_ eq $_[0] } @bcc;
158 for ($procline=0; $procline<=$#bodylines; $procline++) {
159 $state eq 'idle' || print "$state ?\n";
160 $lowstate eq 'idle' || print "$lowstate ?\n";
161 $mergelowstate eq 'idle' || print "$mergelowstate ?\n";
163 &transcript("Stopping processing here.\n\n");
166 $_= $bodylines[$procline]; s/\s+$//;
168 &transcript("> $_\n");
171 if (m/^stop/i || m/^quit/i || m/^--/ || m/^thank/i || m/^kthxbye/i) {
172 &transcript("Stopping processing here.\n\n");
174 } elsif (m/^debug\s+(\d+)$/i && $1 >= 0 && $1 <= 1000) {
176 &transcript("Debug level $dl.\n\n");
177 } elsif (m/^(send|get)\s+\#?(\d{2,})$/i) {
179 &sendlynxdoc("bugreport.cgi?bug=$ref","logs for $gBug#$ref");
180 } elsif (m/^send-detail\s+\#?(\d{2,})$/i) {
182 &sendlynxdoc("bugreport.cgi?bug=$ref&boring=yes",
183 "detailed logs for $gBug#$ref");
184 } elsif (m/^index(\s+full)?$/i) {
185 &transcript("This BTS function is currently disabled, sorry.\n\n");
186 $ok++; # well, it's not really ok, but it fixes #81224 :)
187 } elsif (m/^index-summary\s+by-package$/i) {
188 &transcript("This BTS function is currently disabled, sorry.\n\n");
189 $ok++; # well, it's not really ok, but it fixes #81224 :)
190 } elsif (m/^index-summary(\s+by-number)?$/i) {
191 &transcript("This BTS function is currently disabled, sorry.\n\n");
192 $ok++; # well, it's not really ok, but it fixes #81224 :)
193 } elsif (m/^index(\s+|-)pack(age)?s?$/i) {
194 &sendlynxdoc("pkgindex.cgi?indexon=pkg",'index of packages');
195 } elsif (m/^index(\s+|-)maints?$/i) {
196 &sendlynxdoc("pkgindex.cgi?indexon=maint",'index of maintainers');
197 } elsif (m/^index(\s+|-)maint\s+(\S+)$/i) {
199 &sendlynxdoc("pkgreport.cgi?maint=" . urlsanit($maint),
200 "$gBug list for maintainer \`$maint'");
202 } elsif (m/^index(\s+|-)pack(age)?s?\s+(\S.*\S)$/i) {
204 &sendlynxdoc("pkgreport.cgi?pkg=" . urlsanit($package),
205 "$gBug list for package $package");
207 } elsif (m/^send-unmatched(\s+this|\s+-?0)?$/i) {
208 &transcript("This BTS function is currently disabled, sorry.\n\n");
209 $ok++; # well, it's not really ok, but it fixes #81224 :)
210 } elsif (m/^send-unmatched\s+(last|-1)$/i) {
211 &transcript("This BTS function is currently disabled, sorry.\n\n");
212 $ok++; # well, it's not really ok, but it fixes #81224 :)
213 } elsif (m/^send-unmatched\s+(old|-2)$/i) {
214 &transcript("This BTS function is currently disabled, sorry.\n\n");
215 $ok++; # well, it's not really ok, but it fixes #81224 :)
216 } elsif (m/^getinfo\s+([\w-.]+)$/i) {
217 # the following is basically a Debian-specific kludge, but who cares
219 if ($req =~ /^maintainers$/i && -f "$gConfigDir/Maintainers") {
220 &sendinfo("local", "$gConfigDir/Maintainers", "Maintainers file");
221 } elsif ($req =~ /^override\.(\w+)\.([\w-.]+)$/i) {
223 &sendinfo("ftp.d.o", "$req", "override file for $2 part of $1 distribution");
224 } elsif ($req =~ /^pseudo-packages\.(description|maintainers)$/i && -f "$gConfigDir/$req") {
225 &sendinfo("local", "$gConfigDir/$req", "$req file");
227 &transcript("Info file $req does not exist.\n\n");
229 } elsif (m/^help/i) {
233 } elsif (m/^refcard/i) {
234 &sendtxthelp("bug-mailserver-refcard.txt","mail servers' reference card");
235 } elsif (m/^subscribe/i) {
237 There is no $gProject $gBug mailing list. If you wish to review bug reports
238 please do so via http://$gWebDomain/ or ask this mail server
240 soon: MAILINGLISTS_TEXT
242 } elsif (m/^unsubscribe/i) {
244 soon: UNSUBSCRIBE_TEXT
245 soon: MAILINGLISTS_TEXT
247 } elsif (m/^user\s+(\S+)\s*$/i) {
249 if (Debbugs::User::is_valid_user($newuser)) {
250 my $olduser = ($user ne "" ? " (was $user)" : "");
251 &transcript("Setting user to $newuser$olduser.\n");
254 &transcript("Selected user id ($newuser) invalid, sorry\n");
257 } elsif (m/^usercategory\s+(\S+)(\s+\[hidden\])?\s*$/i) {
260 my $hidden = ($2 ne "");
266 while (++$procline <= $#bodylines) {
267 unless ($bodylines[$procline] =~ m/^\s*([*+])\s*(\S.*)$/) {
271 &transcript("> $bodylines[$procline]\n");
273 my ($o, $txt) = ($1, $2);
274 if ($#cats == -1 && $o eq "+") {
275 &transcript("User defined category specification must start with a category name. Skipping.\n\n");
280 unless (ref($cats[-1]) eq "HASH") {
281 $cats[-1] = { "nam" => $cats[-1],
282 "pri" => [], "ttl" => [] };
285 my ($desc, $ord, $op);
286 if ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?\]\s*$/) {
287 $desc = $1; $ord = $3; $op = "";
288 } elsif ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?(\S+)\]\s*$/) {
289 $desc = $1; $ord = $3; $op = $4;
290 } elsif ($txt =~ m/^([^[\s]+)\s*$/) {
291 $desc = ""; $op = $1;
293 &transcript("Unrecognised syntax for category section. Skipping.\n\n");
297 $ord = 999 unless defined $ord;
300 push @{$cats[-1]->{"pri"}}, $prefix . $op;
301 push @{$cats[-1]->{"ttl"}}, $desc;
302 push @ords, "$ord $catsec";
304 @cats[-1]->{"def"} = $desc;
305 push @ords, "$ord DEF";
308 @ords = sort { my ($a1, $a2, $b1, $b2) = split / /, "$a $b";
309 $a1 <=> $b1 || $a2 <=> $b2; } @ords;
310 $cats[-1]->{"ord"} = [map { m/^.* (\S+)/; $1 eq "DEF" ? $catsec + 1 : $1 } @ords];
311 } elsif ($o eq "*") {
314 if ($txt =~ m/^(.*\S)(\s*\[(\S+)\])\s*$/) {
315 $name = $1; $prefix = $3;
317 $name = $txt; $prefix = "";
322 # XXX: got @cats, now do something with it
323 my $u = Debbugs::User::get_user($user);
325 &transcript("Added usercategory $catname.\n\n");
326 $u->{"categories"}->{$catname} = [ @cats ];
328 &transcript("Removed usercategory $catname.\n\n");
329 delete $u->{"categories"}->{$catname};
332 } elsif (m/^usertags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
334 $ref = $1; $addsubcode = $3 || "+"; $tags = $4;
336 &transcript("No valid user selected\n");
339 Debbugs::User::read_usertags(\%ut, $user);
340 my @oldtags = (); my @newtags = (); my @badtags = ();
342 for my $t (split /[,\s]+/, $tags) {
343 if ($t =~ m/^[a-zA-Z0-9.+\@-]+$/) {
350 &transcript("Ignoring illegal tag/s: ".join(', ', @badtags).".\nPlease use only alphanumerics, at, dot, plus and dash.\n");
352 for my $t (keys %chtags) {
353 $ut{$t} = [] unless defined $ut{$t};
355 for my $t (keys %ut) {
356 my %res = map { ($_, 1) } @{$ut{$t}};
357 push @oldtags, $t if defined $res{$ref};
358 my $addop = ($addsubcode eq "+" or $addsubcode eq "=");
359 my $del = (defined $chtags{$t} ? $addsubcode eq "-"
360 : $addsubcode eq "=");
361 $res{$ref} = 1 if ($addop && defined $chtags{$t});
362 delete $res{$ref} if ($del);
363 push @newtags, $t if defined $res{$ref};
364 $ut{$t} = [ sort { $a <=> $b } (keys %res) ];
367 &transcript("There were no usertags set.\n");
369 &transcript("Usertags were: " . join(" ", @oldtags) . ".\n");
371 &transcript("Usertags are now: " . join(" ", @newtags) . ".\n");
372 Debbugs::User::write_usertags(\%ut, $user);
374 } elsif (!$control) {
376 Unknown command or malformed arguments to command.
377 (Use control\@$gEmailDomain to manipulate reports.)
380 if (++$unknowns >= 3) {
381 &transcript("Too many unknown commands, stopping here.\n\n");
384 #### "developer only" ones start here
385 } elsif (m/^close\s+\#?(-?\d+)(?:\s+(\d.*))?$/i) {
388 $bug_affected{$ref}=1;
391 &transcript("'close' is deprecated; see http://$gWebDomain/Developer$gHTMLSuffix#closing.\n");
392 if (length($data->{done}) and not defined($version)) {
393 &transcript("$gBug is already closed, cannot re-close.\n\n");
398 "marked as fixed in version $version" :
400 ", send any further explanations to $data->{originator}";
402 &addmaintainers($data);
403 if ( length( $gDoneList ) > 0 && length( $gListDomain ) >
404 0 ) { &addccaddress("$gDoneList\@$gListDomain"); }
405 $data->{done}= $replyto;
406 my @keywords= split ' ', $data->{keywords};
407 if (grep $_ eq 'pending', @keywords) {
408 $extramessage= "Removed pending tag.\n";
409 $data->{keywords}= join ' ', grep $_ ne 'pending',
412 addfixedversions($data, $data->{package}, $version, 'binary');
415 From: $gMaintainerEmail ($gProject $gBug Tracking System)
416 To: $data->{originator}
417 Subject: $gBug#$ref acknowledged by developer
419 References: $header{'message-id'} $data->{msgid}
420 In-Reply-To: $data->{msgid}
421 Message-ID: <handler.$ref.$nn.notifdonectrl.$midix\@$gEmailDomain>
422 Reply-To: $ref\@$gEmailDomain
423 X-$gProject-PR-Message: they-closed-control $ref
425 This is an automatic notification regarding your $gBug report
426 #$ref: $data->{subject},
427 which was filed against the $data->{package} package.
429 It has been marked as closed by one of the developers, namely
432 You should be hearing from them with a substantive response shortly,
433 in case you haven't already. If not, please contact them directly.
436 (administrator, $gProject $gBugs database)
439 &sendmailmessage($message,$data->{originator});
440 } while (&getnextbug);
443 } elsif (m/^reassign\s+\#?(-?\d+)\s+(\S+)(?:\s+(\d.*))?$/i) {
445 $ref= $1; $newpackage= $2;
446 $bug_affected{$ref}=1;
448 $newpackage =~ y/A-Z/a-z/;
450 if (length($data->{package})) {
451 $action= "$gBug reassigned from package \`$data->{package}'".
452 " to \`$newpackage'.";
454 $action= "$gBug assigned to package \`$newpackage'.";
457 &addmaintainers($data);
458 $data->{package}= $newpackage;
459 $data->{found_versions}= [];
460 $data->{fixed_versions}= [];
461 # TODO: what if $newpackage is a source package?
462 addfoundversions($data, $data->{package}, $version, 'binary');
463 &addmaintainers($data);
464 } while (&getnextbug);
466 } elsif (m/^reopen\s+\#?(-?\d+)$/i ? ($noriginator='', 1) :
467 m/^reopen\s+\#?(-?\d+)\s+\=$/i ? ($noriginator='', 1) :
468 m/^reopen\s+\#?(-?\d+)\s+\!$/i ? ($noriginator=$replyto, 1) :
469 m/^reopen\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($noriginator=$2, 1) : 0) {
472 $bug_affected{$ref}=1;
474 if (@{$data->{fixed_versions}}) {
475 &transcript("'reopen' is deprecated when a bug has been closed with a version;\nuse 'found' or 'submitter' as appropriate instead.\n");
477 if (!length($data->{done})) {
478 &transcript("$gBug is already open, cannot reopen.\n\n");
482 $noriginator eq '' ? "$gBug reopened, originator not changed." :
483 "$gBug reopened, originator set to $noriginator.";
485 &addmaintainers($data);
486 $data->{originator}= $noriginator eq '' ? $data->{originator} : $noriginator;
487 $data->{fixed_versions}= [];
489 } while (&getnextbug);
492 } elsif (m/^found\s+\#?(-?\d+)(?:\s+(\d.*))?$/i) {
497 if (!length($data->{done}) and not defined($version)) {
498 &transcript("$gBug is already open, cannot reopen.\n\n");
503 "$gBug marked as found in version $version." :
506 &addmaintainers($data);
507 # The 'done' field gets a bit weird with version
508 # tracking, because a bug may be closed by multiple
509 # people in different branches. Until we have something
510 # more flexible, we set it every time a bug is fixed,
511 # and clear it precisely when a found command is
512 # received for the rightmost fixed-in version, which
513 # equates to the most recent fixing of the bug, or when
514 # a versionless found command is received.
515 if (defined $version) {
517 (reverse @{$data->{fixed_versions}})[0];
518 # TODO: what if $data->{package} is a source package?
519 addfoundversions($data, $data->{package}, $version, 'binary');
520 if (defined $lastfixed and not grep { $_ eq $lastfixed } @{$data->{fixed_versions}}) {
524 # Versionless found; assume old-style "not fixed at
526 $data->{fixed_versions} = [];
529 } while (&getnextbug);
532 } elsif (m/^notfound\s+\#?(-?\d+)\s+(\d.*)$/i) {
537 $action= "$gBug marked as not found in version $version.";
538 if (length($data->{done})) {
539 $extramessage= "(By the way, this $gBug is currently marked as done.)\n";
542 &addmaintainers($data);
543 removefoundversions($data, $data->{package}, $version, 'binary');
544 } while (&getnextbug);
546 } elsif (m/^submitter\s+\#?(-?\d+)\s+\!$/i ? ($newsubmitter=$replyto, 1) :
547 m/^submitter\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($newsubmitter=$2, 1) : 0) {
550 $bug_affected{$ref}=1;
551 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
552 $ref = $clonebugs{$ref};
555 if (&checkpkglimit) {
557 &addmaintainers($data);
558 $oldsubmitter= $data->{originator};
559 $data->{originator}= $newsubmitter;
560 $action= "Changed $gBug submitter from $oldsubmitter to $newsubmitter.";
562 &transcript("$action\n");
563 if (length($data->{done})) {
564 &transcript("(By the way, that $gBug is currently marked as done.)\n");
568 From: $gMaintainerEmail ($gProject $gBug Tracking System)
570 Subject: $gBug#$ref submitter address changed
572 References: $header{'message-id'} $data->{msgid}
573 In-Reply-To: $data->{msgid}
574 Message-ID: <handler.$ref.$nn.newsubmitter.$midix\@$gEmailDomain>
575 Reply-To: $ref\@$gEmailDomain
576 X-$gProject-PR-Message: submitter-changed $ref
578 The submitter address recorded for your $gBug report
579 #$ref: $data->{subject}
582 The old submitter address for this report was
584 The new submitter address is
587 This change was made by
589 If it was incorrect, please contact them directly.
592 (administrator, $gProject $gBugs database)
595 &sendmailmessage($message,$oldsubmitter);
602 } elsif (m/^forwarded\s+\#?(-?\d+)\s+(\S.*\S)$/i) {
604 $ref= $1; $whereto= $2;
605 $bug_affected{$ref}=1;
607 if (length($data->{forwarded})) {
608 $action= "Forwarded-to-address changed from $data->{forwarded} to $whereto.";
610 $action= "Noted your statement that $gBug has been forwarded to $whereto.";
612 if (length($data->{done})) {
613 $extramessage= "(By the way, this $gBug is currently marked as done.)\n";
616 &addmaintainers($data);
617 if (length($gForwardList)>0 && length($gListDomain)>0 ) {
618 &addccaddress("$gForwardList\@$gListDomain");
620 $data->{forwarded}= $whereto;
621 } while (&getnextbug);
623 } elsif (m/^notforwarded\s+\#?(-?\d+)$/i) {
626 $bug_affected{$ref}=1;
628 if (!length($data->{forwarded})) {
629 &transcript("$gBug is not marked as having been forwarded.\n\n");
632 $action= "Removed annotation that $gBug had been forwarded to $data->{forwarded}.";
634 &addmaintainers($data);
635 $data->{forwarded}= '';
636 } while (&getnextbug);
639 } elsif (m/^severity\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i ||
640 m/^priority\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i) {
643 $bug_affected{$ref}=1;
645 if (!grep($_ eq $newseverity, @gSeverityList, "$gDefaultSeverity")) {
646 &transcript("Severity level \`$newseverity' is not known.\n".
647 "Recognized are: $gShowSeverities.\n\n");
648 } elsif (exists $gObsoleteSeverities{$newseverity}) {
649 &transcript("Severity level \`$newseverity' is obsolete. " .
650 "$gObsoleteSeverities{$newseverity}\n\n");
652 $printseverity= $data->{severity};
653 $printseverity= "$gDefaultSeverity" if $printseverity eq '';
654 $action= "Severity set to \`$newseverity' from \`$printseverity'";
656 &addmaintainers($data);
657 if (defined $gStrongList and isstrongseverity($newseverity)) {
658 addbcc("$gStrongList\@$gListDomain");
660 $data->{severity}= $newseverity;
661 } while (&getnextbug);
663 } elsif (m/^tags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
665 $ref = $1; $addsubcode = $3; $tags = $4;
666 $bug_affected{$ref}=1;
668 if (defined $addsubcode) {
669 $addsub = "sub" if ($addsubcode eq "-");
670 $addsub = "add" if ($addsubcode eq "+");
671 $addsub = "set" if ($addsubcode eq "=");
675 foreach my $t (split /[\s,]+/, $tags) {
676 if (!grep($_ eq $t, @gTags)) {
683 &transcript("Unknown tag/s: ".join(', ', @badtags).".\n".
684 "Recognized are: ".join(' ', @gTags).".\n\n");
687 if ($data->{keywords} eq '') {
688 &transcript("There were no tags set.\n");
690 &transcript("Tags were: $data->{keywords}\n");
692 if ($addsub eq "set") {
693 $action= "Tags set to: " . join(", ", @okaytags);
694 } elsif ($addsub eq "add") {
695 $action= "Tags added: " . join(", ", @okaytags);
696 } elsif ($addsub eq "sub") {
697 $action= "Tags removed: " . join(", ", @okaytags);
700 &addmaintainers($data);
701 $data->{keywords} = '' if ($addsub eq "set");
702 # Allow removing obsolete tags.
703 if ($addsub eq "sub") {
704 foreach my $t (@badtags) {
705 $data->{keywords} = join ' ', grep $_ ne $t,
706 split ' ', $data->{keywords};
709 # Now process all other additions and subtractions.
710 foreach my $t (@okaytags) {
711 $data->{keywords} = join ' ', grep $_ ne $t,
712 split ' ', $data->{keywords};
713 $data->{keywords} = "$t $data->{keywords}" unless($addsub eq "sub");
715 $data->{keywords} =~ s/\s*$//;
716 } while (&getnextbug);
718 } elsif (m/^(un)?block\s+\#?(-?\d+)\s+(by|with)\s+\s*(\S.*)?$/i) {
720 my $bugnum = $2; my $blockers = $4;
722 $addsub = "sub" if ($1 eq "un");
726 foreach my $b (split /[\s,]+/, $blockers) {
731 push @okayblockers, $b;
733 # add to the list all bugs that are merged with $b,
734 # because all of their data must be kept in sync
735 @thisbugmergelist= split(/ /,$data->{mergedwith});
738 foreach $ref (@thisbugmergelist) {
740 push @okayblockers, $ref;
747 push @badblockers, $b;
751 push @badblockers, $b;
755 &transcript("Unknown blocking bug/s: ".join(', ', @badblockers).".\n");
760 if ($data->{blockedby} eq '') {
761 &transcript("Was not blocked by any bugs.\n");
763 &transcript("Was blocked by: $data->{blockedby}\n");
765 if ($addsub eq "set") {
766 $action= "Blocking bugs set to: " . join(", ", @okayblockers);
767 } elsif ($addsub eq "add") {
768 $action= "Blocking bugs added: " . join(", ", @okayblockers);
769 } elsif ($addsub eq "sub") {
770 $action= "Blocking bugs removed: " . join(", ", @okayblockers);
775 &addmaintainers($data);
776 my @oldblockerlist = split ' ', $data->{blockedby};
777 $data->{blockedby} = '' if ($addsub eq "set");
778 foreach my $b (@okayblockers) {
779 $data->{blockedby} = manipset($data->{blockedby}, $b,
783 foreach my $b (@oldblockerlist) {
784 if (! grep { $_ eq $b } split ' ', $data->{blockedby}) {
785 push @{$removedblocks{$b}}, $ref;
788 foreach my $b (split ' ', $data->{blockedby}) {
789 if (! grep { $_ eq $b } @oldblockerlist) {
790 push @{$addedblocks{$b}}, $ref;
793 } while (&getnextbug);
795 # Now that the blockedby data is updated, change blocks data
796 # to match the changes.
797 foreach $ref (keys %addedblocks) {
799 foreach my $b (@{$addedblocks{$ref}}) {
800 $data->{blocks} = manipset($data->{blocks}, $b, 1);
805 foreach $ref (keys %removedblocks) {
807 foreach my $b (@{$removedblocks{$ref}}) {
808 $data->{blocks} = manipset($data->{blocks}, $b, 0);
814 } elsif (m/^retitle\s+\#?(-?\d+)\s+(\S.*\S)\s*$/i) {
816 $ref= $1; $newtitle= $2;
817 $bug_affected{$ref}=1;
818 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
819 $ref = $clonebugs{$ref};
822 if (&checkpkglimit) {
824 &addmaintainers($data);
825 $data->{subject}= $newtitle;
826 $action= "Changed $gBug title.";
828 &transcript("$action\n");
829 if (length($data->{done})) {
830 &transcript("(By the way, that $gBug is currently marked as done.)\n");
839 } elsif (m/^unmerge\s+\#?(-?\d+)$/i) {
842 $bug_affected{$ref} = 1;
844 if (!length($data->{mergedwith})) {
845 &transcript("$gBug is not marked as being merged with any others.\n\n");
848 $mergelowstate eq 'locked' || die "$mergelowstate ?";
849 $action= "Disconnected #$ref from all other report(s).";
850 @newmergelist= split(/ /,$data->{mergedwith});
852 @bug_affected{@newmergelist} = 1 x @newmergelist;
854 &addmaintainers($data);
855 $data->{mergedwith}= ($ref == $discref) ? ''
856 : join(' ',grep($_ ne $ref,@newmergelist));
857 } while (&getnextbug);
860 } elsif (m/^merge\s+#?(-?\d+(\s+#?-?\d+)+)\s*$/i) {
862 @tomerge= sort { $a <=> $b } split(/\s+#?/,$1);
868 while (defined($ref= shift(@tomerge))) {
869 &transcript("D| checking merge $ref\n") if $dl;
871 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
872 $ref = $clonebugs{$ref};
874 next if grep($_ eq $ref,@newmergelist);
875 if (!&getbug) { ¬foundbug; @newmergelist=(); last }
876 if (!&checkpkglimit) { &cancelbug; @newmergelist=(); last; }
878 &transcript("D| adding $ref ($data->{mergedwith})\n") if $dl;
880 &checkmatch('package','m_package',$data->{package});
881 &checkmatch('forwarded addr','m_forwarded',$data->{forwarded});
882 $data->{severity} = '$gDefaultSeverity' if $data->{severity} eq '';
883 &checkmatch('severity','m_severity',$data->{severity});
884 &checkmatch('blocks','m_blocks',$data->{blocks});
885 &checkmatch('blocked-by','m_blockedby',$data->{blockedby});
886 &checkmatch('done mark','m_done',length($data->{done}) ? 'done' : 'open');
887 &checkmatch('owner','m_owner',$data->{owner});
888 foreach my $t (split /\s+/, $data->{keywords}) { $tags{$t} = 1; }
889 foreach my $f (@{$data->{found_versions}}) { $found{$f} = 1; }
890 foreach my $f (@{$data->{fixed_versions}}) { $fixed{$f} = 1; }
891 if (length($mismatch)) {
892 &transcript("Mismatch - only $gBugs in same state can be merged:\n".
894 &cancelbug; @newmergelist=(); last;
896 push(@newmergelist,$ref);
897 push(@tomerge,split(/ /,$data->{mergedwith}));
901 @newmergelist= sort { $a <=> $b } @newmergelist;
902 $action= "Merged @newmergelist.";
903 delete @fixed{keys %found};
904 for $ref (@newmergelist) {
905 &getbug || die "huh ? $gBug $ref disappeared during merge";
906 &addmaintainers($data);
907 @bug_affected{@newmergelist} = 1 x @newmergelist;
908 $data->{mergedwith}= join(' ',grep($_ ne $ref,@newmergelist));
909 $data->{keywords}= join(' ', keys %tags);
910 $data->{found_versions}= [sort keys %found];
911 $data->{fixed_versions}= [sort keys %fixed];
914 &transcript("$action\n\n");
917 } elsif (m/^clone\s+#?(\d+)\s+((-\d+\s+)*-\d+)\s*$/i) {
921 @newclonedids = split /\s+/, $2;
922 $newbugsneeded = scalar(@newclonedids);
925 $bug_affected{$ref} = 1;
927 if (length($data->{mergedwith})) {
928 &transcript("$gBug is marked as being merged with others.\n\n");
931 &filelock("nextnumber.lock");
932 open(N,"nextnumber") || &quit("nextnumber: read: $!");
933 $v=<N>; $v =~ s/\n$// || &quit("nextnumber bad format");
934 $firstref= $v+0; $v += $newbugsneeded;
935 open(NN,">nextnumber"); print NN "$v\n"; close(NN);
938 $lastref = $firstref + $newbugsneeded - 1;
940 if ($newbugsneeded == 1) {
941 $action= "$gBug $origref cloned as bug $firstref.";
943 $action= "$gBug $origref cloned as bugs $firstref-$lastref.";
946 my $blocks = $data->{blocks};
947 my $blockedby = $data->{blockedby};
950 my $ohash = get_hashname($origref);
951 my $clone = $firstref;
952 @bug_affected{@newclonedids} = 1 x @newclonedids;
953 for $newclonedid (@newclonedids) {
954 $clonebugs{$newclonedid} = $clone;
956 my $hash = get_hashname($clone);
957 copy("db-h/$ohash/$origref.log", "db-h/$hash/$clone.log");
958 copy("db-h/$ohash/$origref.status", "db-h/$hash/$clone.status");
959 copy("db-h/$ohash/$origref.summary", "db-h/$hash/$clone.summary");
960 copy("db-h/$ohash/$origref.report", "db-h/$hash/$clone.report");
961 &bughook('new', $clone, $data);
963 # Update blocking info of bugs blocked by or blocking the
965 foreach $ref (split ' ', $blocks) {
967 $data->{blockedby} = manipset($data->{blockedby}, $clone, 1);
970 foreach $ref (split ' ', $blockedby) {
972 $data->{blocks} = manipset($data->{blocks}, $clone, 1);
980 } elsif (m/^package\s+(\S.*\S)?\s*$/i) {
982 my @pkgs = split /\s+/, $1;
983 if (scalar(@pkgs) > 0) {
984 %limit_pkgs = map { ($_, 1) } @pkgs;
985 &transcript("Ignoring bugs not assigned to: " .
986 join(" ", keys(%limit_pkgs)) . "\n\n");
989 &transcript("Not ignoring any bugs.\n\n");
991 } elsif (m/^owner\s+\#?(-?\d+)\s+!$/i ? ($newowner = $replyto, 1) :
992 m/^owner\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($newowner = $2, 1) : 0) {
995 $bug_affected{$ref} = 1;
997 if (length $data->{owner}) {
998 $action = "Owner changed from $data->{owner} to $newowner.";
1000 $action = "Owner recorded as $newowner.";
1002 if (length $data->{done}) {
1003 $extramessage = "(By the way, this $gBug is currently " .
1004 "marked as done.)\n";
1007 &addmaintainers($data);
1008 $data->{owner} = $newowner;
1009 } while (&getnextbug);
1011 } elsif (m/^noowner\s+\#?(-?\d+)$/i) {
1014 $bug_affected{$ref} = 1;
1016 if (length $data->{owner}) {
1017 $action = "Removed annotation that $gBug was owned by " .
1020 &addmaintainers($data);
1021 $data->{owner} = '';
1022 } while (&getnextbug);
1024 &transcript("$gBug is not marked as having an owner.\n\n");
1029 &transcript("Unknown command or malformed arguments to command.\n\n");
1030 if (++$unknowns >= 5) {
1031 &transcript("Too many unknown commands, stopping here.\n\n");
1036 if ($procline>$#bodylines) {
1037 &transcript(">\nEnd of message, stopping processing here.\n\n");
1039 if (!$ok && !quickabort) {
1040 &transcript("No commands successfully parsed; sending the help text(s).\n");
1045 &transcript("MC\n") if $dl>1;
1047 for $maint (keys %maintccreasons) {
1048 &transcript("MM|$maint|\n") if $dl>1;
1049 next if $maint eq $replyto;
1051 $reasonsref= $maintccreasons{$maint};
1052 &transcript("MY|$maint|\n") if $dl>2;
1053 for $p (sort keys %$reasonsref) {
1054 &transcript("MP|$p|\n") if $dl>2;
1055 $reasonstring.= ', ' if length($reasonstring);
1056 $reasonstring.= $p.' ' if length($p);
1057 $reasonstring.= join(' ',map("#$_",sort keys %{$$reasonsref{$p}}));
1059 if (length($reasonstring) > 40) {
1060 (substr $reasonstring, 37) = "...";
1062 $reasonstring = "" if (!defined($reasonstring));
1063 push(@maintccs,"$maint ($reasonstring)");
1064 push(@maintccaddrs,"$maint");
1069 &transcript("MC|@maintccs|\n") if $dl>2;
1070 $maintccs .= "Cc: " . join(",\n ",@maintccs) . "\n";
1073 # Add Bcc's to subscribed bugs
1074 push @bcc, map {"bugs=$_\@$gListDomain"} keys %bug_affected;
1076 if (!defined $header{'subject'} || $header{'subject'} eq "") {
1077 $header{'subject'} = "your mail";
1081 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1083 ${maintccs}Subject: Processed: $header{'subject'}
1084 In-Reply-To: $header{'message-id'}
1085 References: $header{'message-id'}
1086 Message-ID: <handler.s.$nn.transcript\@$gEmailDomain>
1088 X-$gProject-PR-Message: transcript
1090 ${transcript}Please contact me if you need assistance.
1093 (administrator, $gProject $gBugs database)
1097 $repliedshow= join(', ',$replyto,@maintccaddrs);
1098 &filelock("lock/-1");
1099 open(AP,">>db-h/-1.log") || &quit("open db-h/-1.log: $!");
1101 "\2\n$repliedshow\n\5\n$reply\n\3\n".
1103 "<strong>Request received</strong> from <code>".
1104 &sani($header{'from'})."</code>\n".
1105 "to <code>".&sani($controlrequestaddr)."</code>\n".
1107 "\7\n",@{escapelog(@log)},"\n\3\n") || &quit("writing db-h/-1.log: $!");
1108 close(AP) || &quit("open db-h/-1.log: $!");
1110 utime(time,time,"db-h");
1112 &sendmailmessage($reply,$replyto,@maintccaddrs,@bcc);
1114 unlink("incoming/P$nn") || &quit("unlinking incoming/P$nn: $!");
1116 sub sendmailmessage {
1117 local ($message,@recips) = @_;
1118 $message = "X-Loop: $gMaintainerEmail\n" . $message;
1119 send_mail_message(message => $message,
1120 recipients => \@recips,
1126 &sendtxthelpraw("bug-log-mailserver.txt","instructions for request\@$gEmailDomain");
1127 &sendtxthelpraw("bug-maint-mailcontrol.txt","instructions for control\@$gEmailDomain")
1131 #sub unimplemented {
1132 # &transcript("Sorry, command $_[0] not yet implemented.\n\n");
1136 local ($string,$mvarname,$svarvalue) = @_;
1138 if (@newmergelist) {
1139 eval "\$mvarvalue= \$$mvarname";
1140 &transcript("D| checkmatch \`$string' /$mvarname/$mvarvalue/$svarvalue/\n")
1143 "Values for \`$string' don't match:\n".
1144 " #$newmergelist[0] has \`$mvarvalue';\n".
1145 " #$ref has \`$svarvalue'\n"
1146 if $mvarvalue ne $svarvalue;
1148 &transcript("D| setupmatch \`$string' /$mvarname/$svarvalue/\n")
1150 eval "\$$mvarname= \$svarvalue";
1155 if (keys %limit_pkgs and not defined $limit_pkgs{$data->{package}}) {
1156 &transcript("$gBug number $ref belongs to package $data->{package}, skipping.\n\n");
1167 my %h = map { $_ => 1 } split ' ', $list;
1174 return join ' ', sort keys %h;
1177 # High-level bug manipulation calls
1178 # Do announcements themselves
1180 # Possible calling sequences:
1181 # setbug (returns 0)
1183 # setbug (returns 1)
1184 # &transcript(something)
1187 # setbug (returns 1)
1188 # $action= (something)
1190 # (modify s_* variables)
1191 # } while (getnextbug);
1194 &dlen("nochangebug");
1195 $state eq 'single' || $state eq 'multiple' || die "$state ?";
1197 &endmerge if $manybugs;
1199 &dlex("nochangebug");
1203 &dlen("setbug $ref");
1204 if ($ref =~ m/^-\d+/) {
1205 if (!defined $clonebugs{$ref}) {
1207 &dlex("setbug => noclone");
1210 $ref = $clonebugs{$ref};
1212 $state eq 'idle' || die "$state ?";
1215 &dlex("setbug => 0s");
1219 if (!&checkpkglimit) {
1224 @thisbugmergelist= split(/ /,$data->{mergedwith});
1225 if (!@thisbugmergelist) {
1230 &dlex("setbug => 1s");
1239 &dlex("setbug => 0mc");
1243 $state= 'multiple'; $sref=$ref;
1244 &dlex("setbug => 1m");
1249 &dlen("getnextbug");
1250 $state eq 'single' || $state eq 'multiple' || die "$state ?";
1252 if (!$manybugs || !@thisbugmergelist) {
1253 length($action) || die;
1254 &transcript("$action\n$extramessage\n");
1255 &endmerge if $manybugs;
1257 &dlex("getnextbug => 0");
1260 $ref= shift(@thisbugmergelist);
1261 &getbug || die "bug $ref disappeared";
1263 &dlex("getnextbug => 1");
1267 # Low-level bug-manipulation calls
1268 # Do no announcements
1270 # getbug (returns 0)
1272 # getbug (returns 1)
1276 # $action= (something)
1277 # getbug (returns 1)
1279 # getbug (returns 1)
1281 # [getbug (returns 0)]
1282 # &transcript("$action\n\n")
1285 sub notfoundbug { &transcript("$gBug number $ref not found.\n\n"); }
1286 sub foundbug { &transcript("$gBug#$ref: $data->{subject}\n"); }
1290 $mergelowstate eq 'idle' || die "$mergelowstate ?";
1291 &filelock('lock/merge');
1292 $mergelowstate='locked';
1298 $mergelowstate eq 'locked' || die "$mergelowstate ?";
1300 $mergelowstate='idle';
1305 &dlen("getbug $ref");
1306 $lowstate eq 'idle' || die "$state ?";
1307 if (($data = &lockreadbug($ref))) {
1310 &dlex("getbug => 1");
1315 &dlex("getbug => 0");
1321 $lowstate eq 'open' || die "$state ?";
1328 &dlen("savebug $ref");
1329 $lowstate eq 'open' || die "$lowstate ?";
1330 length($action) || die;
1331 $ref == $sref || die "read $sref but saving $ref ?";
1332 my $hash = get_hashname($ref);
1333 open(L,">>db-h/$hash/$ref.log") || &quit("opening db-h/$hash/$ref.log: $!");
1336 "<strong>".&sani($action)."</strong>\n".
1337 "Request was from <code>".&sani($header{'from'})."</code>\n".
1338 "to <code>".&sani($controlrequestaddr)."</code>. \n".
1340 "\7\n",@{escapelog(@log)},"\n\3\n") || &quit("writing db-h/$hash/$ref.log: $!");
1341 close(L) || &quit("closing db-h/$hash/$ref.log: $!");
1342 unlockwritebug($ref, $data);
1349 &transcript("C> @_ ($state $lowstate $mergelowstate)\n");
1354 &transcript("R> @_ ($state $lowstate $mergelowstate)\n");
1358 print $_[0] if $debug;
1359 $transcript.= $_[0];
1366 my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
1367 $url =~ s/([<>&"])/\&$saniarray{$1};/g;
1383 sub sendtxthelpraw {
1384 local ($relpath,$description) = @_;
1386 open(D,"$gDocDir/$relpath") || &quit("open doc file $relpath: $!");
1387 while(<D>) { $doc.=$_; }
1389 &transcript("Sending $description in separate message.\n");
1390 &sendmailmessage(<<END.$doc,$replyto);
1391 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1393 Subject: $gProject $gBug help: $description
1394 References: $header{'message-id'}
1395 In-Reply-To: $header{'message-id'}
1396 Message-ID: <handler.s.$nn.help.$midix\@$gEmailDomain>
1398 X-$gProject-PR-Message: doc-text $relpath
1404 sub sendlynxdocraw {
1405 local ($relpath,$description) = @_;
1407 open(L,"lynx -nolist -dump http://$gCGIDomain/\Q$relpath\E 2>&1 |") || &quit("fork for lynx: $!");
1408 while(<L>) { $doc.=$_; }
1410 if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
1411 &transcript("Information ($description) is not available -\n".
1412 "perhaps the $gBug does not exist or is not on the WWW yet.\n");
1415 &transcript("Error getting $description (code $? $!):\n$doc\n");
1417 &transcript("Sending $description.\n");
1418 &sendmailmessage(<<END.$doc,$replyto);
1419 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1421 Subject: $gProject $gBugs information: $description
1422 References: $header{'message-id'}
1423 In-Reply-To: $header{'message-id'}
1424 Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
1426 X-$gProject-PR-Message: doc-html $relpath
1435 $maintccreasons{$cca}{''}{$ref}= 1;
1438 sub addmaintainers {
1439 # Data structure is:
1440 # maintainer email address &c -> assoc of packages -> assoc of bug#'s
1443 &ensuremaintainersloaded;
1444 $anymaintfound=0; $anymaintnotfound=0;
1445 for $p (split(m/[ \t?,():]+/, $data->{package})) {
1447 $p =~ /([a-z0-9.+-]+)/;
1449 next unless defined $p;
1450 if (defined $gSubscriptionDomain) {
1451 if (defined($pkgsrc{$p})) {
1452 addbcc("$pkgsrc{$p}\@$gSubscriptionDomain");
1454 addbcc("$p\@$gSubscriptionDomain");
1457 if (defined $data->{severity} and defined $gStrongList and
1458 isstrongseverity($data->{severity})) {
1459 addbcc("$gStrongList\@$gListDomain");
1461 if (defined($maintainerof{$p})) {
1462 $addmaint= $maintainerof{$p};
1463 &transcript("MR|$addmaint|$p|$ref|\n") if $dl>2;
1464 $maintccreasons{$addmaint}{$p}{$ref}= 1;
1465 print "maintainer add >$p|$addmaint<\n" if $debug;
1467 print "maintainer none >$p<\n" if $debug;
1468 &transcript("Warning: Unknown package '$p'\n");
1469 &transcript("MR|unknown-package|$p|$ref|\n") if $dl>2;
1470 $maintccreasons{$gUnknownMaintainerEmail}{$p}{$ref}= 1;
1474 if (length $data->{owner}) {
1475 $addmaint = $data->{owner};
1476 &transcript("MO|$addmaint|$data->{package}|$ref|\n") if $dl>2;
1477 $maintccreasons{$addmaint}{$data->{package}}{$ref} = 1;
1478 print "owner add >$data->{package}|$addmaint<\n" if $debug;
1482 sub ensuremaintainersloaded {
1484 return if $maintainersloaded++;
1485 open(MAINT,"$gMaintainerFile") || die &quit("maintainers open: $!");
1489 m/^(\S+)\s+(\S.*\S)\s*\n$/ || &quit("maintainers bogus \`$_'");
1490 $a= $1; $b= $2; $a =~ y/A-Z/a-z/;
1491 $maintainerof{$1}= $2;
1494 open(MAINT,"$gMaintainerFileOverride") || die &quit("maintainers.override open: $!");
1498 m/^(\S+)\s+(\S.*\S)\s*\n$/ || &quit("maintainers.override bogus \`$_'");
1499 $a= $1; $b= $2; $a =~ y/A-Z/a-z/;
1500 $maintainerof{$1}= $2;
1503 open(SOURCES, "$gPackageSource") || &quit("pkgsrc open: $!");
1505 next unless m/^(\S+)\s+\S+\s+(\S.*\S)\s*$/;
1506 my ($a, $b) = ($1, $2);
1507 $pkgsrc{lc($a)} = $b;
1513 local ($wherefrom,$path,$description) = @_;
1514 if ($wherefrom eq "ftp.d.o") {
1515 $doc = `lynx -nolist -dump http://ftp.debian.org/debian/indices/$path.gz 2>&1 | gunzip -cf` or &quit("fork for lynx/gunzip: $!");
1517 if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
1518 &transcript("$description is not available.\n");
1521 &transcript("Error getting $description (code $? $!):\n$doc\n");
1524 } elsif ($wherefrom eq "local") {
1526 $doc = do { local $/; <P> };
1529 &transcript("internal errror: info files location unknown.\n");
1532 &transcript("Sending $description.\n");
1533 &sendmailmessage(<<END.$doc,$replyto);
1534 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1536 Subject: $gProject $gBugs information: $description
1537 References: $header{'message-id'}
1538 In-Reply-To: $header{'message-id'}
1539 Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
1541 X-$gProject-PR-Message: getinfo
1543 $description follows: