2 # $Id: service.in,v 1.118 2005/10/19 01:22:14 don Exp $
4 # Usage: service <code>.nn
5 # Temps: incoming/P<code>.nn
11 use Debbugs::Config qw(:globals :config);
16 use Params::Validate qw(:types validate_with);
18 use Debbugs::Common qw(:util :quit :misc :lock);
20 use Debbugs::Status qw(:read :status :write :versions :hook);
22 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
23 use Debbugs::Mail qw(send_mail_message);
25 use Debbugs::Recipients qw(:all);
26 use HTML::Entities qw(encode_entities);
27 use Debbugs::Versions::Dpkg;
29 use Debbugs::Status qw(splitpackages);
31 use Debbugs::CGI qw(html_escape);
32 use Debbugs::Control qw(:all);
33 use Debbugs::Log qw(:misc);
34 use Debbugs::Text qw(:templates);
36 use Mail::RFC822::Address;
38 chdir($config{spool_dir}) or
39 die "Unable to chdir to spool_dir '$config{spool_dir}': $!";
44 my ($nn,$control) = $ARGV[0] =~ m/^(([RC])\.\d+)$/;
45 if (not defined $control or not defined $nn) {
46 die "Bad argument to service.in";
48 if (!rename("incoming/G$nn","incoming/P$nn")) {
49 defined $! and $! =~ m/no such file or directory/i and exit 0;
50 die "Failed to rename incoming/G$nn to incoming/P$nn: $!";
53 my $log_fh = IO::File->new("incoming/P$nn",'r') or
54 die "Unable to open incoming/P$nn for reading: $!";
61 print "###\n",join("##\n",@msg),"\n###\n" if $debug;
63 # Bug numbers to send e-mail to, hash so that we don't send to the
67 my (@headerlines,@bodylines);
69 my $parse_output = Debbugs::MIME::parse(join('',@log));
70 @headerlines = @{$parse_output->{header}};
71 @bodylines = @{$parse_output->{body}};
75 $_ = decode_rfc1522($_);
77 print ">$_<\n" if $debug;
80 print ">$v=$_<\n" if $debug;
83 print "!>$_<\n" if $debug;
86 $header{'message-id'} ||= '';
87 $header{subject} ||= '';
89 grep(s/\s+$//,@bodylines);
91 print "***\n",join("\n",@bodylines),"\n***\n" if $debug;
93 if (defined $header{'resent-from'} && !defined $header{'from'}) {
94 $header{'from'} = $header{'resent-from'};
97 defined($header{'from'}) || die "no From header";
99 delete $header{'reply-to'}
100 if ( defined($header{'reply-to'}) && $header{'reply-to'} =~ m/^\s*$/ );
103 if ( defined($header{'reply-to'}) && $header{'reply-to'} ne "" ) {
104 $replyto = $header{'reply-to'};
106 $replyto = $header{'from'};
109 # This is an error counter which should be incremented every time there is an error.
111 my $controlrequestaddr= ($control ? 'control' : 'request').'@'.$config{email_domain};
112 my $transcript_scalar = '';
113 my $transcript = IO::Scalar->new(\$transcript_scalar) or
114 die "Unable to create new IO::Scalar";
115 print {$transcript} "Processing commands for $controlrequestaddr:\n\n";
120 my $lowstate= 'idle';
121 my $mergelowstate= 'idle';
126 $user =~ s/^.*<(.*)>.*$/$1/;
127 $user =~ s/[(].*[)]//;
128 $user =~ s/^\s*(\S+)\s+.*$/$1/;
129 $user = "" unless (Debbugs::User::is_valid_user($user));
130 my $indicated_user = 0;
135 if (@gExcludeFromControl and grep {$replyto =~ m/\Q$_\E/} @gExcludeFromControl) {
136 print {$transcript} fill_template('mail/excluded_from_control');
147 push @bcc, $_[0] unless grep { $_ eq $_[0] } @bcc;
162 my %affected_packages;
166 for ($procline=0; $procline<=$#bodylines; $procline++) {
171 $state eq 'idle' || print "state: $state ?\n";
172 $lowstate eq 'idle' || print "lowstate: $lowstate ?\n";
173 $mergelowstate eq 'idle' || print "mergelowstate: $mergelowstate ?\n";
175 print {$transcript} "Stopping processing here.\n\n";
178 $_= $bodylines[$procline]; s/\s+$//;
179 # Remove BOM markers from UTF-8 strings
183 print {$transcript} "> $_\n";
186 if (m/^stop\s*$/i || m/^quit\s*$/i || m/^--\s*$/ || m/^thank(?:s|\s*you)?\s*$/i || m/^kthxbye\s*$/i) {
187 print {$transcript} "Stopping processing here.\n\n";
189 } elsif (m/^debug\s+(\d+)$/i && $1 >= 0 && $1 <= 1000) {
191 print {$transcript} "Debug level $dl.\n\n";
192 } elsif (m/^(send|get)\s+\#?(\d{2,})$/i) {
194 &sendlynxdoc("bugreport.cgi?bug=$ref","logs for $gBug#$ref");
195 } elsif (m/^send-detail\s+\#?(\d{2,})$/i) {
197 &sendlynxdoc("bugreport.cgi?bug=$ref&boring=yes",
198 "detailed logs for $gBug#$ref");
199 } elsif (m/^index(\s+full)?$/i) {
200 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
202 $ok++; # well, it's not really ok, but it fixes #81224 :)
203 } elsif (m/^index-summary\s+by-package$/i) {
204 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
206 $ok++; # well, it's not really ok, but it fixes #81224 :)
207 } elsif (m/^index-summary(\s+by-number)?$/i) {
208 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
210 $ok++; # well, it's not really ok, but it fixes #81224 :)
211 } elsif (m/^index(\s+|-)pack(age)?s?$/i) {
212 &sendlynxdoc("pkgindex.cgi?indexon=pkg",'index of packages');
213 } elsif (m/^index(\s+|-)maints?$/i) {
214 &sendlynxdoc("pkgindex.cgi?indexon=maint",'index of maintainers');
215 } elsif (m/^index(\s+|-)maint\s+(\S+)$/i) {
217 &sendlynxdoc("pkgreport.cgi?maint=" . urlsanit($maint),
218 "$gBug list for maintainer \`$maint'");
220 } elsif (m/^index(\s+|-)pack(age)?s?\s+(\S.*\S)$/i) {
222 &sendlynxdoc("pkgreport.cgi?pkg=" . urlsanit($package),
223 "$gBug list for package $package");
225 } elsif (m/^send-unmatched(\s+this|\s+-?0)?$/i) {
226 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
228 $ok++; # well, it's not really ok, but it fixes #81224 :)
229 } elsif (m/^send-unmatched\s+(last|-1)$/i) {
230 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
232 $ok++; # well, it's not really ok, but it fixes #81224 :)
233 } elsif (m/^send-unmatched\s+(old|-2)$/i) {
234 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
236 $ok++; # well, it's not really ok, but it fixes #81224 :)
237 } elsif (m/^getinfo\s+([\w.-]+)$/i) {
238 # the following is basically a Debian-specific kludge, but who cares
240 if ($req =~ /^maintainers$/i && -f "$gConfigDir/Maintainers") {
241 &sendinfo("local", "$gConfigDir/Maintainers", "Maintainers file");
242 } elsif ($req =~ /^override\.(\w+)\.([\w.-]+)$/i) {
244 &sendinfo("ftp.d.o", "$req", "override file for $2 part of $1 distribution");
245 } elsif ($req =~ /^pseudo-packages\.(description|maintainers)$/i && -f "$gConfigDir/$req") {
246 &sendinfo("local", "$gConfigDir/$req", "$req file");
248 print {$transcript} "Info file $req does not exist.\n\n";
250 } elsif (m/^help/i) {
252 print {$transcript} "\n";
254 } elsif (m/^refcard/i) {
255 &sendtxthelp("bug-mailserver-refcard.txt","mail servers' reference card");
256 } elsif (m/^subscribe/i) {
257 print {$transcript} <<END;
258 There is no $gProject $gBug mailing list. If you wish to review bug reports
259 please do so via http://$gWebDomain/ or ask this mail server
261 soon: MAILINGLISTS_TEXT
263 } elsif (m/^unsubscribe/i) {
264 print {$transcript} <<END;
265 soon: UNSUBSCRIBE_TEXT
266 soon: MAILINGLISTS_TEXT
268 } elsif (m/^user\s+(\S+)\s*$/i) {
270 if (Debbugs::User::is_valid_user($newuser)) {
271 my $olduser = ($user ne "" ? " (was $user)" : "");
272 print {$transcript} "Setting user to $newuser$olduser.\n";
276 print {$transcript} "Selected user id ($newuser) invalid, sorry\n";
281 } elsif (m/^usercategory\s+(\S+)(\s+\[hidden\])?\s*$/i) {
284 my $hidden = ($2 ne "");
291 print {$transcript} "No valid user selected\n";
295 if (not $indicated_user and defined $user) {
296 print {$transcript} "User is $user\n";
300 while (++$procline <= $#bodylines) {
301 unless ($bodylines[$procline] =~ m/^\s*([*+])\s*(\S.*)$/) {
305 print {$transcript} "> $bodylines[$procline]\n";
307 my ($o, $txt) = ($1, $2);
308 if ($#cats == -1 && $o eq "+") {
309 print {$transcript} "User defined category specification must start with a category name. Skipping.\n\n";
315 unless (ref($cats[-1]) eq "HASH") {
316 $cats[-1] = { "nam" => $cats[-1],
317 "pri" => [], "ttl" => [] };
320 my ($desc, $ord, $op);
321 if ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?\]\s*$/) {
322 $desc = $1; $ord = $3; $op = "";
323 } elsif ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?(\S+)\]\s*$/) {
324 $desc = $1; $ord = $3; $op = $4;
325 } elsif ($txt =~ m/^([^[\s]+)\s*$/) {
326 $desc = ""; $op = $1;
328 print {$transcript} "Unrecognised syntax for category section. Skipping.\n\n";
333 $ord = 999 unless defined $ord;
336 push @{$cats[-1]->{"pri"}}, $prefix . $op;
337 push @{$cats[-1]->{"ttl"}}, $desc;
338 push @ords, "$ord $catsec";
340 $cats[-1]->{"def"} = $desc;
341 push @ords, "$ord DEF";
344 @ords = sort { my ($a1, $a2, $b1, $b2) = split / /, "$a $b";
345 $a1 <=> $b1 || $a2 <=> $b2; } @ords;
346 $cats[-1]->{"ord"} = [map { m/^.* (\S+)/; $1 eq "DEF" ? $catsec + 1 : $1 } @ords];
347 } elsif ($o eq "*") {
350 if ($txt =~ m/^(.*\S)(\s*\[(\S+)\])\s*$/) {
351 $name = $1; $prefix = $3;
353 $name = $txt; $prefix = "";
358 # XXX: got @cats, now do something with it
359 my $u = Debbugs::User::get_user($user);
361 print {$transcript} "Added usercategory $catname.\n\n";
362 $u->{"categories"}->{$catname} = [ @cats ];
364 push @{$u->{visible_cats}},$catname;
367 print {$transcript} "Removed usercategory $catname.\n\n";
368 delete $u->{"categories"}->{$catname};
369 @{$u->{visible_cats}} = grep {$_ ne $catname} @{$u->{visible_cats}};
372 } elsif (m/^usertags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
375 my $addsubcode = $3 || "+";
377 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
378 $ref = $clonebugs{$ref};
381 print {$transcript} "No valid user selected\n";
385 if (not $indicated_user and defined $user) {
386 print {$transcript} "User is $user\n";
391 Debbugs::User::read_usertags(\%ut, $user);
392 my @oldtags = (); my @newtags = (); my @badtags = ();
394 if (defined $tags and length $tags) {
395 for my $t (split /[,\s]+/, $tags) {
396 if ($t =~ m/^[a-zA-Z0-9.+\@-]+$/) {
404 print {$transcript} "Ignoring illegal tag/s: ".join(', ', @badtags).".\nPlease use only alphanumerics, at, dot, plus and dash.\n";
407 for my $t (keys %chtags) {
408 $ut{$t} = [] unless defined $ut{$t};
410 for my $t (keys %ut) {
411 my %res = map { ($_, 1) } @{$ut{$t}};
412 push @oldtags, $t if defined $res{$ref};
413 my $addop = ($addsubcode eq "+" or $addsubcode eq "=");
414 my $del = (defined $chtags{$t} ? $addsubcode eq "-"
415 : $addsubcode eq "=");
416 $res{$ref} = 1 if ($addop && defined $chtags{$t});
417 delete $res{$ref} if ($del);
418 push @newtags, $t if defined $res{$ref};
419 $ut{$t} = [ sort { $a <=> $b } (keys %res) ];
422 print {$transcript} "There were no usertags set.\n";
424 print {$transcript} "Usertags were: " . join(" ", @oldtags) . ".\n";
426 print {$transcript} "Usertags are now: " . join(" ", @newtags) . ".\n";
427 Debbugs::User::write_usertags(\%ut, $user);
429 } elsif (!$control) {
430 print {$transcript} <<END;
431 Unknown command or malformed arguments to command.
432 (Use control\@$gEmailDomain to manipulate reports.)
436 if (++$unknowns >= 3) {
437 print {$transcript} "Too many unknown commands, stopping here.\n\n";
440 #### "developer only" ones start here
441 } elsif (m/^close\s+\#?(-?\d+)(?:\s+(\d.*))?$/i) {
444 $bug_affected{$ref}=1;
447 print {$transcript} "'close' is deprecated; see http://$gWebDomain/Developer$gHTMLSuffix#closing.\n";
448 if (length($data->{done}) and not defined($version)) {
449 print {$transcript} "$gBug is already closed, cannot re-close.\n\n";
454 "marked as fixed in version $version" :
456 ", send any further explanations to $data->{originator}";
458 $affected_packages{$data->{package}} = 1;
459 add_recipients(data => $data,
460 recipients => \%recipients,
461 actions_taken => {done => 1},
462 transcript => $transcript,
463 ($dl > 0 ? (debug => $transcript):()),
465 $data->{done}= $replyto;
466 my @keywords= split ' ', $data->{keywords};
467 my $extramessage = '';
468 if (grep $_ eq 'pending', @keywords) {
469 $extramessage= "Removed pending tag.\n";
470 $data->{keywords}= join ' ', grep $_ ne 'pending',
473 addfixedversions($data, $data->{package}, $version, 'binary');
476 From: $gMaintainerEmail ($gProject $gBug Tracking System)
477 To: $data->{originator}
478 Subject: $gBug#$ref acknowledged by developer
480 References: $header{'message-id'} $data->{msgid}
481 In-Reply-To: $data->{msgid}
482 Message-ID: <handler.$ref.$nn.notifdonectrl.$midix\@$gEmailDomain>
483 Reply-To: $ref\@$gEmailDomain
484 X-$gProject-PR-Message: they-closed-control $ref
486 This is an automatic notification regarding your $gBug report
487 #$ref: $data->{subject},
488 which was filed against the $data->{package} package.
490 It has been marked as closed by one of the developers, namely
493 You should be hearing from them with a substantive response shortly,
494 in case you haven't already. If not, please contact them directly.
497 (administrator, $gProject $gBugs database)
500 &sendmailmessage($message,$data->{originator});
501 } while (&getnextbug);
504 } elsif (m/^reassign\s+\#?(-?\d+)\s+(\S+)(?:\s+(\d.*))?$/i) {
508 $bug_affected{$ref}=1;
510 $newpackage =~ y/A-Z/a-z/;
512 if (length($data->{package})) {
513 $action= "$gBug reassigned from package \`$data->{package}'".
514 " to \`$newpackage'.";
516 $action= "$gBug assigned to package \`$newpackage'.";
519 $affected_packages{$data->{package}} = 1;
520 add_recipients(data => $data,
521 recipients => \%recipients,
522 transcript => $transcript,
523 ($dl > 0 ? (debug => $transcript):()),
525 $data->{package}= $newpackage;
526 $data->{found_versions}= [];
527 $data->{fixed_versions}= [];
528 # TODO: what if $newpackage is a source package?
529 addfoundversions($data, $data->{package}, $version, 'binary');
530 add_recipients(data => $data,
531 recipients => \%recipients,
532 transcript => $transcript,
533 ($dl > 0 ? (debug => $transcript):()),
535 } while (&getnextbug);
537 } elsif (m/^reopen\s+\#?(-?\d+)$/i ? ($noriginator='', 1) :
538 m/^reopen\s+\#?(-?\d+)\s+\=$/i ? ($noriginator='', 1) :
539 m/^reopen\s+\#?(-?\d+)\s+\!$/i ? ($noriginator=$replyto, 1) :
540 m/^reopen\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($noriginator=$2, 1) : 0) {
543 $bug_affected{$ref}=1;
545 if (@{$data->{fixed_versions}}) {
546 print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\nyou may need to use 'found' to remove fixed versions.\n";
548 if (!length($data->{done})) {
549 print {$transcript} "$gBug is already open, cannot reopen.\n\n";
553 $noriginator eq '' ? "$gBug reopened, originator not changed." :
554 "$gBug reopened, originator set to $noriginator.";
556 $affected_packages{$data->{package}} = 1;
557 add_recipients(data => $data,
558 recipients => \%recipients,
559 transcript => $transcript,
560 ($dl > 0 ? (debug => $transcript):()),
562 $data->{originator}= $noriginator eq '' ? $data->{originator} : $noriginator;
563 $data->{fixed_versions}= [];
565 } while (&getnextbug);
568 } elsif (m{^found\s+\#?(-?\d+)
569 (?:\s+((?:$config{package_name_re}\/)?
570 $config{package_version_re}))?$}ix) {
575 if (!length($data->{done}) and not defined($version)) {
576 print {$transcript} "$gBug is already open, cannot reopen.\n\n";
582 "$gBug marked as found in version $version." :
585 $affected_packages{$data->{package}} = 1;
586 add_recipients(data => $data,
587 recipients => \%recipients,
588 transcript => $transcript,
589 ($dl > 0 ? (debug => $transcript):()),
591 # The 'done' field gets a bit weird with version
592 # tracking, because a bug may be closed by multiple
593 # people in different branches. Until we have something
594 # more flexible, we set it every time a bug is fixed,
595 # and clear it when a bug is found in a version greater
596 # than any version in which the bug is fixed or when
597 # a bug is found and there is no fixed version
598 if (defined $version) {
599 my ($version_only) = $version =~ m{([^/]+)$};
600 addfoundversions($data, $data->{package}, $version, 'binary');
601 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
602 map {s{.+/}{}; $_;} @{$data->{fixed_versions}};
603 if (not @fixed_order or (Debbugs::Versions::Dpkg::vercmp($version_only,$fixed_order[-1]) >= 0)) {
604 $action = "$gBug marked as found in version $version and reopened."
605 if length $data->{done};
609 # Versionless found; assume old-style "not fixed at
611 $data->{fixed_versions} = [];
614 } while (&getnextbug);
617 } elsif (m[^notfound\s+\#?(-?\d+)\s+
618 ((?:$config{package_name_re}\/)?
624 $action= "$gBug no longer marked as found in version $version.";
625 if (length($data->{done})) {
626 $extramessage= "(By the way, this $gBug is currently marked as done.)\n";
629 $affected_packages{$data->{package}} = 1;
630 add_recipients(data => $data,
631 recipients => \%recipients,
632 transcript => $transcript,
633 ($dl > 0 ? (debug => $transcript):()),
635 removefoundversions($data, $data->{package}, $version, 'binary');
636 } while (&getnextbug);
639 elsif (m[^fixed\s+\#?(-?\d+)\s+
640 ((?:$config{package_name_re}\/)?
641 $config{package_version_re})\s*$]ix) {
648 "$gBug marked as fixed in version $version." :
651 $affected_packages{$data->{package}} = 1;
652 add_recipients(data => $data,
653 recipients => \%recipients,
654 transcript => $transcript,
655 ($dl > 0 ? (debug => $transcript):()),
657 addfixedversions($data, $data->{package}, $version, 'binary');
658 } while (&getnextbug);
661 elsif (m[^notfixed\s+\#?(-?\d+)\s+
662 ((?:$config{package_name_re}\/)?
670 "$gBug no longer marked as fixed in version $version." :
673 $affected_packages{$data->{package}} = 1;
674 add_recipients(data => $data,
675 recipients => \%recipients,
676 transcript => $transcript,
677 ($dl > 0 ? (debug => $transcript):()),
679 removefixedversions($data, $data->{package}, $version, 'binary');
680 } while (&getnextbug);
683 elsif (m/^submitter\s+\#?(-?\d+)\s+\!$/i ? ($newsubmitter=$replyto, 1) :
684 m/^submitter\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($newsubmitter=$2, 1) : 0) {
687 $bug_affected{$ref}=1;
688 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
689 $ref = $clonebugs{$ref};
691 if (not Mail::RFC822::Address::valid($newsubmitter)) {
692 transcript("$newsubmitter is not a valid e-mail address; not changing submitter\n");
696 if (&checkpkglimit) {
698 $affected_packages{$data->{package}} = 1;
699 add_recipients(data => $data,
700 recipients => \%recipients,
701 transcript => $transcript,
702 ($dl > 0 ? (debug => $transcript):()),
704 $oldsubmitter= $data->{originator};
705 $data->{originator}= $newsubmitter;
706 $action= "Changed $gBug submitter from $oldsubmitter to $newsubmitter.";
708 print {$transcript} "$action\n";
709 if (length($data->{done})) {
710 print {$transcript} "(By the way, that $gBug is currently marked as done.)\n";
712 print {$transcript} "\n";
714 From: $gMaintainerEmail ($gProject $gBug Tracking System)
716 Subject: $gBug#$ref submitter address changed
718 References: $header{'message-id'} $data->{msgid}
719 In-Reply-To: $data->{msgid}
720 Message-ID: <handler.$ref.$nn.newsubmitter.$midix\@$gEmailDomain>
721 Reply-To: $ref\@$gEmailDomain
722 X-$gProject-PR-Message: submitter-changed $ref
724 The submitter address recorded for your $gBug report
725 #$ref: $data->{subject}
728 The old submitter address for this report was
730 The new submitter address is
733 This change was made by
735 If it was incorrect, please contact them directly.
738 (administrator, $gProject $gBugs database)
741 &sendmailmessage($message,$oldsubmitter);
748 } elsif (m/^forwarded\s+\#?(-?\d+)\s+(\S.*\S)$/i) {
752 $bug_affected{$ref}=1;
754 if (length($data->{forwarded})) {
755 $action= "Forwarded-to-address changed from $data->{forwarded} to $whereto.";
757 $action= "Noted your statement that $gBug has been forwarded to $whereto.";
759 if (length($data->{done})) {
760 $extramessage= "(By the way, this $gBug is currently marked as done.)\n";
763 $affected_packages{$data->{package}} = 1;
764 add_recipients(data => $data,
765 recipients => \%recipients,
766 actions_taken => {forwarded => 1},
767 transcript => $transcript,
768 ($dl > 0 ? (debug => $transcript):()),
770 $data->{forwarded}= $whereto;
771 } while (&getnextbug);
773 } elsif (m/^notforwarded\s+\#?(-?\d+)$/i) {
776 $bug_affected{$ref}=1;
778 if (!length($data->{forwarded})) {
779 print {$transcript} "$gBug is not marked as having been forwarded.\n\n";
782 $action= "Removed annotation that $gBug had been forwarded to $data->{forwarded}.";
784 $affected_packages{$data->{package}} = 1;
785 add_recipients(data => $data,
786 recipients => \%recipients,
787 transcript => $transcript,
788 ($dl > 0 ? (debug => $transcript):()),
790 $data->{forwarded}= '';
791 } while (&getnextbug);
794 } elsif (m/^severity\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i ||
795 m/^priority\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i) {
798 $bug_affected{$ref}=1;
800 if (!grep($_ eq $newseverity, @gSeverityList, "$gDefaultSeverity")) {
801 print {$transcript} "Severity level \`$newseverity' is not known.\n".
802 "Recognized are: $gShowSeverities.\n\n";
804 } elsif (exists $gObsoleteSeverities{$newseverity}) {
805 print {$transcript} "Severity level \`$newseverity' is obsolete. " .
806 "Use $gObsoleteSeverities{$newseverity} instead.\n\n";
809 my $printseverity= $data->{severity};
810 $printseverity= "$gDefaultSeverity" if $printseverity eq '';
811 $action= "Severity set to \`$newseverity' from \`$printseverity'";
813 $affected_packages{$data->{package}} = 1;
814 add_recipients(data => $data,
815 recipients => \%recipients,
816 transcript => $transcript,
817 ($dl > 0 ? (debug => $transcript):()),
819 if (defined $gStrongList and isstrongseverity($newseverity)) {
820 addbcc("$gStrongList\@$gListDomain");
822 $data->{severity}= $newseverity;
823 } while (&getnextbug);
825 } elsif (m/^tags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
830 $bug_affected{$ref}=1;
832 if (defined $addsubcode) {
833 $addsub = "sub" if ($addsubcode eq "-");
834 $addsub = "add" if ($addsubcode eq "+");
835 $addsub = "set" if ($addsubcode eq "=");
839 foreach my $t (split /[\s,]+/, $tags) {
840 if (!grep($_ eq $t, @gTags)) {
847 print {$transcript} "Unknown tag/s: ".join(', ', @badtags).".\n".
848 "Recognized are: ".join(' ', @gTags).".\n\n";
852 if ($data->{keywords} eq '') {
853 print {$transcript} "There were no tags set.\n";
855 print {$transcript} "Tags were: $data->{keywords}\n";
857 if ($addsub eq "set") {
858 $action= "Tags set to: " . join(", ", @okaytags);
859 } elsif ($addsub eq "add") {
860 $action= "Tags added: " . join(", ", @okaytags);
861 } elsif ($addsub eq "sub") {
862 $action= "Tags removed: " . join(", ", @okaytags);
865 $affected_packages{$data->{package}} = 1;
866 add_recipients(data => $data,
867 recipients => \%recipients,
868 transcript => $transcript,
869 ($dl > 0 ? (debug => $transcript):()),
871 $data->{keywords} = '' if ($addsub eq "set");
872 # Allow removing obsolete tags.
873 if ($addsub eq "sub") {
874 foreach my $t (@badtags) {
875 $data->{keywords} = join ' ', grep $_ ne $t,
876 split ' ', $data->{keywords};
879 # Now process all other additions and subtractions.
880 foreach my $t (@okaytags) {
881 $data->{keywords} = join ' ', grep $_ ne $t,
882 split ' ', $data->{keywords};
883 $data->{keywords} = "$t $data->{keywords}" unless($addsub eq "sub");
885 $data->{keywords} =~ s/\s*$//;
886 } while (&getnextbug);
888 } elsif (m/^(un)?block\s+\#?(-?\d+)\s+(by|with)\s+(\S.*)?$/i) {
890 my $bugnum = $2; my $blockers = $4;
892 $addsub = "sub" if (defined $1 and $1 eq "un");
893 if ($bugnum =~ m/^-\d+$/ && defined $clonebugs{$bugnum}) {
894 $bugnum = $clonebugs{$bugnum};
899 foreach my $b (split /[\s,]+/, $blockers) {
903 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
904 $ref = $clonebugs{$ref};
908 push @okayblockers, $ref;
910 # add to the list all bugs that are merged with $b,
911 # because all of their data must be kept in sync
912 my @thisbugmergelist= split(/ /,$data->{mergedwith});
915 foreach $ref (@thisbugmergelist) {
917 push @okayblockers, $ref;
924 push @badblockers, $ref;
928 push @badblockers, $b;
932 print {$transcript} "Unknown blocking bug/s: ".join(', ', @badblockers).".\n";
938 if ($data->{blockedby} eq '') {
939 print {$transcript} "Was not blocked by any bugs.\n";
941 print {$transcript} "Was blocked by: $data->{blockedby}\n";
943 if ($addsub eq "set") {
944 $action= "Blocking bugs of $bugnum set to: " . join(", ", @okayblockers);
945 } elsif ($addsub eq "add") {
946 $action= "Blocking bugs of $bugnum added: " . join(", ", @okayblockers);
947 } elsif ($addsub eq "sub") {
948 $action= "Blocking bugs of $bugnum removed: " . join(", ", @okayblockers);
953 $affected_packages{$data->{package}} = 1;
954 add_recipients(data => $data,
955 recipients => \%recipients,
956 transcript => $transcript,
957 ($dl > 0 ? (debug => $transcript):()),
959 my @oldblockerlist = split ' ', $data->{blockedby};
960 $data->{blockedby} = '' if ($addsub eq "set");
961 foreach my $b (@okayblockers) {
962 $data->{blockedby} = manipset($data->{blockedby}, $b,
966 foreach my $b (@oldblockerlist) {
967 if (! grep { $_ eq $b } split ' ', $data->{blockedby}) {
968 push @{$removedblocks{$b}}, $ref;
971 foreach my $b (split ' ', $data->{blockedby}) {
972 if (! grep { $_ eq $b } @oldblockerlist) {
973 push @{$addedblocks{$b}}, $ref;
976 } while (&getnextbug);
978 # Now that the blockedby data is updated, change blocks data
979 # to match the changes.
980 foreach $ref (keys %addedblocks) {
982 foreach my $b (@{$addedblocks{$ref}}) {
983 $data->{blocks} = manipset($data->{blocks}, $b, 1);
988 foreach $ref (keys %removedblocks) {
990 foreach my $b (@{$removedblocks{$ref}}) {
991 $data->{blocks} = manipset($data->{blocks}, $b, 0);
997 } elsif (m/^retitle\s+\#?(-?\d+)\s+(\S.*\S)\s*$/i) {
999 $ref= $1; my $newtitle= $2;
1000 $bug_affected{$ref}=1;
1001 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
1002 $ref = $clonebugs{$ref};
1005 if (&checkpkglimit) {
1007 $affected_packages{$data->{package}} = 1;
1008 add_recipients(data => $data,
1009 recipients => \%recipients,
1010 transcript => $transcript,
1011 ($dl > 0 ? (debug => $transcript):()),
1013 my $oldtitle = $data->{subject};
1014 $data->{subject}= $newtitle;
1015 $action= "Changed $gBug title to `$newtitle' from `$oldtitle'.";
1017 print {$transcript} "$action\n";
1018 if (length($data->{done})) {
1019 print {$transcript} "(By the way, that $gBug is currently marked as done.)\n";
1021 print {$transcript} "\n";
1028 } elsif (m/^unmerge\s+\#?(-?\d+)$/i) {
1031 $bug_affected{$ref} = 1;
1033 if (!length($data->{mergedwith})) {
1034 print {$transcript} "$gBug is not marked as being merged with any others.\n\n";
1037 $mergelowstate eq 'locked' || die "$mergelowstate ?";
1038 $action= "Disconnected #$ref from all other report(s).";
1039 my @newmergelist= split(/ /,$data->{mergedwith});
1041 @bug_affected{@newmergelist} = 1 x @newmergelist;
1043 $affected_packages{$data->{package}} = 1;
1044 add_recipients(data => $data,
1045 recipients => \%recipients,
1046 transcript => $transcript,
1047 ($dl > 0 ? (debug => $transcript):()),
1049 $data->{mergedwith}= ($ref == $discref) ? ''
1050 : join(' ',grep($_ ne $ref,@newmergelist));
1051 } while (&getnextbug);
1054 } elsif (m/^merge\s+#?(-?\d+(\s+#?-?\d+)+)\s*$/i) {
1056 my @tomerge= sort { $a <=> $b } split(/\s+#?/,$1);
1057 my @newmergelist= ();
1062 while (defined($ref= shift(@tomerge))) {
1063 print {$transcript} "D| checking merge $ref\n" if $dl;
1065 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
1066 $ref = $clonebugs{$ref};
1068 next if grep($_ == $ref,@newmergelist);
1069 if (!&getbug) { ¬foundbug; @newmergelist=(); last }
1070 if (!&checkpkglimit) { &cancelbug; @newmergelist=(); last; }
1072 print {$transcript} "D| adding $ref ($data->{mergedwith})\n" if $dl;
1074 &checkmatch('package','m_package',$data->{package},@newmergelist);
1075 &checkmatch('forwarded addr','m_forwarded',$data->{forwarded},@newmergelist);
1076 $data->{severity} = '$gDefaultSeverity' if $data->{severity} eq '';
1077 &checkmatch('severity','m_severity',$data->{severity},@newmergelist);
1078 &checkmatch('blocks','m_blocks',$data->{blocks},@newmergelist);
1079 &checkmatch('blocked-by','m_blockedby',$data->{blockedby},@newmergelist);
1080 &checkmatch('done mark','m_done',length($data->{done}) ? 'done' : 'open',@newmergelist);
1081 &checkmatch('owner','m_owner',$data->{owner},@newmergelist);
1082 &checkmatch('summary','m_summary',$data->{summary},@newmergelist);
1083 &checkmatch('affects','m_affects',$data->{affects},@newmergelist);
1084 foreach my $t (split /\s+/, $data->{keywords}) { $tags{$t} = 1; }
1085 foreach my $f (@{$data->{found_versions}}) { $found{$f} = 1; }
1086 foreach my $f (@{$data->{fixed_versions}}) { $fixed{$f} = 1; }
1087 if (length($mismatch)) {
1088 print {$transcript} "Mismatch - only $gBugs in same state can be merged:\n".
1091 &cancelbug; @newmergelist=(); last;
1093 push(@newmergelist,$ref);
1094 push(@tomerge,split(/ /,$data->{mergedwith}));
1097 if (@newmergelist) {
1098 @newmergelist= sort { $a <=> $b } @newmergelist;
1099 $action= "Merged @newmergelist.";
1100 delete @fixed{keys %found};
1101 for $ref (@newmergelist) {
1102 &getbug || die "huh ? $gBug $ref disappeared during merge";
1103 $affected_packages{$data->{package}} = 1;
1104 add_recipients(data => $data,
1105 recipients => \%recipients,
1106 transcript => $transcript,
1107 ($dl > 0 ? (debug => $transcript):()),
1109 @bug_affected{@newmergelist} = 1 x @newmergelist;
1110 $data->{mergedwith}= join(' ',grep($_ != $ref,@newmergelist));
1111 $data->{keywords}= join(' ', keys %tags);
1112 $data->{found_versions}= [sort keys %found];
1113 $data->{fixed_versions}= [sort keys %fixed];
1116 print {$transcript} "$action\n\n";
1119 } elsif (m/^forcemerge\s+\#?(-?\d+(?:\s+\#?-?\d+)+)\s*$/i) {
1121 my @temp = split /\s+\#?/,$1;
1122 my $master_bug = shift @temp;
1123 my $master_bug_data;
1124 my @tomerge = sort { $a <=> $b } @temp;
1125 unshift @tomerge,$master_bug;
1126 print {$transcript} "D| force merging ".join(',',@tomerge)."\n" if $dl;
1127 my @newmergelist= ();
1131 # Here we try to do the right thing.
1132 # First, if the bugs are in the same package, we merge all of the found, fixed, and tags.
1133 # If not, we discard the found and fixed.
1134 # Everything else we set to the values of the first bug.
1136 while (defined($ref= shift(@tomerge))) {
1137 print {$transcript} "D| checking merge $ref\n" if $dl;
1139 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
1140 $ref = $clonebugs{$ref};
1142 next if grep($_ == $ref,@newmergelist);
1143 if (!&getbug) { ¬foundbug; @newmergelist=(); last }
1144 if (!&checkpkglimit) { &cancelbug; @newmergelist=(); last; }
1146 print {$transcript} "D| adding $ref ($data->{mergedwith})\n" if $dl;
1147 $master_bug_data = $data if not defined $master_bug_data;
1148 if ($data->{package} ne $master_bug_data->{package}) {
1149 print {$transcript} "Mismatch - only $gBugs in the same package can be forcibly merged:\n".
1150 "$gBug $ref is not in the same package as $master_bug\n";
1152 &cancelbug; @newmergelist=(); last;
1154 for my $t (split /\s+/,$data->{keywords}) {
1157 @found{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1158 @fixed{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1159 push(@newmergelist,$ref);
1160 push(@tomerge,split(/ /,$data->{mergedwith}));
1163 if (@newmergelist) {
1164 @newmergelist= sort { $a <=> $b } @newmergelist;
1165 $action= "Forcibly Merged @newmergelist.";
1166 delete @fixed{keys %found};
1167 for $ref (@newmergelist) {
1168 &getbug || die "huh ? $gBug $ref disappeared during merge";
1169 $affected_packages{$data->{package}} = 1;
1170 add_recipients(data => $data,
1171 recipients => \%recipients,
1172 transcript => $transcript,
1173 ($dl > 0 ? (debug => $transcript):()),
1175 @bug_affected{@newmergelist} = 1 x @newmergelist;
1176 $data->{mergedwith}= join(' ',grep($_ != $ref,@newmergelist));
1177 $data->{keywords}= join(' ', keys %tags);
1178 $data->{found_versions}= [sort keys %found];
1179 $data->{fixed_versions}= [sort keys %fixed];
1180 my @field_list = qw(forwarded package severity blocks blockedby owner done affects summary);
1181 @{$data}{@field_list} = @{$master_bug_data}{@field_list};
1184 print {$transcript} "$action\n\n";
1187 } elsif (m/^clone\s+#?(\d+)\s+((-\d+\s+)*-\d+)\s*$/i) {
1191 my @newclonedids = split /\s+/, $2;
1192 my $newbugsneeded = scalar(@newclonedids);
1195 $bug_affected{$ref} = 1;
1197 $affected_packages{$data->{package}} = 1;
1198 if (length($data->{mergedwith})) {
1199 print {$transcript} "$gBug is marked as being merged with others. Use an existing clone.\n\n";
1203 &filelock("nextnumber.lock");
1204 open(N,"nextnumber") || die "nextnumber: read: $!";
1205 my $v=<N>; $v =~ s/\n$// || die "nextnumber bad format";
1206 my $firstref= $v+0; $v += $newbugsneeded;
1207 open(NN,">nextnumber"); print NN "$v\n"; close(NN);
1210 my $lastref = $firstref + $newbugsneeded - 1;
1212 if ($newbugsneeded == 1) {
1213 $action= "$gBug $origref cloned as bug $firstref.";
1215 $action= "$gBug $origref cloned as bugs $firstref-$lastref.";
1218 my $blocks = $data->{blocks};
1219 my $blockedby = $data->{blockedby};
1222 my $ohash = get_hashname($origref);
1223 my $clone = $firstref;
1224 @bug_affected{@newclonedids} = 1 x @newclonedids;
1225 for my $newclonedid (@newclonedids) {
1226 $clonebugs{$newclonedid} = $clone;
1228 my $hash = get_hashname($clone);
1229 copy("db-h/$ohash/$origref.log", "db-h/$hash/$clone.log");
1230 copy("db-h/$ohash/$origref.status", "db-h/$hash/$clone.status");
1231 copy("db-h/$ohash/$origref.summary", "db-h/$hash/$clone.summary");
1232 copy("db-h/$ohash/$origref.report", "db-h/$hash/$clone.report");
1233 &bughook('new', $clone, $data);
1235 # Update blocking info of bugs blocked by or blocking the
1237 foreach $ref (split ' ', $blocks) {
1239 $data->{blockedby} = manipset($data->{blockedby}, $clone, 1);
1242 foreach $ref (split ' ', $blockedby) {
1244 $data->{blocks} = manipset($data->{blocks}, $clone, 1);
1252 } elsif (m/^package\:?\s+(\S.*\S)?\s*$/i) {
1254 my @pkgs = split /\s+/, $1;
1255 if (scalar(@pkgs) > 0) {
1256 %limit_pkgs = map { ($_, 1) } @pkgs;
1257 print {$transcript} "Ignoring bugs not assigned to: " .
1258 join(" ", keys(%limit_pkgs)) . "\n\n";
1261 print {$transcript} "Not ignoring any bugs.\n\n";
1263 } elsif (m/^affects?\s+\#?(-?\d+)(?:\s+((?:[=+-])?)\s*(\S.*)?)?\s*$/i) {
1266 my $add_remove = $2 || '';
1267 my $packages = $3 || '';
1268 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1269 $bug_affected{$ref} = 1;
1271 affects(bug => $ref,
1272 transcript => $transcript,
1273 ($dl > 0 ? (debug => $transcript):()),
1274 requester => $header{from},
1275 request_addr => $controlrequestaddr,
1277 recipients => \%recipients,
1278 packages => [splitpackages($3)],
1279 ($add_remove eq '+'?(add => 1):()),
1280 ($add_remove eq '-'?(remove => 1):()),
1285 print {$transcript} "Failed to give $ref a summary: $@";
1288 } elsif (m/^summary\s+\#?(-?\d+)\s*(\d+|)\s*$/i) {
1291 my $summary_msg = length($2)?$2:undef;
1292 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1293 $bug_affected{$ref} = 1;
1295 summary(bug => $ref,
1296 transcript => $transcript,
1297 ($dl > 0 ? (debug => $transcript):()),
1298 requester => $header{from},
1299 request_addr => $controlrequestaddr,
1301 recipients => \%recipients,
1302 summary => $summary_msg,
1307 print {$transcript} "Failed to give $ref a summary: $@";
1310 } elsif (m/^owner\s+\#?(-?\d+)\s+((?:\S.*\S)|\!)\s*$/i) {
1313 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1315 if ($newowner eq '!') {
1316 $newowner = $replyto;
1318 $bug_affected{$ref} = 1;
1321 transcript => $transcript,
1322 ($dl > 0 ? (debug => $transcript):()),
1323 requester => $header{from},
1324 request_addr => $controlrequestaddr,
1326 recipients => \%recipients,
1332 print {$transcript} "Failed to mark $ref as having an owner: $@";
1334 } elsif (m/^noowner\s+\#?(-?\d+)\s*$/i) {
1337 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1338 $bug_affected{$ref} = 1;
1341 transcript => $transcript,
1342 ($dl > 0 ? (debug => $transcript):()),
1343 requester => $header{from},
1344 request_addr => $controlrequestaddr,
1346 recipients => \%recipients,
1352 print {$transcript} "Failed to mark $ref as not having an owner: $@";
1354 } elsif (m/^unarchive\s+#?(\d+)$/i) {
1357 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1358 $bug_affected{$ref} = 1;
1360 bug_unarchive(bug => $ref,
1361 transcript => $transcript,
1362 ($dl > 0 ? (debug => $transcript):()),
1363 affected_bugs => \%bug_affected,
1364 requester => $header{from},
1365 request_addr => $controlrequestaddr,
1367 recipients => \%recipients,
1373 } elsif (m/^archive\s+#?(\d+)$/i) {
1376 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1377 $bug_affected{$ref} = 1;
1379 bug_archive(bug => $ref,
1380 transcript => $transcript,
1381 ($dl > 0 ? (debug => $transcript):()),
1383 archive_unarchived => 0,
1384 affected_bugs => \%bug_affected,
1385 requester => $header{from},
1386 request_addr => $controlrequestaddr,
1388 recipients => \%recipients,
1395 print {$transcript} "Unknown command or malformed arguments to command.\n\n";
1397 if (++$unknowns >= 5) {
1398 print {$transcript} "Too many unknown commands, stopping here.\n\n";
1403 if ($procline>$#bodylines) {
1404 print {$transcript} ">\nEnd of message, stopping processing here.\n\n";
1406 if (!$ok && !$quickabort) {
1408 print {$transcript} "No commands successfully parsed; sending the help text(s).\n";
1410 print {$transcript} "\n";
1413 my @maintccs = determine_recipients(recipients => \%recipients,
1417 my $maintccs = 'Cc: '.join(",\n ",
1418 determine_recipients(recipients => \%recipients,
1424 $packagepr = "X-${gProject}-PR-Package: " . join(keys %affected_packages) . "\n" if keys %affected_packages;
1426 # Add Bcc's to subscribed bugs
1427 # now handled by Debbugs::Recipients
1428 #push @bcc, map {"bugs=$_\@$gListDomain"} keys %bug_affected;
1430 if (!defined $header{'subject'} || $header{'subject'} eq "") {
1431 $header{'subject'} = "your mail";
1434 # Error text here advertises how many errors there were
1435 my $error_text = $errors > 0 ? " (with $errors errors)":'';
1438 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1440 ${maintccs}Subject: Processed${error_text}: $header{'subject'}
1441 In-Reply-To: $header{'message-id'}
1444 References: $header{'message-id'}
1445 Message-ID: <handler.s.$nn.transcript\@$gEmailDomain>
1447 ${packagepr}X-$gProject-PR-Message: transcript
1449 ${transcript_scalar}Please contact me if you need assistance.
1452 (administrator, $gProject $gBugs database)
1455 my $repliedshow= join(', ',$replyto,
1456 determine_recipients(recipients => \%recipients,
1461 # -1 is the service.in log
1462 &filelock("lock/-1");
1463 open(AP,">>db-h/-1.log") || die "open db-h/-1.log: $!";
1465 "\2\n$repliedshow\n\5\n$reply\n\3\n".
1467 "<strong>Request received</strong> from <code>".
1468 html_escape($header{'from'})."</code>\n".
1469 "to <code>".html_escape($controlrequestaddr)."</code>\n".
1471 "\7\n",escape_log(@log),"\n\3\n") || die "writing db-h/-1.log: $!";
1472 close(AP) || die "open db-h/-1.log: $!";
1474 utime(time,time,"db-h");
1476 &sendmailmessage($reply,
1477 exists $header{'x-debbugs-no-ack'}?():$replyto,
1478 make_list(values %{{determine_recipients(recipients => \%recipients,
1484 unlink("incoming/P$nn") || die "unlinking incoming/P$nn: $!";
1486 sub sendmailmessage {
1487 my ($message,@recips) = @_;
1488 $message = "X-Loop: $gMaintainerEmail\n" . $message;
1489 send_mail_message(message => $message,
1490 recipients => \@recips,
1496 my ($template,$extra_var) = @_;
1498 my $variables = {config => \%config,
1499 defined($ref)?(ref => $ref):(),
1500 defined($data)?(data => $data):(),
1503 my $hole_var = {'&bugurl' =>
1505 'http://'.$config{cgi_domain}.'/'.
1506 Debbugs::CGI::bug_url($_[0]);
1509 return fill_in_template(template => $template,
1510 variables => $variables,
1511 hole_var => $hole_var,
1515 =head2 message_body_template
1517 message_body_template('mail/ack',{ref=>'foo'});
1519 Creates a message body using a template
1523 sub message_body_template{
1524 my ($template,$extra_var) = @_;
1526 my $body = fill_template($template,$extra_var);
1527 return fill_template('mail/message_body',
1536 &sendtxthelpraw("bug-maint-mailcontrol.txt","instructions for control\@$gEmailDomain")
1539 &sendtxthelpraw("bug-log-mailserver.txt","instructions for request\@$gEmailDomain");
1543 #sub unimplemented {
1544 # print {$transcript} "Sorry, command $_[0] not yet implemented.\n\n";
1546 our %checkmatch_values;
1548 my ($string,$mvarname,$svarvalue,@newmergelist) = @_;
1550 if (@newmergelist) {
1551 $mvarvalue = $checkmatch_values{$mvarname};
1552 print {$transcript} "D| checkmatch \`$string' /$mvarname/$mvarvalue/$svarvalue/\n"
1555 "Values for \`$string' don't match:\n".
1556 " #$newmergelist[0] has \`$mvarvalue';\n".
1557 " #$ref has \`$svarvalue'\n"
1558 if $mvarvalue ne $svarvalue;
1560 print {$transcript} "D| setupmatch \`$string' /$mvarname/$svarvalue/\n"
1562 $checkmatch_values{$mvarname} = $svarvalue;
1567 if (keys %limit_pkgs and not defined $limit_pkgs{$data->{package}}) {
1568 print {$transcript} "$gBug number $ref belongs to package $data->{package}, skipping.\n\n";
1580 my %h = map { $_ => 1 } split ' ', $list;
1587 return join ' ', sort keys %h;
1590 # High-level bug manipulation calls
1591 # Do announcements themselves
1593 # Possible calling sequences:
1594 # setbug (returns 0)
1596 # setbug (returns 1)
1597 # &transcript(something)
1600 # setbug (returns 1)
1601 # $action= (something)
1603 # (modify s_* variables)
1604 # } while (getnextbug);
1609 &dlen("nochangebug");
1610 $state eq 'single' || $state eq 'multiple' || die "$state ?";
1612 &endmerge if $manybugs;
1614 &dlex("nochangebug");
1618 our @thisbugmergelist;
1621 &dlen("setbug $ref");
1622 if ($ref =~ m/^-\d+/) {
1623 if (!defined $clonebugs{$ref}) {
1625 &dlex("setbug => noclone");
1628 $ref = $clonebugs{$ref};
1630 $state eq 'idle' || die "$state ?";
1633 &dlex("setbug => 0s");
1637 if (!&checkpkglimit) {
1642 @thisbugmergelist= split(/ /,$data->{mergedwith});
1643 if (!@thisbugmergelist) {
1648 &dlex("setbug => 1s");
1657 &dlex("setbug => 0mc");
1661 $state= 'multiple'; $sref=$ref;
1662 &dlex("setbug => 1m");
1667 &dlen("getnextbug");
1668 $state eq 'single' || $state eq 'multiple' || die "$state ?";
1670 if (!$manybugs || !@thisbugmergelist) {
1671 length($action) || die;
1672 print {$transcript} "$action\n$extramessage\n";
1673 &endmerge if $manybugs;
1675 &dlex("getnextbug => 0");
1678 $ref= shift(@thisbugmergelist);
1679 &getbug || die "bug $ref disappeared";
1681 &dlex("getnextbug => 1");
1685 # Low-level bug-manipulation calls
1686 # Do no announcements
1688 # getbug (returns 0)
1690 # getbug (returns 1)
1694 # $action= (something)
1695 # getbug (returns 1)
1697 # getbug (returns 1)
1699 # [getbug (returns 0)]
1700 # &transcript("$action\n\n")
1703 sub notfoundbug { print {$transcript} "$gBug number $ref not found. (Is it archived?)\n\n"; }
1704 sub foundbug { print {$transcript} "$gBug#$ref: $data->{subject}\n"; }
1708 $mergelowstate eq 'idle' || die "$mergelowstate ?";
1709 &filelock('lock/merge');
1710 $mergelowstate='locked';
1716 $mergelowstate eq 'locked' || die "$mergelowstate ?";
1718 $mergelowstate='idle';
1723 &dlen("getbug $ref");
1724 $lowstate eq 'idle' || die "$state ?";
1725 # Only use unmerged bugs here
1726 if (($data = &lockreadbug($ref,'db-h'))) {
1729 &dlex("getbug => 1");
1734 &dlex("getbug => 0");
1740 $lowstate eq 'open' || die "$state ?";
1747 &dlen("savebug $ref");
1748 $lowstate eq 'open' || die "$lowstate ?";
1749 length($action) || die;
1750 $ref == $sref || die "read $sref but saving $ref ?";
1751 append_action_to_log(bug => $ref,
1753 requester => $header{from},
1754 request_addr => $controlrequestaddr,
1758 unlockwritebug($ref, $data);
1765 print {$transcript} "C> @_ ($state $lowstate $mergelowstate)\n";
1770 print {$transcript} "R> @_ ($state $lowstate $mergelowstate)\n";
1777 my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
1778 $url =~ s/([<>&"])/\&$saniarray{$1};/g;
1784 print {$transcript} "\n";
1790 print {$transcript} "\n";
1796 sub sendtxthelpraw {
1797 my ($relpath,$description) = @_;
1799 open(D,"$gDocDir/$relpath") || die "open doc file $relpath: $!";
1800 while(<D>) { $doc.=$_; }
1802 print {$transcript} "Sending $description in separate message.\n";
1803 &sendmailmessage(<<END.$doc,$replyto);
1804 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1806 Subject: $gProject $gBug help: $description
1807 References: $header{'message-id'}
1808 In-Reply-To: $header{'message-id'}
1809 Message-ID: <handler.s.$nn.help.$midix\@$gEmailDomain>
1811 X-$gProject-PR-Message: doc-text $relpath
1817 sub sendlynxdocraw {
1818 my ($relpath,$description) = @_;
1820 open(L,"lynx -nolist -dump http://$gCGIDomain/\Q$relpath\E 2>&1 |") || die "fork for lynx: $!";
1821 while(<L>) { $doc.=$_; }
1823 if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
1824 print {$transcript} "Information ($description) is not available -\n".
1825 "perhaps the $gBug does not exist or is not on the WWW yet.\n";
1828 print {$transcript} "Error getting $description (code $? $!):\n$doc\n";
1830 print {$transcript} "Sending $description.\n";
1831 &sendmailmessage(<<END.$doc,$replyto);
1832 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1834 Subject: $gProject $gBugs information: $description
1835 References: $header{'message-id'}
1836 In-Reply-To: $header{'message-id'}
1837 Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
1839 X-$gProject-PR-Message: doc-html $relpath
1848 my ($wherefrom,$path,$description) = @_;
1849 if ($wherefrom eq "ftp.d.o") {
1850 $doc = `lynx -nolist -dump http://ftp.debian.org/debian/indices/$path.gz 2>&1 | gunzip -cf` or die "fork for lynx/gunzip: $!";
1852 if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
1853 print {$transcript} "$description is not available.\n";
1856 print {$transcript} "Error getting $description (code $? $!):\n$doc\n";
1859 } elsif ($wherefrom eq "local") {
1861 $doc = do { local $/; <P> };
1864 print {$transcript} "internal errror: info files location unknown.\n";
1867 print {$transcript} "Sending $description.\n";
1868 &sendmailmessage(<<END.$doc,$replyto);
1869 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1871 Subject: $gProject $gBugs information: $description
1872 References: $header{'message-id'}
1873 In-Reply-To: $header{'message-id'}
1874 Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
1876 X-$gProject-PR-Message: getinfo
1878 $description follows:
1882 print {$transcript} "\n";