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+$//;
180 print {$transcript} "> $_\n";
183 if (m/^stop\s*$/i || m/^quit\s*$/i || m/^--\s*$/ || m/^thank(?:s|\s*you)?\s*$/i || m/^kthxbye\s*$/i) {
184 print {$transcript} "Stopping processing here.\n\n";
186 } elsif (m/^debug\s+(\d+)$/i && $1 >= 0 && $1 <= 1000) {
188 print {$transcript} "Debug level $dl.\n\n";
189 } elsif (m/^(send|get)\s+\#?(\d{2,})$/i) {
191 &sendlynxdoc("bugreport.cgi?bug=$ref","logs for $gBug#$ref");
192 } elsif (m/^send-detail\s+\#?(\d{2,})$/i) {
194 &sendlynxdoc("bugreport.cgi?bug=$ref&boring=yes",
195 "detailed logs for $gBug#$ref");
196 } elsif (m/^index(\s+full)?$/i) {
197 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
199 $ok++; # well, it's not really ok, but it fixes #81224 :)
200 } elsif (m/^index-summary\s+by-package$/i) {
201 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
203 $ok++; # well, it's not really ok, but it fixes #81224 :)
204 } elsif (m/^index-summary(\s+by-number)?$/i) {
205 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
207 $ok++; # well, it's not really ok, but it fixes #81224 :)
208 } elsif (m/^index(\s+|-)pack(age)?s?$/i) {
209 &sendlynxdoc("pkgindex.cgi?indexon=pkg",'index of packages');
210 } elsif (m/^index(\s+|-)maints?$/i) {
211 &sendlynxdoc("pkgindex.cgi?indexon=maint",'index of maintainers');
212 } elsif (m/^index(\s+|-)maint\s+(\S+)$/i) {
214 &sendlynxdoc("pkgreport.cgi?maint=" . urlsanit($maint),
215 "$gBug list for maintainer \`$maint'");
217 } elsif (m/^index(\s+|-)pack(age)?s?\s+(\S.*\S)$/i) {
219 &sendlynxdoc("pkgreport.cgi?pkg=" . urlsanit($package),
220 "$gBug list for package $package");
222 } elsif (m/^send-unmatched(\s+this|\s+-?0)?$/i) {
223 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
225 $ok++; # well, it's not really ok, but it fixes #81224 :)
226 } elsif (m/^send-unmatched\s+(last|-1)$/i) {
227 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
229 $ok++; # well, it's not really ok, but it fixes #81224 :)
230 } elsif (m/^send-unmatched\s+(old|-2)$/i) {
231 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
233 $ok++; # well, it's not really ok, but it fixes #81224 :)
234 } elsif (m/^getinfo\s+([\w.-]+)$/i) {
235 # the following is basically a Debian-specific kludge, but who cares
237 if ($req =~ /^maintainers$/i && -f "$gConfigDir/Maintainers") {
238 &sendinfo("local", "$gConfigDir/Maintainers", "Maintainers file");
239 } elsif ($req =~ /^override\.(\w+)\.([\w.-]+)$/i) {
241 &sendinfo("ftp.d.o", "$req", "override file for $2 part of $1 distribution");
242 } elsif ($req =~ /^pseudo-packages\.(description|maintainers)$/i && -f "$gConfigDir/$req") {
243 &sendinfo("local", "$gConfigDir/$req", "$req file");
245 print {$transcript} "Info file $req does not exist.\n\n";
247 } elsif (m/^help/i) {
249 print {$transcript} "\n";
251 } elsif (m/^refcard/i) {
252 &sendtxthelp("bug-mailserver-refcard.txt","mail servers' reference card");
253 } elsif (m/^subscribe/i) {
254 print {$transcript} <<END;
255 There is no $gProject $gBug mailing list. If you wish to review bug reports
256 please do so via http://$gWebDomain/ or ask this mail server
258 soon: MAILINGLISTS_TEXT
260 } elsif (m/^unsubscribe/i) {
261 print {$transcript} <<END;
262 soon: UNSUBSCRIBE_TEXT
263 soon: MAILINGLISTS_TEXT
265 } elsif (m/^user\s+(\S+)\s*$/i) {
267 if (Debbugs::User::is_valid_user($newuser)) {
268 my $olduser = ($user ne "" ? " (was $user)" : "");
269 print {$transcript} "Setting user to $newuser$olduser.\n";
273 print {$transcript} "Selected user id ($newuser) invalid, sorry\n";
278 } elsif (m/^usercategory\s+(\S+)(\s+\[hidden\])?\s*$/i) {
281 my $hidden = ($2 ne "");
288 print {$transcript} "No valid user selected\n";
292 if (not $indicated_user and defined $user) {
293 print {$transcript} "User is $user\n";
297 while (++$procline <= $#bodylines) {
298 unless ($bodylines[$procline] =~ m/^\s*([*+])\s*(\S.*)$/) {
302 print {$transcript} "> $bodylines[$procline]\n";
304 my ($o, $txt) = ($1, $2);
305 if ($#cats == -1 && $o eq "+") {
306 print {$transcript} "User defined category specification must start with a category name. Skipping.\n\n";
312 unless (ref($cats[-1]) eq "HASH") {
313 $cats[-1] = { "nam" => $cats[-1],
314 "pri" => [], "ttl" => [] };
317 my ($desc, $ord, $op);
318 if ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?\]\s*$/) {
319 $desc = $1; $ord = $3; $op = "";
320 } elsif ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?(\S+)\]\s*$/) {
321 $desc = $1; $ord = $3; $op = $4;
322 } elsif ($txt =~ m/^([^[\s]+)\s*$/) {
323 $desc = ""; $op = $1;
325 print {$transcript} "Unrecognised syntax for category section. Skipping.\n\n";
330 $ord = 999 unless defined $ord;
333 push @{$cats[-1]->{"pri"}}, $prefix . $op;
334 push @{$cats[-1]->{"ttl"}}, $desc;
335 push @ords, "$ord $catsec";
337 $cats[-1]->{"def"} = $desc;
338 push @ords, "$ord DEF";
341 @ords = sort { my ($a1, $a2, $b1, $b2) = split / /, "$a $b";
342 $a1 <=> $b1 || $a2 <=> $b2; } @ords;
343 $cats[-1]->{"ord"} = [map { m/^.* (\S+)/; $1 eq "DEF" ? $catsec + 1 : $1 } @ords];
344 } elsif ($o eq "*") {
347 if ($txt =~ m/^(.*\S)(\s*\[(\S+)\])\s*$/) {
348 $name = $1; $prefix = $3;
350 $name = $txt; $prefix = "";
355 # XXX: got @cats, now do something with it
356 my $u = Debbugs::User::get_user($user);
358 print {$transcript} "Added usercategory $catname.\n\n";
359 $u->{"categories"}->{$catname} = [ @cats ];
361 push @{$u->{visible_cats}},$catname;
364 print {$transcript} "Removed usercategory $catname.\n\n";
365 delete $u->{"categories"}->{$catname};
366 @{$u->{visible_cats}} = grep {$_ ne $catname} @{$u->{visible_cats}};
369 } elsif (m/^usertags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
372 my $addsubcode = $3 || "+";
374 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
375 $ref = $clonebugs{$ref};
378 print {$transcript} "No valid user selected\n";
382 if (not $indicated_user and defined $user) {
383 print {$transcript} "User is $user\n";
388 Debbugs::User::read_usertags(\%ut, $user);
389 my @oldtags = (); my @newtags = (); my @badtags = ();
391 if (defined $tags and length $tags) {
392 for my $t (split /[,\s]+/, $tags) {
393 if ($t =~ m/^[a-zA-Z0-9.+\@-]+$/) {
401 print {$transcript} "Ignoring illegal tag/s: ".join(', ', @badtags).".\nPlease use only alphanumerics, at, dot, plus and dash.\n";
404 for my $t (keys %chtags) {
405 $ut{$t} = [] unless defined $ut{$t};
407 for my $t (keys %ut) {
408 my %res = map { ($_, 1) } @{$ut{$t}};
409 push @oldtags, $t if defined $res{$ref};
410 my $addop = ($addsubcode eq "+" or $addsubcode eq "=");
411 my $del = (defined $chtags{$t} ? $addsubcode eq "-"
412 : $addsubcode eq "=");
413 $res{$ref} = 1 if ($addop && defined $chtags{$t});
414 delete $res{$ref} if ($del);
415 push @newtags, $t if defined $res{$ref};
416 $ut{$t} = [ sort { $a <=> $b } (keys %res) ];
419 print {$transcript} "There were no usertags set.\n";
421 print {$transcript} "Usertags were: " . join(" ", @oldtags) . ".\n";
423 print {$transcript} "Usertags are now: " . join(" ", @newtags) . ".\n";
424 Debbugs::User::write_usertags(\%ut, $user);
426 } elsif (!$control) {
427 print {$transcript} <<END;
428 Unknown command or malformed arguments to command.
429 (Use control\@$gEmailDomain to manipulate reports.)
433 if (++$unknowns >= 3) {
434 print {$transcript} "Too many unknown commands, stopping here.\n\n";
437 #### "developer only" ones start here
438 } elsif (m/^close\s+\#?(-?\d+)(?:\s+(\d.*))?$/i) {
441 $bug_affected{$ref}=1;
444 print {$transcript} "'close' is deprecated; see http://$gWebDomain/Developer$gHTMLSuffix#closing.\n";
445 if (length($data->{done}) and not defined($version)) {
446 print {$transcript} "$gBug is already closed, cannot re-close.\n\n";
451 "marked as fixed in version $version" :
453 ", send any further explanations to $data->{originator}";
455 $affected_packages{$data->{package}} = 1;
456 add_recipients(data => $data,
457 recipients => \%recipients,
458 actions_taken => {done => 1},
459 transcript => $transcript,
460 ($dl > 0 ? (debug => $transcript):()),
462 $data->{done}= $replyto;
463 my @keywords= split ' ', $data->{keywords};
464 my $extramessage = '';
465 if (grep $_ eq 'pending', @keywords) {
466 $extramessage= "Removed pending tag.\n";
467 $data->{keywords}= join ' ', grep $_ ne 'pending',
470 addfixedversions($data, $data->{package}, $version, 'binary');
473 From: $gMaintainerEmail ($gProject $gBug Tracking System)
474 To: $data->{originator}
475 Subject: $gBug#$ref acknowledged by developer
477 References: $header{'message-id'} $data->{msgid}
478 In-Reply-To: $data->{msgid}
479 Message-ID: <handler.$ref.$nn.notifdonectrl.$midix\@$gEmailDomain>
480 Reply-To: $ref\@$gEmailDomain
481 X-$gProject-PR-Message: they-closed-control $ref
483 This is an automatic notification regarding your $gBug report
484 #$ref: $data->{subject},
485 which was filed against the $data->{package} package.
487 It has been marked as closed by one of the developers, namely
490 You should be hearing from them with a substantive response shortly,
491 in case you haven't already. If not, please contact them directly.
494 (administrator, $gProject $gBugs database)
497 &sendmailmessage($message,$data->{originator});
498 } while (&getnextbug);
501 } elsif (m/^reassign\s+\#?(-?\d+)\s+(\S+)(?:\s+(\d.*))?$/i) {
505 $bug_affected{$ref}=1;
507 $newpackage =~ y/A-Z/a-z/;
509 if (length($data->{package})) {
510 $action= "$gBug reassigned from package \`$data->{package}'".
511 " to \`$newpackage'.";
513 $action= "$gBug assigned to package \`$newpackage'.";
516 $affected_packages{$data->{package}} = 1;
517 add_recipients(data => $data,
518 recipients => \%recipients,
519 transcript => $transcript,
520 ($dl > 0 ? (debug => $transcript):()),
522 $data->{package}= $newpackage;
523 $data->{found_versions}= [];
524 $data->{fixed_versions}= [];
525 # TODO: what if $newpackage is a source package?
526 addfoundversions($data, $data->{package}, $version, 'binary');
527 add_recipients(data => $data,
528 recipients => \%recipients,
529 transcript => $transcript,
530 ($dl > 0 ? (debug => $transcript):()),
532 } while (&getnextbug);
534 } elsif (m/^reopen\s+\#?(-?\d+)$/i ? ($noriginator='', 1) :
535 m/^reopen\s+\#?(-?\d+)\s+\=$/i ? ($noriginator='', 1) :
536 m/^reopen\s+\#?(-?\d+)\s+\!$/i ? ($noriginator=$replyto, 1) :
537 m/^reopen\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($noriginator=$2, 1) : 0) {
540 $bug_affected{$ref}=1;
542 if (@{$data->{fixed_versions}}) {
543 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";
545 if (!length($data->{done})) {
546 print {$transcript} "$gBug is already open, cannot reopen.\n\n";
550 $noriginator eq '' ? "$gBug reopened, originator not changed." :
551 "$gBug reopened, originator set to $noriginator.";
553 $affected_packages{$data->{package}} = 1;
554 add_recipients(data => $data,
555 recipients => \%recipients,
556 transcript => $transcript,
557 ($dl > 0 ? (debug => $transcript):()),
559 $data->{originator}= $noriginator eq '' ? $data->{originator} : $noriginator;
560 $data->{fixed_versions}= [];
562 } while (&getnextbug);
565 } elsif (m{^found\s+\#?(-?\d+)
566 (?:\s+((?:$config{package_name_re}\/)?
567 $config{package_version_re}))?$}ix) {
572 if (!length($data->{done}) and not defined($version)) {
573 print {$transcript} "$gBug is already open, cannot reopen.\n\n";
579 "$gBug marked as found in version $version." :
582 $affected_packages{$data->{package}} = 1;
583 add_recipients(data => $data,
584 recipients => \%recipients,
585 transcript => $transcript,
586 ($dl > 0 ? (debug => $transcript):()),
588 # The 'done' field gets a bit weird with version
589 # tracking, because a bug may be closed by multiple
590 # people in different branches. Until we have something
591 # more flexible, we set it every time a bug is fixed,
592 # and clear it when a bug is found in a version greater
593 # than any version in which the bug is fixed or when
594 # a bug is found and there is no fixed version
595 if (defined $version) {
596 my ($version_only) = $version =~ m{([^/]+)$};
597 addfoundversions($data, $data->{package}, $version, 'binary');
598 my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
599 map {s{.+/}{}; $_;} @{$data->{fixed_versions}};
600 if (not @fixed_order or (Debbugs::Versions::Dpkg::vercmp($version_only,$fixed_order[-1]) >= 0)) {
601 $action = "$gBug marked as found in version $version and reopened."
602 if length $data->{done};
606 # Versionless found; assume old-style "not fixed at
608 $data->{fixed_versions} = [];
611 } while (&getnextbug);
614 } elsif (m[^notfound\s+\#?(-?\d+)\s+
615 ((?:$config{package_name_re}\/)?
621 $action= "$gBug no longer marked as found in version $version.";
622 if (length($data->{done})) {
623 $extramessage= "(By the way, this $gBug is currently marked as done.)\n";
626 $affected_packages{$data->{package}} = 1;
627 add_recipients(data => $data,
628 recipients => \%recipients,
629 transcript => $transcript,
630 ($dl > 0 ? (debug => $transcript):()),
632 removefoundversions($data, $data->{package}, $version, 'binary');
633 } while (&getnextbug);
636 elsif (m[^fixed\s+\#?(-?\d+)\s+
637 ((?:$config{package_name_re}\/)?
638 $config{package_version_re})\s*$]ix) {
645 "$gBug marked as fixed in version $version." :
648 $affected_packages{$data->{package}} = 1;
649 add_recipients(data => $data,
650 recipients => \%recipients,
651 transcript => $transcript,
652 ($dl > 0 ? (debug => $transcript):()),
654 addfixedversions($data, $data->{package}, $version, 'binary');
655 } while (&getnextbug);
658 elsif (m[^notfixed\s+\#?(-?\d+)\s+
659 ((?:$config{package_name_re}\/)?
667 "$gBug no longer marked as fixed in version $version." :
670 $affected_packages{$data->{package}} = 1;
671 add_recipients(data => $data,
672 recipients => \%recipients,
673 transcript => $transcript,
674 ($dl > 0 ? (debug => $transcript):()),
676 removefixedversions($data, $data->{package}, $version, 'binary');
677 } while (&getnextbug);
680 elsif (m/^submitter\s+\#?(-?\d+)\s+\!$/i ? ($newsubmitter=$replyto, 1) :
681 m/^submitter\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($newsubmitter=$2, 1) : 0) {
684 $bug_affected{$ref}=1;
685 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
686 $ref = $clonebugs{$ref};
688 if (not Mail::RFC822::Address::valid($newsubmitter)) {
689 transcript("$newsubmitter is not a valid e-mail address; not changing submitter\n");
693 if (&checkpkglimit) {
695 $affected_packages{$data->{package}} = 1;
696 add_recipients(data => $data,
697 recipients => \%recipients,
698 transcript => $transcript,
699 ($dl > 0 ? (debug => $transcript):()),
701 $oldsubmitter= $data->{originator};
702 $data->{originator}= $newsubmitter;
703 $action= "Changed $gBug submitter from $oldsubmitter to $newsubmitter.";
705 print {$transcript} "$action\n";
706 if (length($data->{done})) {
707 print {$transcript} "(By the way, that $gBug is currently marked as done.)\n";
709 print {$transcript} "\n";
711 From: $gMaintainerEmail ($gProject $gBug Tracking System)
713 Subject: $gBug#$ref submitter address changed
715 References: $header{'message-id'} $data->{msgid}
716 In-Reply-To: $data->{msgid}
717 Message-ID: <handler.$ref.$nn.newsubmitter.$midix\@$gEmailDomain>
718 Reply-To: $ref\@$gEmailDomain
719 X-$gProject-PR-Message: submitter-changed $ref
721 The submitter address recorded for your $gBug report
722 #$ref: $data->{subject}
725 The old submitter address for this report was
727 The new submitter address is
730 This change was made by
732 If it was incorrect, please contact them directly.
735 (administrator, $gProject $gBugs database)
738 &sendmailmessage($message,$oldsubmitter);
745 } elsif (m/^forwarded\s+\#?(-?\d+)\s+(\S.*\S)$/i) {
749 $bug_affected{$ref}=1;
751 if (length($data->{forwarded})) {
752 $action= "Forwarded-to-address changed from $data->{forwarded} to $whereto.";
754 $action= "Noted your statement that $gBug has been forwarded to $whereto.";
756 if (length($data->{done})) {
757 $extramessage= "(By the way, this $gBug is currently marked as done.)\n";
760 $affected_packages{$data->{package}} = 1;
761 add_recipients(data => $data,
762 recipients => \%recipients,
763 actions_taken => {forwarded => 1},
764 transcript => $transcript,
765 ($dl > 0 ? (debug => $transcript):()),
767 $data->{forwarded}= $whereto;
768 } while (&getnextbug);
770 } elsif (m/^notforwarded\s+\#?(-?\d+)$/i) {
773 $bug_affected{$ref}=1;
775 if (!length($data->{forwarded})) {
776 print {$transcript} "$gBug is not marked as having been forwarded.\n\n";
779 $action= "Removed annotation that $gBug had been forwarded to $data->{forwarded}.";
781 $affected_packages{$data->{package}} = 1;
782 add_recipients(data => $data,
783 recipients => \%recipients,
784 transcript => $transcript,
785 ($dl > 0 ? (debug => $transcript):()),
787 $data->{forwarded}= '';
788 } while (&getnextbug);
791 } elsif (m/^severity\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i ||
792 m/^priority\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i) {
795 $bug_affected{$ref}=1;
797 if (!grep($_ eq $newseverity, @gSeverityList, "$gDefaultSeverity")) {
798 print {$transcript} "Severity level \`$newseverity' is not known.\n".
799 "Recognized are: $gShowSeverities.\n\n";
801 } elsif (exists $gObsoleteSeverities{$newseverity}) {
802 print {$transcript} "Severity level \`$newseverity' is obsolete. " .
803 "Use $gObsoleteSeverities{$newseverity} instead.\n\n";
806 my $printseverity= $data->{severity};
807 $printseverity= "$gDefaultSeverity" if $printseverity eq '';
808 $action= "Severity set to \`$newseverity' from \`$printseverity'";
810 $affected_packages{$data->{package}} = 1;
811 add_recipients(data => $data,
812 recipients => \%recipients,
813 transcript => $transcript,
814 ($dl > 0 ? (debug => $transcript):()),
816 if (defined $gStrongList and isstrongseverity($newseverity)) {
817 addbcc("$gStrongList\@$gListDomain");
819 $data->{severity}= $newseverity;
820 } while (&getnextbug);
822 } elsif (m/^tags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
827 $bug_affected{$ref}=1;
829 if (defined $addsubcode) {
830 $addsub = "sub" if ($addsubcode eq "-");
831 $addsub = "add" if ($addsubcode eq "+");
832 $addsub = "set" if ($addsubcode eq "=");
836 foreach my $t (split /[\s,]+/, $tags) {
837 if (!grep($_ eq $t, @gTags)) {
844 print {$transcript} "Unknown tag/s: ".join(', ', @badtags).".\n".
845 "Recognized are: ".join(' ', @gTags).".\n\n";
849 if ($data->{keywords} eq '') {
850 print {$transcript} "There were no tags set.\n";
852 print {$transcript} "Tags were: $data->{keywords}\n";
854 if ($addsub eq "set") {
855 $action= "Tags set to: " . join(", ", @okaytags);
856 } elsif ($addsub eq "add") {
857 $action= "Tags added: " . join(", ", @okaytags);
858 } elsif ($addsub eq "sub") {
859 $action= "Tags removed: " . join(", ", @okaytags);
862 $affected_packages{$data->{package}} = 1;
863 add_recipients(data => $data,
864 recipients => \%recipients,
865 transcript => $transcript,
866 ($dl > 0 ? (debug => $transcript):()),
868 $data->{keywords} = '' if ($addsub eq "set");
869 # Allow removing obsolete tags.
870 if ($addsub eq "sub") {
871 foreach my $t (@badtags) {
872 $data->{keywords} = join ' ', grep $_ ne $t,
873 split ' ', $data->{keywords};
876 # Now process all other additions and subtractions.
877 foreach my $t (@okaytags) {
878 $data->{keywords} = join ' ', grep $_ ne $t,
879 split ' ', $data->{keywords};
880 $data->{keywords} = "$t $data->{keywords}" unless($addsub eq "sub");
882 $data->{keywords} =~ s/\s*$//;
883 } while (&getnextbug);
885 } elsif (m/^(un)?block\s+\#?(-?\d+)\s+(by|with)\s+(\S.*)?$/i) {
887 my $bugnum = $2; my $blockers = $4;
889 $addsub = "sub" if (defined $1 and $1 eq "un");
890 if ($bugnum =~ m/^-\d+$/ && defined $clonebugs{$bugnum}) {
891 $bugnum = $clonebugs{$bugnum};
896 foreach my $b (split /[\s,]+/, $blockers) {
900 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
901 $ref = $clonebugs{$ref};
905 push @okayblockers, $ref;
907 # add to the list all bugs that are merged with $b,
908 # because all of their data must be kept in sync
909 my @thisbugmergelist= split(/ /,$data->{mergedwith});
912 foreach $ref (@thisbugmergelist) {
914 push @okayblockers, $ref;
921 push @badblockers, $ref;
925 push @badblockers, $b;
929 print {$transcript} "Unknown blocking bug/s: ".join(', ', @badblockers).".\n";
935 if ($data->{blockedby} eq '') {
936 print {$transcript} "Was not blocked by any bugs.\n";
938 print {$transcript} "Was blocked by: $data->{blockedby}\n";
940 if ($addsub eq "set") {
941 $action= "Blocking bugs of $bugnum set to: " . join(", ", @okayblockers);
942 } elsif ($addsub eq "add") {
943 $action= "Blocking bugs of $bugnum added: " . join(", ", @okayblockers);
944 } elsif ($addsub eq "sub") {
945 $action= "Blocking bugs of $bugnum removed: " . join(", ", @okayblockers);
950 $affected_packages{$data->{package}} = 1;
951 add_recipients(data => $data,
952 recipients => \%recipients,
953 transcript => $transcript,
954 ($dl > 0 ? (debug => $transcript):()),
956 my @oldblockerlist = split ' ', $data->{blockedby};
957 $data->{blockedby} = '' if ($addsub eq "set");
958 foreach my $b (@okayblockers) {
959 $data->{blockedby} = manipset($data->{blockedby}, $b,
963 foreach my $b (@oldblockerlist) {
964 if (! grep { $_ eq $b } split ' ', $data->{blockedby}) {
965 push @{$removedblocks{$b}}, $ref;
968 foreach my $b (split ' ', $data->{blockedby}) {
969 if (! grep { $_ eq $b } @oldblockerlist) {
970 push @{$addedblocks{$b}}, $ref;
973 } while (&getnextbug);
975 # Now that the blockedby data is updated, change blocks data
976 # to match the changes.
977 foreach $ref (keys %addedblocks) {
979 foreach my $b (@{$addedblocks{$ref}}) {
980 $data->{blocks} = manipset($data->{blocks}, $b, 1);
985 foreach $ref (keys %removedblocks) {
987 foreach my $b (@{$removedblocks{$ref}}) {
988 $data->{blocks} = manipset($data->{blocks}, $b, 0);
994 } elsif (m/^retitle\s+\#?(-?\d+)\s+(\S.*\S)\s*$/i) {
996 $ref= $1; my $newtitle= $2;
997 $bug_affected{$ref}=1;
998 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
999 $ref = $clonebugs{$ref};
1002 if (&checkpkglimit) {
1004 $affected_packages{$data->{package}} = 1;
1005 add_recipients(data => $data,
1006 recipients => \%recipients,
1007 transcript => $transcript,
1008 ($dl > 0 ? (debug => $transcript):()),
1010 my $oldtitle = $data->{subject};
1011 $data->{subject}= $newtitle;
1012 $action= "Changed $gBug title to `$newtitle' from `$oldtitle'.";
1014 print {$transcript} "$action\n";
1015 if (length($data->{done})) {
1016 print {$transcript} "(By the way, that $gBug is currently marked as done.)\n";
1018 print {$transcript} "\n";
1025 } elsif (m/^unmerge\s+\#?(-?\d+)$/i) {
1028 $bug_affected{$ref} = 1;
1030 if (!length($data->{mergedwith})) {
1031 print {$transcript} "$gBug is not marked as being merged with any others.\n\n";
1034 $mergelowstate eq 'locked' || die "$mergelowstate ?";
1035 $action= "Disconnected #$ref from all other report(s).";
1036 my @newmergelist= split(/ /,$data->{mergedwith});
1038 @bug_affected{@newmergelist} = 1 x @newmergelist;
1040 $affected_packages{$data->{package}} = 1;
1041 add_recipients(data => $data,
1042 recipients => \%recipients,
1043 transcript => $transcript,
1044 ($dl > 0 ? (debug => $transcript):()),
1046 $data->{mergedwith}= ($ref == $discref) ? ''
1047 : join(' ',grep($_ ne $ref,@newmergelist));
1048 } while (&getnextbug);
1051 } elsif (m/^merge\s+#?(-?\d+(\s+#?-?\d+)+)\s*$/i) {
1053 my @tomerge= sort { $a <=> $b } split(/\s+#?/,$1);
1054 my @newmergelist= ();
1059 while (defined($ref= shift(@tomerge))) {
1060 print {$transcript} "D| checking merge $ref\n" if $dl;
1062 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
1063 $ref = $clonebugs{$ref};
1065 next if grep($_ == $ref,@newmergelist);
1066 if (!&getbug) { ¬foundbug; @newmergelist=(); last }
1067 if (!&checkpkglimit) { &cancelbug; @newmergelist=(); last; }
1069 print {$transcript} "D| adding $ref ($data->{mergedwith})\n" if $dl;
1071 &checkmatch('package','m_package',$data->{package},@newmergelist);
1072 &checkmatch('forwarded addr','m_forwarded',$data->{forwarded},@newmergelist);
1073 $data->{severity} = '$gDefaultSeverity' if $data->{severity} eq '';
1074 &checkmatch('severity','m_severity',$data->{severity},@newmergelist);
1075 &checkmatch('blocks','m_blocks',$data->{blocks},@newmergelist);
1076 &checkmatch('blocked-by','m_blockedby',$data->{blockedby},@newmergelist);
1077 &checkmatch('done mark','m_done',length($data->{done}) ? 'done' : 'open',@newmergelist);
1078 &checkmatch('owner','m_owner',$data->{owner},@newmergelist);
1079 &checkmatch('summary','m_summary',$data->{summary},@newmergelist);
1080 &checkmatch('affects','m_affects',$data->{affects},@newmergelist);
1081 foreach my $t (split /\s+/, $data->{keywords}) { $tags{$t} = 1; }
1082 foreach my $f (@{$data->{found_versions}}) { $found{$f} = 1; }
1083 foreach my $f (@{$data->{fixed_versions}}) { $fixed{$f} = 1; }
1084 if (length($mismatch)) {
1085 print {$transcript} "Mismatch - only $gBugs in same state can be merged:\n".
1088 &cancelbug; @newmergelist=(); last;
1090 push(@newmergelist,$ref);
1091 push(@tomerge,split(/ /,$data->{mergedwith}));
1094 if (@newmergelist) {
1095 @newmergelist= sort { $a <=> $b } @newmergelist;
1096 $action= "Merged @newmergelist.";
1097 delete @fixed{keys %found};
1098 for $ref (@newmergelist) {
1099 &getbug || die "huh ? $gBug $ref disappeared during merge";
1100 $affected_packages{$data->{package}} = 1;
1101 add_recipients(data => $data,
1102 recipients => \%recipients,
1103 transcript => $transcript,
1104 ($dl > 0 ? (debug => $transcript):()),
1106 @bug_affected{@newmergelist} = 1 x @newmergelist;
1107 $data->{mergedwith}= join(' ',grep($_ != $ref,@newmergelist));
1108 $data->{keywords}= join(' ', keys %tags);
1109 $data->{found_versions}= [sort keys %found];
1110 $data->{fixed_versions}= [sort keys %fixed];
1113 print {$transcript} "$action\n\n";
1116 } elsif (m/^forcemerge\s+\#?(-?\d+(?:\s+\#?-?\d+)+)\s*$/i) {
1118 my @temp = split /\s+\#?/,$1;
1119 my $master_bug = shift @temp;
1120 my $master_bug_data;
1121 my @tomerge = sort { $a <=> $b } @temp;
1122 unshift @tomerge,$master_bug;
1123 print {$transcript} "D| force merging ".join(',',@tomerge)."\n" if $dl;
1124 my @newmergelist= ();
1128 # Here we try to do the right thing.
1129 # First, if the bugs are in the same package, we merge all of the found, fixed, and tags.
1130 # If not, we discard the found and fixed.
1131 # Everything else we set to the values of the first bug.
1133 while (defined($ref= shift(@tomerge))) {
1134 print {$transcript} "D| checking merge $ref\n" if $dl;
1136 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
1137 $ref = $clonebugs{$ref};
1139 next if grep($_ == $ref,@newmergelist);
1140 if (!&getbug) { ¬foundbug; @newmergelist=(); last }
1141 if (!&checkpkglimit) { &cancelbug; @newmergelist=(); last; }
1143 print {$transcript} "D| adding $ref ($data->{mergedwith})\n" if $dl;
1144 $master_bug_data = $data if not defined $master_bug_data;
1145 if ($data->{package} ne $master_bug_data->{package}) {
1146 print {$transcript} "Mismatch - only $gBugs in the same package can be forcibly merged:\n".
1147 "$gBug $ref is not in the same package as $master_bug\n";
1149 &cancelbug; @newmergelist=(); last;
1151 for my $t (split /\s+/,$data->{keywords}) {
1154 @found{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1155 @fixed{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1156 push(@newmergelist,$ref);
1157 push(@tomerge,split(/ /,$data->{mergedwith}));
1160 if (@newmergelist) {
1161 @newmergelist= sort { $a <=> $b } @newmergelist;
1162 $action= "Forcibly Merged @newmergelist.";
1163 delete @fixed{keys %found};
1164 for $ref (@newmergelist) {
1165 &getbug || die "huh ? $gBug $ref disappeared during merge";
1166 $affected_packages{$data->{package}} = 1;
1167 add_recipients(data => $data,
1168 recipients => \%recipients,
1169 transcript => $transcript,
1170 ($dl > 0 ? (debug => $transcript):()),
1172 @bug_affected{@newmergelist} = 1 x @newmergelist;
1173 $data->{mergedwith}= join(' ',grep($_ != $ref,@newmergelist));
1174 $data->{keywords}= join(' ', keys %tags);
1175 $data->{found_versions}= [sort keys %found];
1176 $data->{fixed_versions}= [sort keys %fixed];
1177 my @field_list = qw(forwarded package severity blocks blockedby owner done affects summary);
1178 @{$data}{@field_list} = @{$master_bug_data}{@field_list};
1181 print {$transcript} "$action\n\n";
1184 } elsif (m/^clone\s+#?(\d+)\s+((-\d+\s+)*-\d+)\s*$/i) {
1188 my @newclonedids = split /\s+/, $2;
1189 my $newbugsneeded = scalar(@newclonedids);
1192 $bug_affected{$ref} = 1;
1194 $affected_packages{$data->{package}} = 1;
1195 if (length($data->{mergedwith})) {
1196 print {$transcript} "$gBug is marked as being merged with others. Use an existing clone.\n\n";
1200 &filelock("nextnumber.lock");
1201 open(N,"nextnumber") || die "nextnumber: read: $!";
1202 my $v=<N>; $v =~ s/\n$// || die "nextnumber bad format";
1203 my $firstref= $v+0; $v += $newbugsneeded;
1204 open(NN,">nextnumber"); print NN "$v\n"; close(NN);
1207 my $lastref = $firstref + $newbugsneeded - 1;
1209 if ($newbugsneeded == 1) {
1210 $action= "$gBug $origref cloned as bug $firstref.";
1212 $action= "$gBug $origref cloned as bugs $firstref-$lastref.";
1215 my $blocks = $data->{blocks};
1216 my $blockedby = $data->{blockedby};
1219 my $ohash = get_hashname($origref);
1220 my $clone = $firstref;
1221 @bug_affected{@newclonedids} = 1 x @newclonedids;
1222 for my $newclonedid (@newclonedids) {
1223 $clonebugs{$newclonedid} = $clone;
1225 my $hash = get_hashname($clone);
1226 copy("db-h/$ohash/$origref.log", "db-h/$hash/$clone.log");
1227 copy("db-h/$ohash/$origref.status", "db-h/$hash/$clone.status");
1228 copy("db-h/$ohash/$origref.summary", "db-h/$hash/$clone.summary");
1229 copy("db-h/$ohash/$origref.report", "db-h/$hash/$clone.report");
1230 &bughook('new', $clone, $data);
1232 # Update blocking info of bugs blocked by or blocking the
1234 foreach $ref (split ' ', $blocks) {
1236 $data->{blockedby} = manipset($data->{blockedby}, $clone, 1);
1239 foreach $ref (split ' ', $blockedby) {
1241 $data->{blocks} = manipset($data->{blocks}, $clone, 1);
1249 } elsif (m/^package\:?\s+(\S.*\S)?\s*$/i) {
1251 my @pkgs = split /\s+/, $1;
1252 if (scalar(@pkgs) > 0) {
1253 %limit_pkgs = map { ($_, 1) } @pkgs;
1254 print {$transcript} "Ignoring bugs not assigned to: " .
1255 join(" ", keys(%limit_pkgs)) . "\n\n";
1258 print {$transcript} "Not ignoring any bugs.\n\n";
1260 } elsif (m/^affects?\s+\#?(-?\d+)(?:\s+((?:[=+-])?)\s*(\S.*)?)?\s*$/i) {
1263 my $add_remove = $2 || '';
1264 my $packages = $3 || '';
1265 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1266 $bug_affected{$ref} = 1;
1268 affects(bug => $ref,
1269 transcript => $transcript,
1270 ($dl > 0 ? (debug => $transcript):()),
1271 requester => $header{from},
1272 request_addr => $controlrequestaddr,
1274 recipients => \%recipients,
1275 packages => [splitpackages($3)],
1276 ($add_remove eq '+'?(add => 1):()),
1277 ($add_remove eq '-'?(remove => 1):()),
1282 print {$transcript} "Failed to give $ref a summary: $@";
1285 } elsif (m/^summary\s+\#?(-?\d+)\s*(\d+|)\s*$/i) {
1288 my $summary_msg = length($2)?$2:undef;
1289 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1290 $bug_affected{$ref} = 1;
1292 summary(bug => $ref,
1293 transcript => $transcript,
1294 ($dl > 0 ? (debug => $transcript):()),
1295 requester => $header{from},
1296 request_addr => $controlrequestaddr,
1298 recipients => \%recipients,
1299 summary => $summary_msg,
1304 print {$transcript} "Failed to give $ref a summary: $@";
1307 } elsif (m/^owner\s+\#?(-?\d+)\s+((?:\S.*\S)|\!)\s*$/i) {
1310 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1312 if ($newowner eq '!') {
1313 $newowner = $replyto;
1315 $bug_affected{$ref} = 1;
1318 transcript => $transcript,
1319 ($dl > 0 ? (debug => $transcript):()),
1320 requester => $header{from},
1321 request_addr => $controlrequestaddr,
1323 recipients => \%recipients,
1329 print {$transcript} "Failed to mark $ref as having an owner: $@";
1331 } elsif (m/^noowner\s+\#?(-?\d+)\s*$/i) {
1334 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1335 $bug_affected{$ref} = 1;
1338 transcript => $transcript,
1339 ($dl > 0 ? (debug => $transcript):()),
1340 requester => $header{from},
1341 request_addr => $controlrequestaddr,
1343 recipients => \%recipients,
1349 print {$transcript} "Failed to mark $ref as not having an owner: $@";
1351 } elsif (m/^unarchive\s+#?(\d+)$/i) {
1354 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1355 $bug_affected{$ref} = 1;
1357 bug_unarchive(bug => $ref,
1358 transcript => $transcript,
1359 ($dl > 0 ? (debug => $transcript):()),
1360 affected_bugs => \%bug_affected,
1361 requester => $header{from},
1362 request_addr => $controlrequestaddr,
1364 recipients => \%recipients,
1370 } elsif (m/^archive\s+#?(\d+)$/i) {
1373 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1374 $bug_affected{$ref} = 1;
1376 bug_archive(bug => $ref,
1377 transcript => $transcript,
1378 ($dl > 0 ? (debug => $transcript):()),
1380 archive_unarchived => 0,
1381 affected_bugs => \%bug_affected,
1382 requester => $header{from},
1383 request_addr => $controlrequestaddr,
1385 recipients => \%recipients,
1392 print {$transcript} "Unknown command or malformed arguments to command.\n\n";
1394 if (++$unknowns >= 5) {
1395 print {$transcript} "Too many unknown commands, stopping here.\n\n";
1400 if ($procline>$#bodylines) {
1401 print {$transcript} ">\nEnd of message, stopping processing here.\n\n";
1403 if (!$ok && !$quickabort) {
1405 print {$transcript} "No commands successfully parsed; sending the help text(s).\n";
1407 print {$transcript} "\n";
1410 my @maintccs = determine_recipients(recipients => \%recipients,
1414 my $maintccs = 'Cc: '.join(",\n ",
1415 determine_recipients(recipients => \%recipients,
1421 $packagepr = "X-${gProject}-PR-Package: " . join(keys %affected_packages) . "\n" if keys %affected_packages;
1423 # Add Bcc's to subscribed bugs
1424 # now handled by Debbugs::Recipients
1425 #push @bcc, map {"bugs=$_\@$gListDomain"} keys %bug_affected;
1427 if (!defined $header{'subject'} || $header{'subject'} eq "") {
1428 $header{'subject'} = "your mail";
1431 # Error text here advertises how many errors there were
1432 my $error_text = $errors > 0 ? " (with $errors errors)":'';
1435 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1437 ${maintccs}Subject: Processed${error_text}: $header{'subject'}
1438 In-Reply-To: $header{'message-id'}
1441 References: $header{'message-id'}
1442 Message-ID: <handler.s.$nn.transcript\@$gEmailDomain>
1444 ${packagepr}X-$gProject-PR-Message: transcript
1446 ${transcript_scalar}Please contact me if you need assistance.
1449 (administrator, $gProject $gBugs database)
1452 my $repliedshow= join(', ',$replyto,
1453 determine_recipients(recipients => \%recipients,
1458 # -1 is the service.in log
1459 &filelock("lock/-1");
1460 open(AP,">>db-h/-1.log") || die "open db-h/-1.log: $!";
1462 "\2\n$repliedshow\n\5\n$reply\n\3\n".
1464 "<strong>Request received</strong> from <code>".
1465 html_escape($header{'from'})."</code>\n".
1466 "to <code>".html_escape($controlrequestaddr)."</code>\n".
1468 "\7\n",escape_log(@log),"\n\3\n") || die "writing db-h/-1.log: $!";
1469 close(AP) || die "open db-h/-1.log: $!";
1471 utime(time,time,"db-h");
1473 &sendmailmessage($reply,
1474 exists $header{'x-debbugs-no-ack'}?():$replyto,
1475 make_list(values %{{determine_recipients(recipients => \%recipients,
1481 unlink("incoming/P$nn") || die "unlinking incoming/P$nn: $!";
1483 sub sendmailmessage {
1484 my ($message,@recips) = @_;
1485 $message = "X-Loop: $gMaintainerEmail\n" . $message;
1486 send_mail_message(message => $message,
1487 recipients => \@recips,
1493 my ($template,$extra_var) = @_;
1495 my $variables = {config => \%config,
1496 defined($ref)?(ref => $ref):(),
1497 defined($data)?(data => $data):(),
1500 my $hole_var = {'&bugurl' =>
1502 'http://'.$config{cgi_domain}.'/'.
1503 Debbugs::CGI::bug_url($_[0]);
1506 return fill_in_template(template => $template,
1507 variables => $variables,
1508 hole_var => $hole_var,
1512 =head2 message_body_template
1514 message_body_template('mail/ack',{ref=>'foo'});
1516 Creates a message body using a template
1520 sub message_body_template{
1521 my ($template,$extra_var) = @_;
1523 my $body = fill_template($template,$extra_var);
1524 return fill_template('mail/message_body',
1533 &sendtxthelpraw("bug-maint-mailcontrol.txt","instructions for control\@$gEmailDomain")
1536 &sendtxthelpraw("bug-log-mailserver.txt","instructions for request\@$gEmailDomain");
1540 #sub unimplemented {
1541 # print {$transcript} "Sorry, command $_[0] not yet implemented.\n\n";
1543 our %checkmatch_values;
1545 my ($string,$mvarname,$svarvalue,@newmergelist) = @_;
1547 if (@newmergelist) {
1548 $mvarvalue = $checkmatch_values{$mvarname};
1549 print {$transcript} "D| checkmatch \`$string' /$mvarname/$mvarvalue/$svarvalue/\n"
1552 "Values for \`$string' don't match:\n".
1553 " #$newmergelist[0] has \`$mvarvalue';\n".
1554 " #$ref has \`$svarvalue'\n"
1555 if $mvarvalue ne $svarvalue;
1557 print {$transcript} "D| setupmatch \`$string' /$mvarname/$svarvalue/\n"
1559 $checkmatch_values{$mvarname} = $svarvalue;
1564 if (keys %limit_pkgs and not defined $limit_pkgs{$data->{package}}) {
1565 print {$transcript} "$gBug number $ref belongs to package $data->{package}, skipping.\n\n";
1577 my %h = map { $_ => 1 } split ' ', $list;
1584 return join ' ', sort keys %h;
1587 # High-level bug manipulation calls
1588 # Do announcements themselves
1590 # Possible calling sequences:
1591 # setbug (returns 0)
1593 # setbug (returns 1)
1594 # &transcript(something)
1597 # setbug (returns 1)
1598 # $action= (something)
1600 # (modify s_* variables)
1601 # } while (getnextbug);
1606 &dlen("nochangebug");
1607 $state eq 'single' || $state eq 'multiple' || die "$state ?";
1609 &endmerge if $manybugs;
1611 &dlex("nochangebug");
1615 our @thisbugmergelist;
1618 &dlen("setbug $ref");
1619 if ($ref =~ m/^-\d+/) {
1620 if (!defined $clonebugs{$ref}) {
1622 &dlex("setbug => noclone");
1625 $ref = $clonebugs{$ref};
1627 $state eq 'idle' || die "$state ?";
1630 &dlex("setbug => 0s");
1634 if (!&checkpkglimit) {
1639 @thisbugmergelist= split(/ /,$data->{mergedwith});
1640 if (!@thisbugmergelist) {
1645 &dlex("setbug => 1s");
1654 &dlex("setbug => 0mc");
1658 $state= 'multiple'; $sref=$ref;
1659 &dlex("setbug => 1m");
1664 &dlen("getnextbug");
1665 $state eq 'single' || $state eq 'multiple' || die "$state ?";
1667 if (!$manybugs || !@thisbugmergelist) {
1668 length($action) || die;
1669 print {$transcript} "$action\n$extramessage\n";
1670 &endmerge if $manybugs;
1672 &dlex("getnextbug => 0");
1675 $ref= shift(@thisbugmergelist);
1676 &getbug || die "bug $ref disappeared";
1678 &dlex("getnextbug => 1");
1682 # Low-level bug-manipulation calls
1683 # Do no announcements
1685 # getbug (returns 0)
1687 # getbug (returns 1)
1691 # $action= (something)
1692 # getbug (returns 1)
1694 # getbug (returns 1)
1696 # [getbug (returns 0)]
1697 # &transcript("$action\n\n")
1700 sub notfoundbug { print {$transcript} "$gBug number $ref not found. (Is it archived?)\n\n"; }
1701 sub foundbug { print {$transcript} "$gBug#$ref: $data->{subject}\n"; }
1705 $mergelowstate eq 'idle' || die "$mergelowstate ?";
1706 &filelock('lock/merge');
1707 $mergelowstate='locked';
1713 $mergelowstate eq 'locked' || die "$mergelowstate ?";
1715 $mergelowstate='idle';
1720 &dlen("getbug $ref");
1721 $lowstate eq 'idle' || die "$state ?";
1722 # Only use unmerged bugs here
1723 if (($data = &lockreadbug($ref,'db-h'))) {
1726 &dlex("getbug => 1");
1731 &dlex("getbug => 0");
1737 $lowstate eq 'open' || die "$state ?";
1744 &dlen("savebug $ref");
1745 $lowstate eq 'open' || die "$lowstate ?";
1746 length($action) || die;
1747 $ref == $sref || die "read $sref but saving $ref ?";
1748 append_action_to_log(bug => $ref,
1750 requester => $header{from},
1751 request_addr => $controlrequestaddr,
1755 unlockwritebug($ref, $data);
1762 print {$transcript} "C> @_ ($state $lowstate $mergelowstate)\n";
1767 print {$transcript} "R> @_ ($state $lowstate $mergelowstate)\n";
1774 my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
1775 $url =~ s/([<>&"])/\&$saniarray{$1};/g;
1781 print {$transcript} "\n";
1787 print {$transcript} "\n";
1793 sub sendtxthelpraw {
1794 my ($relpath,$description) = @_;
1796 open(D,"$gDocDir/$relpath") || die "open doc file $relpath: $!";
1797 while(<D>) { $doc.=$_; }
1799 print {$transcript} "Sending $description in separate message.\n";
1800 &sendmailmessage(<<END.$doc,$replyto);
1801 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1803 Subject: $gProject $gBug help: $description
1804 References: $header{'message-id'}
1805 In-Reply-To: $header{'message-id'}
1806 Message-ID: <handler.s.$nn.help.$midix\@$gEmailDomain>
1808 X-$gProject-PR-Message: doc-text $relpath
1814 sub sendlynxdocraw {
1815 my ($relpath,$description) = @_;
1817 open(L,"lynx -nolist -dump http://$gCGIDomain/\Q$relpath\E 2>&1 |") || die "fork for lynx: $!";
1818 while(<L>) { $doc.=$_; }
1820 if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
1821 print {$transcript} "Information ($description) is not available -\n".
1822 "perhaps the $gBug does not exist or is not on the WWW yet.\n";
1825 print {$transcript} "Error getting $description (code $? $!):\n$doc\n";
1827 print {$transcript} "Sending $description.\n";
1828 &sendmailmessage(<<END.$doc,$replyto);
1829 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1831 Subject: $gProject $gBugs information: $description
1832 References: $header{'message-id'}
1833 In-Reply-To: $header{'message-id'}
1834 Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
1836 X-$gProject-PR-Message: doc-html $relpath
1845 my ($wherefrom,$path,$description) = @_;
1846 if ($wherefrom eq "ftp.d.o") {
1847 $doc = `lynx -nolist -dump http://ftp.debian.org/debian/indices/$path.gz 2>&1 | gunzip -cf` or die "fork for lynx/gunzip: $!";
1849 if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
1850 print {$transcript} "$description is not available.\n";
1853 print {$transcript} "Error getting $description (code $? $!):\n$doc\n";
1856 } elsif ($wherefrom eq "local") {
1858 $doc = do { local $/; <P> };
1861 print {$transcript} "internal errror: info files location unknown.\n";
1864 print {$transcript} "Sending $description.\n";
1865 &sendmailmessage(<<END.$doc,$replyto);
1866 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1868 Subject: $gProject $gBugs information: $description
1869 References: $header{'message-id'}
1870 In-Reply-To: $header{'message-id'}
1871 Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
1873 X-$gProject-PR-Message: getinfo
1875 $description follows:
1879 print {$transcript} "\n";