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 Scalar::Util qw(looks_like_number);
38 use Mail::RFC822::Address;
40 chdir($config{spool_dir}) or
41 die "Unable to chdir to spool_dir '$config{spool_dir}': $!";
46 my ($nn,$control) = $ARGV[0] =~ m/^(([RC])\.\d+)$/;
47 if (not defined $control or not defined $nn) {
48 die "Bad argument to service.in";
50 if (!rename("incoming/G$nn","incoming/P$nn")) {
51 defined $! and $! =~ m/no such file or directory/i and exit 0;
52 die "Failed to rename incoming/G$nn to incoming/P$nn: $!";
55 my $log_fh = IO::File->new("incoming/P$nn",'r') or
56 die "Unable to open incoming/P$nn for reading: $!";
63 print "###\n",join("##\n",@msg),"\n###\n" if $debug;
65 # Bug numbers to send e-mail to, hash so that we don't send to the
69 my (@headerlines,@bodylines);
71 my $parse_output = Debbugs::MIME::parse(join('',@log));
72 @headerlines = @{$parse_output->{header}};
73 @bodylines = @{$parse_output->{body}};
77 $_ = decode_rfc1522($_);
79 print ">$_<\n" if $debug;
82 print ">$v=$_<\n" if $debug;
85 print "!>$_<\n" if $debug;
88 $header{'message-id'} ||= '';
89 $header{subject} ||= '';
91 grep(s/\s+$//,@bodylines);
93 print "***\n",join("\n",@bodylines),"\n***\n" if $debug;
95 if (defined $header{'resent-from'} && !defined $header{'from'}) {
96 $header{'from'} = $header{'resent-from'};
99 defined($header{'from'}) || die "no From header";
101 delete $header{'reply-to'}
102 if ( defined($header{'reply-to'}) && $header{'reply-to'} =~ m/^\s*$/ );
105 if ( defined($header{'reply-to'}) && $header{'reply-to'} ne "" ) {
106 $replyto = $header{'reply-to'};
108 $replyto = $header{'from'};
111 # This is an error counter which should be incremented every time there is an error.
113 my $controlrequestaddr= ($control ? 'control' : 'request').'@'.$config{email_domain};
114 my $transcript_scalar = '';
115 my $transcript = IO::Scalar->new(\$transcript_scalar) or
116 die "Unable to create new IO::Scalar";
117 print {$transcript} "Processing commands for $controlrequestaddr:\n\n";
122 my $lowstate= 'idle';
123 my $mergelowstate= 'idle';
128 $user =~ s/^.*<(.*)>.*$/$1/;
129 $user =~ s/[(].*[)]//;
130 $user =~ s/^\s*(\S+)\s+.*$/$1/;
131 $user = "" unless (Debbugs::User::is_valid_user($user));
132 my $indicated_user = 0;
137 if (@gExcludeFromControl and grep {$replyto =~ m/\Q$_\E/} @gExcludeFromControl) {
138 print {$transcript} fill_template('mail/excluded_from_control');
149 push @bcc, $_[0] unless grep { $_ eq $_[0] } @bcc;
164 my %affected_packages;
168 for ($procline=0; $procline<=$#bodylines; $procline++) {
173 $state eq 'idle' || print "state: $state ?\n";
174 $lowstate eq 'idle' || print "lowstate: $lowstate ?\n";
175 $mergelowstate eq 'idle' || print "mergelowstate: $mergelowstate ?\n";
177 print {$transcript} "Stopping processing here.\n\n";
180 $_= $bodylines[$procline]; s/\s+$//;
181 # Remove BOM markers from UTF-8 strings
185 print {$transcript} "> $_\n";
188 if (m/^stop\s*$/i || m/^quit\s*$/i || m/^--\s*$/ || m/^thank(?:s|\s*you)?\s*$/i || m/^kthxbye\s*$/i) {
189 print {$transcript} "Stopping processing here.\n\n";
191 } elsif (m/^debug\s+(\d+)$/i && $1 >= 0 && $1 <= 1000) {
193 print {$transcript} "Debug level $dl.\n\n";
194 } elsif (m/^(send|get)\s+\#?(\d{2,})$/i) {
196 &sendlynxdoc("bugreport.cgi?bug=$ref","logs for $gBug#$ref");
197 } elsif (m/^send-detail\s+\#?(\d{2,})$/i) {
199 &sendlynxdoc("bugreport.cgi?bug=$ref&boring=yes",
200 "detailed logs for $gBug#$ref");
201 } elsif (m/^index(\s+full)?$/i) {
202 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
204 $ok++; # well, it's not really ok, but it fixes #81224 :)
205 } elsif (m/^index-summary\s+by-package$/i) {
206 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
208 $ok++; # well, it's not really ok, but it fixes #81224 :)
209 } elsif (m/^index-summary(\s+by-number)?$/i) {
210 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
212 $ok++; # well, it's not really ok, but it fixes #81224 :)
213 } elsif (m/^index(\s+|-)pack(age)?s?$/i) {
214 &sendlynxdoc("pkgindex.cgi?indexon=pkg",'index of packages');
215 } elsif (m/^index(\s+|-)maints?$/i) {
216 &sendlynxdoc("pkgindex.cgi?indexon=maint",'index of maintainers');
217 } elsif (m/^index(\s+|-)maint\s+(\S+)$/i) {
219 &sendlynxdoc("pkgreport.cgi?maint=" . urlsanit($maint),
220 "$gBug list for maintainer \`$maint'");
222 } elsif (m/^index(\s+|-)pack(age)?s?\s+(\S.*\S)$/i) {
224 &sendlynxdoc("pkgreport.cgi?pkg=" . urlsanit($package),
225 "$gBug list for package $package");
227 } elsif (m/^send-unmatched(\s+this|\s+-?0)?$/i) {
228 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
230 $ok++; # well, it's not really ok, but it fixes #81224 :)
231 } elsif (m/^send-unmatched\s+(last|-1)$/i) {
232 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
234 $ok++; # well, it's not really ok, but it fixes #81224 :)
235 } elsif (m/^send-unmatched\s+(old|-2)$/i) {
236 print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
238 $ok++; # well, it's not really ok, but it fixes #81224 :)
239 } elsif (m/^getinfo\s+([\w.-]+)$/i) {
240 # the following is basically a Debian-specific kludge, but who cares
242 if ($req =~ /^maintainers$/i && -f "$gConfigDir/Maintainers") {
243 &sendinfo("local", "$gConfigDir/Maintainers", "Maintainers file");
244 } elsif ($req =~ /^override\.(\w+)\.([\w.-]+)$/i) {
246 &sendinfo("ftp.d.o", "$req", "override file for $2 part of $1 distribution");
247 } elsif ($req =~ /^pseudo-packages\.(description|maintainers)$/i && -f "$gConfigDir/$req") {
248 &sendinfo("local", "$gConfigDir/$req", "$req file");
250 print {$transcript} "Info file $req does not exist.\n\n";
252 } elsif (m/^help/i) {
254 print {$transcript} "\n";
256 } elsif (m/^refcard/i) {
257 &sendtxthelp("bug-mailserver-refcard.txt","mail servers' reference card");
258 } elsif (m/^subscribe/i) {
259 print {$transcript} <<END;
260 There is no $gProject $gBug mailing list. If you wish to review bug reports
261 please do so via http://$gWebDomain/ or ask this mail server
263 soon: MAILINGLISTS_TEXT
265 } elsif (m/^unsubscribe/i) {
266 print {$transcript} <<END;
267 soon: UNSUBSCRIBE_TEXT
268 soon: MAILINGLISTS_TEXT
270 } elsif (m/^user\s+(\S+)\s*$/i) {
272 if (Debbugs::User::is_valid_user($newuser)) {
273 my $olduser = ($user ne "" ? " (was $user)" : "");
274 print {$transcript} "Setting user to $newuser$olduser.\n";
278 print {$transcript} "Selected user id ($newuser) invalid, sorry\n";
283 } elsif (m/^usercategory\s+(\S+)(\s+\[hidden\])?\s*$/i) {
286 my $hidden = (defined $2 and $2 ne "");
293 print {$transcript} "No valid user selected\n";
297 if (not $indicated_user and defined $user) {
298 print {$transcript} "User is $user\n";
302 while (++$procline <= $#bodylines) {
303 unless ($bodylines[$procline] =~ m/^\s*([*+])\s*(\S.*)$/) {
307 print {$transcript} "> $bodylines[$procline]\n";
309 my ($o, $txt) = ($1, $2);
310 if ($#cats == -1 && $o eq "+") {
311 print {$transcript} "User defined category specification must start with a category name. Skipping.\n\n";
317 unless (ref($cats[-1]) eq "HASH") {
318 $cats[-1] = { "nam" => $cats[-1],
319 "pri" => [], "ttl" => [] };
322 my ($desc, $ord, $op);
323 if ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?\]\s*$/) {
324 $desc = $1; $ord = $3; $op = "";
325 } elsif ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?(\S+)\]\s*$/) {
326 $desc = $1; $ord = $3; $op = $4;
327 } elsif ($txt =~ m/^([^[\s]+)\s*$/) {
328 $desc = ""; $op = $1;
330 print {$transcript} "Unrecognised syntax for category section. Skipping.\n\n";
335 $ord = 999 unless defined $ord;
338 push @{$cats[-1]->{"pri"}}, $prefix . $op;
339 push @{$cats[-1]->{"ttl"}}, $desc;
340 push @ords, "$ord $catsec";
342 $cats[-1]->{"def"} = $desc;
343 push @ords, "$ord DEF";
347 my ($a1, $a2, $b1, $b2) = split / /, "$a $b";
348 ((looks_like_number($a1) and looks_like_number($a2))?$a1 <=> $b1:$a1 cmp $b1) ||
349 ((looks_like_number($a2) and looks_like_number($b2))?$a2 <=> $b2:$a2 cmp $b2);
351 $cats[-1]->{"ord"} = [map { m/^.* (\S+)/; $1 eq "DEF" ? $catsec + 1 : $1 } @ords];
352 } elsif ($o eq "*") {
355 if ($txt =~ m/^(.*\S)(\s*\[(\S+)\])\s*$/) {
356 $name = $1; $prefix = $3;
358 $name = $txt; $prefix = "";
363 # XXX: got @cats, now do something with it
364 my $u = Debbugs::User::get_user($user);
366 print {$transcript} "Added usercategory $catname.\n\n";
367 $u->{"categories"}->{$catname} = [ @cats ];
369 push @{$u->{visible_cats}},$catname;
372 print {$transcript} "Removed usercategory $catname.\n\n";
373 delete $u->{"categories"}->{$catname};
374 @{$u->{visible_cats}} = grep {$_ ne $catname} @{$u->{visible_cats}};
377 } elsif (m/^usertags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
380 my $addsubcode = $3 || "+";
382 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
383 $ref = $clonebugs{$ref};
386 print {$transcript} "No valid user selected\n";
390 if (not $indicated_user and defined $user) {
391 print {$transcript} "User is $user\n";
396 Debbugs::User::read_usertags(\%ut, $user);
397 my @oldtags = (); my @newtags = (); my @badtags = ();
399 if (defined $tags and length $tags) {
400 for my $t (split /[,\s]+/, $tags) {
401 if ($t =~ m/^[a-zA-Z0-9.+\@-]+$/) {
409 print {$transcript} "Ignoring illegal tag/s: ".join(', ', @badtags).".\nPlease use only alphanumerics, at, dot, plus and dash.\n";
412 for my $t (keys %chtags) {
413 $ut{$t} = [] unless defined $ut{$t};
415 for my $t (keys %ut) {
416 my %res = map { ($_, 1) } @{$ut{$t}};
417 push @oldtags, $t if defined $res{$ref};
418 my $addop = ($addsubcode eq "+" or $addsubcode eq "=");
419 my $del = (defined $chtags{$t} ? $addsubcode eq "-"
420 : $addsubcode eq "=");
421 $res{$ref} = 1 if ($addop && defined $chtags{$t});
422 delete $res{$ref} if ($del);
423 push @newtags, $t if defined $res{$ref};
424 $ut{$t} = [ sort { $a <=> $b } (keys %res) ];
427 print {$transcript} "There were no usertags set.\n";
429 print {$transcript} "Usertags were: " . join(" ", @oldtags) . ".\n";
431 print {$transcript} "Usertags are now: " . join(" ", @newtags) . ".\n";
432 Debbugs::User::write_usertags(\%ut, $user);
434 } elsif (!$control) {
435 print {$transcript} <<END;
436 Unknown command or malformed arguments to command.
437 (Use control\@$gEmailDomain to manipulate reports.)
441 if (++$unknowns >= 3) {
442 print {$transcript} "Too many unknown commands, stopping here.\n\n";
445 #### "developer only" ones start here
446 } elsif (m/^close\s+\#?(-?\d+)(?:\s+(\d.*))?$/i) {
449 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
450 $bug_affected{$ref}=1;
453 print {$transcript} "'close' is deprecated; see http://$gWebDomain/Developer$gHTMLSuffix#closing.\n";
454 if (length($data->{done}) and not defined($version)) {
455 print {$transcript} "$gBug is already closed, cannot re-close.\n\n";
460 "marked as fixed in version $version" :
462 ", send any further explanations to $data->{originator}";
464 $affected_packages{$data->{package}} = 1;
465 add_recipients(data => $data,
466 recipients => \%recipients,
467 actions_taken => {done => 1},
468 transcript => $transcript,
469 ($dl > 0 ? (debug => $transcript):()),
471 $data->{done}= $replyto;
472 my @keywords= split ' ', $data->{keywords};
473 my $extramessage = '';
474 if (grep $_ eq 'pending', @keywords) {
475 $extramessage= "Removed pending tag.\n";
476 $data->{keywords}= join ' ', grep $_ ne 'pending',
479 addfixedversions($data, $data->{package}, $version, 'binary');
482 From: $gMaintainerEmail ($gProject $gBug Tracking System)
483 To: $data->{originator}
484 Subject: $gBug#$ref acknowledged by developer
486 References: $header{'message-id'} $data->{msgid}
487 In-Reply-To: $data->{msgid}
488 Message-ID: <handler.$ref.$nn.notifdonectrl.$midix\@$gEmailDomain>
489 Reply-To: $ref\@$gEmailDomain
490 X-$gProject-PR-Message: they-closed-control $ref
492 This is an automatic notification regarding your $gBug report
493 #$ref: $data->{subject},
494 which was filed against the $data->{package} package.
496 It has been marked as closed by one of the developers, namely
499 You should be hearing from them with a substantive response shortly,
500 in case you haven't already. If not, please contact them directly.
503 (administrator, $gProject $gBugs database)
506 &sendmailmessage($message,$data->{originator});
507 } while (&getnextbug);
510 } elsif (m/^reassign\s+\#?(-?\d+)\s+ # bug and command
511 (?:(?:((?:src:|source:)?$config{package_name_re}) # new package
512 (?:\s+((?:$config{package_name_re}\/)?
513 $config{package_version_re}))?)| # optional version
514 ((?:src:|source:)?$config{package_name_re} # multiple package form
515 (?:\s*\,\s*(?:src:|source:)?$config{package_name_re})+))
520 if (not defined $2) {
521 push @new_packages, split /\s*\,\s*/,$4;
524 push @new_packages, $2;
526 @new_packages = map {y/A-Z/a-z/; s/^(?:src|source):/src:/; $_;} @new_packages;
527 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
528 $bug_affected{$ref}=1;
531 set_package(bug => $ref,
532 transcript => $transcript,
533 ($dl > 0 ? (debug => $transcript):()),
534 requester => $header{from},
535 request_addr => $controlrequestaddr,
537 recipients => \%recipients,
538 package => \@new_packages,
540 # if there is a version passed, we make an internal call
542 if (defined($version) && length $version) {
543 set_found(bug => $ref,
544 transcript => $transcript,
545 ($dl > 0 ? (debug => $transcript):()),
546 requester => $header{from},
547 request_addr => $controlrequestaddr,
549 recipients => \%recipients,
556 print {$transcript} "Failed to clear fixed versions and reopen on $ref: $@";
558 } elsif (m/^reopen\s+\#?(-?\d+)$/i ? ($noriginator='', 1) :
559 m/^reopen\s+\#?(-?\d+)\s+\=$/i ? ($noriginator='', 1) :
560 m/^reopen\s+\#?(-?\d+)\s+\!$/i ? ($noriginator=$replyto, 1) :
561 m/^reopen\s+\#?(-?\d+)\s+(\S.*\S)$/i ? ($noriginator=$2, 1) : 0) {
564 $bug_affected{$ref}=1;
566 if (@{$data->{fixed_versions}}) {
567 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";
569 if (!length($data->{done})) {
570 print {$transcript} "$gBug is already open, cannot reopen.\n\n";
574 $noriginator eq '' ? "$gBug reopened, originator not changed." :
575 "$gBug reopened, originator set to $noriginator.";
577 $affected_packages{$data->{package}} = 1;
578 add_recipients(data => $data,
579 recipients => \%recipients,
580 transcript => $transcript,
581 ($dl > 0 ? (debug => $transcript):()),
583 $data->{originator}= $noriginator eq '' ? $data->{originator} : $noriginator;
584 $data->{fixed_versions}= [];
586 } while (&getnextbug);
589 } elsif (m{^(?:(?i)found)\s+\#?(-?\d+)
590 (?:\s+((?:$config{package_name_re}\/)?
591 $config{package_version_re}
592 # allow for multiple packages
593 (?:\s*,\s*(?:$config{package_name_re}\/)?
594 $config{package_version_re})*)
598 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
601 @versions = split /\s*,\s*/,$2;
603 set_found(bug => $ref,
604 transcript => $transcript,
605 ($dl > 0 ? (debug => $transcript):()),
606 requester => $header{from},
607 request_addr => $controlrequestaddr,
609 affected_packages => \%affected_packages,
610 recipients => \%recipients,
617 print {$transcript} "Failed to add found on $ref: $@";
622 set_fixed(bug => $ref,
623 transcript => $transcript,
624 ($dl > 0 ? (debug => $transcript):()),
625 requester => $header{from},
626 request_addr => $controlrequestaddr,
628 affected_packages => \%affected_packages,
629 recipients => \%recipients,
636 print {$transcript} "Failed to clear fixed versions and reopen on $ref: $@";
640 elsif (m{^(?:(?i)notfound)\s+\#?(-?\d+)
641 \s+((?:$config{package_name_re}\/)?
642 $config{package_version_re}
643 # allow for multiple packages
644 (?:\s*,\s*(?:$config{package_name_re}\/)?
645 $config{package_version_re})*
649 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
651 @versions = split /\s*,\s*/,$2;
653 set_found(bug => $ref,
654 transcript => $transcript,
655 ($dl > 0 ? (debug => $transcript):()),
656 requester => $header{from},
657 request_addr => $controlrequestaddr,
659 affected_packages => \%affected_packages,
660 recipients => \%recipients,
667 print {$transcript} "Failed to remove found on $ref: $@";
670 elsif (m{^(?:(?i)fixed)\s+\#?(-?\d+)
671 \s+((?:$config{package_name_re}\/)?
672 $config{package_version_re}
673 # allow for multiple packages
674 (?:\s*,\s*(?:$config{package_name_re}\/)?
675 $config{package_version_re})*)
679 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
681 @versions = split /\s*,\s*/,$2;
683 set_fixed(bug => $ref,
684 transcript => $transcript,
685 ($dl > 0 ? (debug => $transcript):()),
686 requester => $header{from},
687 request_addr => $controlrequestaddr,
689 affected_packages => \%affected_packages,
690 recipients => \%recipients,
697 print {$transcript} "Failed to add fixed on $ref: $@";
700 elsif (m{^(?:(?i)notfixed)\s+\#?(-?\d+)
701 \s+((?:$config{package_name_re}\/)?
702 $config{package_version_re}
703 # allow for multiple packages
704 (?:\s*,\s*(?:$config{package_name_re}\/)?
705 $config{package_version_re})*)
709 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
711 @versions = split /\s*,\s*/,$2;
713 set_fixed(bug => $ref,
714 transcript => $transcript,
715 ($dl > 0 ? (debug => $transcript):()),
716 requester => $header{from},
717 request_addr => $controlrequestaddr,
719 affected_packages => \%affected_packages,
720 recipients => \%recipients,
727 print {$transcript} "Failed to remove fixed on $ref: $@";
730 elsif (m/^submitter\s+\#?(-?\d+)\s+(\!|\S.*\S)$/i) {
733 $bug_affected{$ref}=1;
734 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
735 my $newsubmitter = $2 eq '!' ? $replyto : $2;
736 if (not Mail::RFC822::Address::valid($newsubmitter)) {
737 print {$transcript} "$newsubmitter is not a valid e-mail address; not changing submitter\n";
741 if (&checkpkglimit) {
743 $affected_packages{$data->{package}} = 1;
744 add_recipients(data => $data,
745 recipients => \%recipients,
746 transcript => $transcript,
747 ($dl > 0 ? (debug => $transcript):()),
749 $oldsubmitter= $data->{originator};
750 $data->{originator}= $newsubmitter;
751 $action= "Changed $gBug submitter from $oldsubmitter to $newsubmitter.";
753 print {$transcript} "$action\n";
754 if (length($data->{done})) {
755 print {$transcript} "(By the way, that $gBug is currently marked as done.)\n";
757 print {$transcript} "\n";
759 From: $gMaintainerEmail ($gProject $gBug Tracking System)
761 Subject: $gBug#$ref submitter address changed
763 References: $header{'message-id'} $data->{msgid}
764 In-Reply-To: $data->{msgid}
765 Message-ID: <handler.$ref.$nn.newsubmitter.$midix\@$gEmailDomain>
766 Reply-To: $ref\@$gEmailDomain
767 X-$gProject-PR-Message: submitter-changed $ref
769 The submitter address recorded for your $gBug report
770 #$ref: $data->{subject}
773 The old submitter address for this report was
775 The new submitter address is
778 This change was made by
780 If it was incorrect, please contact them directly.
783 (administrator, $gProject $gBugs database)
786 &sendmailmessage($message,$oldsubmitter);
793 } elsif (m/^forwarded\s+\#?(-?\d+)\s+(\S.*\S)$/i) {
797 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
798 $bug_affected{$ref} = 1;
800 set_forwarded(bug => $ref,
801 transcript => $transcript,
802 ($dl > 0 ? (debug => $transcript):()),
803 requester => $header{from},
804 request_addr => $controlrequestaddr,
806 affected_packages => \%affected_packages,
807 recipients => \%recipients,
808 forwarded => $forward_to,
813 print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
815 } elsif (m/^notforwarded\s+\#?(-?\d+)$/i) {
818 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
819 $bug_affected{$ref} = 1;
821 set_forwarded(bug => $ref,
822 transcript => $transcript,
823 ($dl > 0 ? (debug => $transcript):()),
824 requester => $header{from},
825 request_addr => $controlrequestaddr,
827 affected_packages => \%affected_packages,
828 recipients => \%recipients,
834 print {$transcript} "Failed to clear the forwarded-to-address of $ref: $@";
836 } elsif (m/^(?:severity|priority)\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i) {
839 $bug_affected{$ref}=1;
841 if (!grep($_ eq $newseverity, @gSeverityList, "$gDefaultSeverity")) {
842 print {$transcript} "Severity level \`$newseverity' is not known.\n".
843 "Recognized are: $gShowSeverities.\n\n";
845 } elsif (exists $gObsoleteSeverities{$newseverity}) {
846 print {$transcript} "Severity level \`$newseverity' is obsolete. " .
847 "Use $gObsoleteSeverities{$newseverity} instead.\n\n";
850 my $printseverity= $data->{severity};
851 $printseverity= "$gDefaultSeverity" if $printseverity eq '';
852 $action= "Severity set to \`$newseverity' from \`$printseverity'";
854 $affected_packages{$data->{package}} = 1;
855 add_recipients(data => $data,
856 recipients => \%recipients,
857 transcript => $transcript,
858 ($dl > 0 ? (debug => $transcript):()),
860 if (defined $gStrongList and isstrongseverity($newseverity)) {
861 addbcc("$gStrongList\@$gListDomain");
863 $data->{severity}= $newseverity;
864 } while (&getnextbug);
866 } elsif (m/^tags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
871 $bug_affected{$ref}=1;
873 if (defined $addsubcode) {
874 $addsub = "sub" if ($addsubcode eq "-");
875 $addsub = "add" if ($addsubcode eq "+");
876 $addsub = "set" if ($addsubcode eq "=");
880 foreach my $t (split /[\s,]+/, $tags) {
881 if (!grep($_ eq $t, @gTags)) {
888 print {$transcript} "Unknown tag/s: ".join(', ', @badtags).".\n".
889 "Recognized are: ".join(' ', @gTags).".\n\n";
893 if ($data->{keywords} eq '') {
894 print {$transcript} "There were no tags set.\n";
896 print {$transcript} "Tags were: $data->{keywords}\n";
898 if ($addsub eq "set") {
899 $action= "Tags set to: " . join(", ", @okaytags);
900 } elsif ($addsub eq "add") {
901 $action= "Tags added: " . join(", ", @okaytags);
902 } elsif ($addsub eq "sub") {
903 $action= "Tags removed: " . join(", ", @okaytags);
906 $affected_packages{$data->{package}} = 1;
907 add_recipients(data => $data,
908 recipients => \%recipients,
909 transcript => $transcript,
910 ($dl > 0 ? (debug => $transcript):()),
912 $data->{keywords} = '' if ($addsub eq "set");
913 # Allow removing obsolete tags.
914 if ($addsub eq "sub") {
915 foreach my $t (@badtags) {
916 $data->{keywords} = join ' ', grep $_ ne $t,
917 split ' ', $data->{keywords};
920 # Now process all other additions and subtractions.
921 foreach my $t (@okaytags) {
922 $data->{keywords} = join ' ', grep $_ ne $t,
923 split ' ', $data->{keywords};
924 $data->{keywords} = "$t $data->{keywords}" unless($addsub eq "sub");
926 $data->{keywords} =~ s/\s*$//;
927 } while (&getnextbug);
929 } elsif (m/^(un)?block\s+\#?(-?\d+)\s+(by|with)\s+(\S.*)?$/i) {
931 my $bugnum = $2; my $blockers = $4;
933 $addsub = "sub" if (defined $1 and $1 eq "un");
934 if ($bugnum =~ m/^-\d+$/ && defined $clonebugs{$bugnum}) {
935 $bugnum = $clonebugs{$bugnum};
940 foreach my $b (split /[\s,]+/, $blockers) {
944 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
945 $ref = $clonebugs{$ref};
949 push @okayblockers, $ref;
951 # add to the list all bugs that are merged with $b,
952 # because all of their data must be kept in sync
953 my @thisbugmergelist= split(/ /,$data->{mergedwith});
956 foreach $ref (@thisbugmergelist) {
958 push @okayblockers, $ref;
965 push @badblockers, $ref;
969 push @badblockers, $b;
973 print {$transcript} "Unknown blocking bug/s: ".join(', ', @badblockers).".\n";
979 if ($data->{blockedby} eq '') {
980 print {$transcript} "Was not blocked by any bugs.\n";
982 print {$transcript} "Was blocked by: $data->{blockedby}\n";
984 if ($addsub eq "set") {
985 $action= "Blocking bugs of $bugnum set to: " . join(", ", @okayblockers);
986 } elsif ($addsub eq "add") {
987 $action= "Blocking bugs of $bugnum added: " . join(", ", @okayblockers);
988 } elsif ($addsub eq "sub") {
989 $action= "Blocking bugs of $bugnum removed: " . join(", ", @okayblockers);
994 $affected_packages{$data->{package}} = 1;
995 add_recipients(data => $data,
996 recipients => \%recipients,
997 transcript => $transcript,
998 ($dl > 0 ? (debug => $transcript):()),
1000 my @oldblockerlist = split ' ', $data->{blockedby};
1001 $data->{blockedby} = '' if ($addsub eq "set");
1002 foreach my $b (@okayblockers) {
1003 $data->{blockedby} = manipset($data->{blockedby}, $b,
1004 ($addsub ne "sub"));
1007 foreach my $b (@oldblockerlist) {
1008 if (! grep { $_ eq $b } split ' ', $data->{blockedby}) {
1009 push @{$removedblocks{$b}}, $ref;
1012 foreach my $b (split ' ', $data->{blockedby}) {
1013 if (! grep { $_ eq $b } @oldblockerlist) {
1014 push @{$addedblocks{$b}}, $ref;
1017 } while (&getnextbug);
1019 # Now that the blockedby data is updated, change blocks data
1020 # to match the changes.
1021 foreach $ref (keys %addedblocks) {
1023 foreach my $b (@{$addedblocks{$ref}}) {
1024 $data->{blocks} = manipset($data->{blocks}, $b, 1);
1029 foreach $ref (keys %removedblocks) {
1031 foreach my $b (@{$removedblocks{$ref}}) {
1032 $data->{blocks} = manipset($data->{blocks}, $b, 0);
1038 } elsif (m/^retitle\s+\#?(-?\d+)\s+(\S.*\S)\s*$/i) {
1040 $ref= $1; my $newtitle= $2;
1041 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1042 $bug_affected{$ref} = 1;
1044 set_title(bug => $ref,
1045 transcript => $transcript,
1046 ($dl > 0 ? (debug => $transcript):()),
1047 requester => $header{from},
1048 request_addr => $controlrequestaddr,
1050 recipients => \%recipients,
1056 print {$transcript} "Failed to set the title of $ref: $@";
1058 } elsif (m/^unmerge\s+\#?(-?\d+)$/i) {
1061 $bug_affected{$ref} = 1;
1063 if (!length($data->{mergedwith})) {
1064 print {$transcript} "$gBug is not marked as being merged with any others.\n\n";
1067 $mergelowstate eq 'locked' || die "$mergelowstate ?";
1068 $action= "Disconnected #$ref from all other report(s).";
1069 my @newmergelist= split(/ /,$data->{mergedwith});
1071 @bug_affected{@newmergelist} = 1 x @newmergelist;
1073 $affected_packages{$data->{package}} = 1;
1074 add_recipients(data => $data,
1075 recipients => \%recipients,
1076 transcript => $transcript,
1077 ($dl > 0 ? (debug => $transcript):()),
1079 $data->{mergedwith}= ($ref == $discref) ? ''
1080 : join(' ',grep($_ ne $ref,@newmergelist));
1081 } while (&getnextbug);
1084 } elsif (m/^merge\s+#?(-?\d+(\s+#?-?\d+)+)\s*$/i) {
1086 my @tomerge= sort { $a <=> $b } split(/\s+#?/,$1);
1087 my @newmergelist= ();
1092 while (defined($ref= shift(@tomerge))) {
1093 print {$transcript} "D| checking merge $ref\n" if $dl;
1095 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
1096 $ref = $clonebugs{$ref};
1098 next if grep($_ == $ref,@newmergelist);
1099 if (!&getbug) { ¬foundbug; @newmergelist=(); last }
1100 if (!&checkpkglimit) { &cancelbug; @newmergelist=(); last; }
1102 print {$transcript} "D| adding $ref ($data->{mergedwith})\n" if $dl;
1104 &checkmatch('package','m_package',$data->{package},@newmergelist);
1105 &checkmatch('forwarded addr','m_forwarded',$data->{forwarded},@newmergelist);
1106 $data->{severity} = '$gDefaultSeverity' if $data->{severity} eq '';
1107 &checkmatch('severity','m_severity',$data->{severity},@newmergelist);
1108 &checkmatch('blocks','m_blocks',$data->{blocks},@newmergelist);
1109 &checkmatch('blocked-by','m_blockedby',$data->{blockedby},@newmergelist);
1110 &checkmatch('done mark','m_done',length($data->{done}) ? 'done' : 'open',@newmergelist);
1111 &checkmatch('owner','m_owner',$data->{owner},@newmergelist);
1112 &checkmatch('summary','m_summary',$data->{summary},@newmergelist);
1113 &checkmatch('affects','m_affects',$data->{affects},@newmergelist);
1114 foreach my $t (split /\s+/, $data->{keywords}) { $tags{$t} = 1; }
1115 foreach my $f (@{$data->{found_versions}}) { $found{$f} = 1; }
1116 foreach my $f (@{$data->{fixed_versions}}) { $fixed{$f} = 1; }
1117 if (length($mismatch)) {
1118 print {$transcript} "Mismatch - only $gBugs in same state can be merged:\n".
1121 &cancelbug; @newmergelist=(); last;
1123 push(@newmergelist,$ref);
1124 push(@tomerge,split(/ /,$data->{mergedwith}));
1127 if (@newmergelist) {
1128 @newmergelist= sort { $a <=> $b } @newmergelist;
1129 $action= "Merged @newmergelist.";
1130 delete @fixed{keys %found};
1131 for $ref (@newmergelist) {
1132 &getbug || die "huh ? $gBug $ref disappeared during merge";
1133 $affected_packages{$data->{package}} = 1;
1134 add_recipients(data => $data,
1135 recipients => \%recipients,
1136 transcript => $transcript,
1137 ($dl > 0 ? (debug => $transcript):()),
1139 @bug_affected{@newmergelist} = 1 x @newmergelist;
1140 $data->{mergedwith}= join(' ',grep($_ != $ref,@newmergelist));
1141 $data->{keywords}= join(' ', keys %tags);
1142 $data->{found_versions}= [sort keys %found];
1143 $data->{fixed_versions}= [sort keys %fixed];
1146 print {$transcript} "$action\n\n";
1149 } elsif (m/^forcemerge\s+\#?(-?\d+(?:\s+\#?-?\d+)+)\s*$/i) {
1151 my @temp = split /\s+\#?/,$1;
1152 my $master_bug = shift @temp;
1153 my $master_bug_data;
1154 my @tomerge = sort { $a <=> $b } @temp;
1155 unshift @tomerge,$master_bug;
1156 print {$transcript} "D| force merging ".join(',',@tomerge)."\n" if $dl;
1157 my @newmergelist= ();
1161 # Here we try to do the right thing.
1162 # First, if the bugs are in the same package, we merge all of the found, fixed, and tags.
1163 # If not, we discard the found and fixed.
1164 # Everything else we set to the values of the first bug.
1166 while (defined($ref= shift(@tomerge))) {
1167 print {$transcript} "D| checking merge $ref\n" if $dl;
1169 if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
1170 $ref = $clonebugs{$ref};
1172 next if grep($_ == $ref,@newmergelist);
1173 if (!&getbug) { ¬foundbug; @newmergelist=(); last }
1174 if (!&checkpkglimit) { &cancelbug; @newmergelist=(); last; }
1176 print {$transcript} "D| adding $ref ($data->{mergedwith})\n" if $dl;
1177 $master_bug_data = $data if not defined $master_bug_data;
1178 if ($data->{package} ne $master_bug_data->{package}) {
1179 print {$transcript} "Mismatch - only $gBugs in the same package can be forcibly merged:\n".
1180 "$gBug $ref is not in the same package as $master_bug\n";
1182 &cancelbug; @newmergelist=(); last;
1184 for my $t (split /\s+/,$data->{keywords}) {
1187 @found{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1188 @fixed{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1189 push(@newmergelist,$ref);
1190 push(@tomerge,split(/ /,$data->{mergedwith}));
1193 if (@newmergelist) {
1194 @newmergelist= sort { $a <=> $b } @newmergelist;
1195 $action= "Forcibly Merged @newmergelist.";
1196 delete @fixed{keys %found};
1197 for $ref (@newmergelist) {
1198 &getbug || die "huh ? $gBug $ref disappeared during merge";
1199 $affected_packages{$data->{package}} = 1;
1200 add_recipients(data => $data,
1201 recipients => \%recipients,
1202 transcript => $transcript,
1203 ($dl > 0 ? (debug => $transcript):()),
1205 @bug_affected{@newmergelist} = 1 x @newmergelist;
1206 $data->{mergedwith}= join(' ',grep($_ != $ref,@newmergelist));
1207 $data->{keywords}= join(' ', keys %tags);
1208 $data->{found_versions}= [sort keys %found];
1209 $data->{fixed_versions}= [sort keys %fixed];
1210 my @field_list = qw(forwarded package severity blocks blockedby owner done affects summary);
1211 @{$data}{@field_list} = @{$master_bug_data}{@field_list};
1214 print {$transcript} "$action\n\n";
1217 } elsif (m/^clone\s+#?(\d+)\s+((-\d+\s+)*-\d+)\s*$/i) {
1221 my @newclonedids = split /\s+/, $2;
1222 my $newbugsneeded = scalar(@newclonedids);
1225 $bug_affected{$ref} = 1;
1227 $affected_packages{$data->{package}} = 1;
1228 if (length($data->{mergedwith})) {
1229 print {$transcript} "$gBug is marked as being merged with others. Use an existing clone.\n\n";
1233 &filelock("nextnumber.lock");
1234 open(N,"nextnumber") || die "nextnumber: read: $!";
1235 my $v=<N>; $v =~ s/\n$// || die "nextnumber bad format";
1236 my $firstref= $v+0; $v += $newbugsneeded;
1237 open(NN,">nextnumber"); print NN "$v\n"; close(NN);
1240 my $lastref = $firstref + $newbugsneeded - 1;
1242 if ($newbugsneeded == 1) {
1243 $action= "$gBug $origref cloned as bug $firstref.";
1245 $action= "$gBug $origref cloned as bugs $firstref-$lastref.";
1248 my $blocks = $data->{blocks};
1249 my $blockedby = $data->{blockedby};
1252 my $ohash = get_hashname($origref);
1253 my $clone = $firstref;
1254 @bug_affected{@newclonedids} = 1 x @newclonedids;
1255 for my $newclonedid (@newclonedids) {
1256 $clonebugs{$newclonedid} = $clone;
1258 my $hash = get_hashname($clone);
1259 copy("db-h/$ohash/$origref.log", "db-h/$hash/$clone.log");
1260 copy("db-h/$ohash/$origref.status", "db-h/$hash/$clone.status");
1261 copy("db-h/$ohash/$origref.summary", "db-h/$hash/$clone.summary");
1262 copy("db-h/$ohash/$origref.report", "db-h/$hash/$clone.report");
1263 &bughook('new', $clone, $data);
1265 # Update blocking info of bugs blocked by or blocking the
1267 foreach $ref (split ' ', $blocks) {
1269 $data->{blockedby} = manipset($data->{blockedby}, $clone, 1);
1272 foreach $ref (split ' ', $blockedby) {
1274 $data->{blocks} = manipset($data->{blocks}, $clone, 1);
1282 } elsif (m/^package\:?\s+(\S.*\S)?\s*$/i) {
1284 my @pkgs = split /\s+/, $1;
1285 if (scalar(@pkgs) > 0) {
1286 %limit_pkgs = map { ($_, 1) } @pkgs;
1287 print {$transcript} "Ignoring bugs not assigned to: " .
1288 join(" ", keys(%limit_pkgs)) . "\n\n";
1291 print {$transcript} "Not ignoring any bugs.\n\n";
1293 } elsif (m/^affects?\s+\#?(-?\d+)(?:\s+((?:[=+-])?)\s*(\S.*)?)?\s*$/i) {
1296 my $add_remove = $2 || '';
1297 my $packages = $3 || '';
1298 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1299 $bug_affected{$ref} = 1;
1301 affects(bug => $ref,
1302 transcript => $transcript,
1303 ($dl > 0 ? (debug => $transcript):()),
1304 requester => $header{from},
1305 request_addr => $controlrequestaddr,
1307 recipients => \%recipients,
1308 packages => [splitpackages($3)],
1309 ($add_remove eq '+'?(add => 1):()),
1310 ($add_remove eq '-'?(remove => 1):()),
1315 print {$transcript} "Failed to mark $ref as affecting package(s): $@";
1318 } elsif (m/^summary\s+\#?(-?\d+)\s*(\d+|)\s*$/i) {
1321 my $summary_msg = length($2)?$2:undef;
1322 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1323 $bug_affected{$ref} = 1;
1325 summary(bug => $ref,
1326 transcript => $transcript,
1327 ($dl > 0 ? (debug => $transcript):()),
1328 requester => $header{from},
1329 request_addr => $controlrequestaddr,
1331 recipients => \%recipients,
1332 summary => $summary_msg,
1337 print {$transcript} "Failed to give $ref a summary: $@";
1340 } elsif (m/^owner\s+\#?(-?\d+)\s+((?:\S.*\S)|\!)\s*$/i) {
1343 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1345 if ($newowner eq '!') {
1346 $newowner = $replyto;
1348 $bug_affected{$ref} = 1;
1351 transcript => $transcript,
1352 ($dl > 0 ? (debug => $transcript):()),
1353 requester => $header{from},
1354 request_addr => $controlrequestaddr,
1356 recipients => \%recipients,
1362 print {$transcript} "Failed to mark $ref as having an owner: $@";
1364 } elsif (m/^noowner\s+\#?(-?\d+)\s*$/i) {
1367 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1368 $bug_affected{$ref} = 1;
1371 transcript => $transcript,
1372 ($dl > 0 ? (debug => $transcript):()),
1373 requester => $header{from},
1374 request_addr => $controlrequestaddr,
1376 recipients => \%recipients,
1382 print {$transcript} "Failed to mark $ref as not having an owner: $@";
1384 } elsif (m/^unarchive\s+#?(\d+)$/i) {
1387 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1388 $bug_affected{$ref} = 1;
1390 bug_unarchive(bug => $ref,
1391 transcript => $transcript,
1392 ($dl > 0 ? (debug => $transcript):()),
1393 affected_bugs => \%bug_affected,
1394 requester => $header{from},
1395 request_addr => $controlrequestaddr,
1397 recipients => \%recipients,
1403 } elsif (m/^archive\s+#?(\d+)$/i) {
1406 $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1407 $bug_affected{$ref} = 1;
1409 bug_archive(bug => $ref,
1410 transcript => $transcript,
1411 ($dl > 0 ? (debug => $transcript):()),
1413 archive_unarchived => 0,
1414 affected_bugs => \%bug_affected,
1415 requester => $header{from},
1416 request_addr => $controlrequestaddr,
1418 recipients => \%recipients,
1425 print {$transcript} "Unknown command or malformed arguments to command.\n\n";
1427 if (++$unknowns >= 5) {
1428 print {$transcript} "Too many unknown commands, stopping here.\n\n";
1433 if ($procline>$#bodylines) {
1434 print {$transcript} ">\nEnd of message, stopping processing here.\n\n";
1436 if (!$ok && !$quickabort) {
1438 print {$transcript} "No commands successfully parsed; sending the help text(s).\n";
1440 print {$transcript} "\n";
1443 my @maintccs = determine_recipients(recipients => \%recipients,
1447 my $maintccs = 'Cc: '.join(",\n ",
1448 determine_recipients(recipients => \%recipients,
1454 $packagepr = "X-${gProject}-PR-Package: " . join(keys %affected_packages) . "\n" if keys %affected_packages;
1456 # Add Bcc's to subscribed bugs
1457 # now handled by Debbugs::Recipients
1458 #push @bcc, map {"bugs=$_\@$gListDomain"} keys %bug_affected;
1460 if (!defined $header{'subject'} || $header{'subject'} eq "") {
1461 $header{'subject'} = "your mail";
1464 # Error text here advertises how many errors there were
1465 my $error_text = $errors > 0 ? " (with $errors errors)":'';
1468 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1470 ${maintccs}Subject: Processed${error_text}: $header{'subject'}
1471 In-Reply-To: $header{'message-id'}
1474 References: $header{'message-id'}
1475 Message-ID: <handler.s.$nn.transcript\@$gEmailDomain>
1477 ${packagepr}X-$gProject-PR-Message: transcript
1479 ${transcript_scalar}Please contact me if you need assistance.
1482 (administrator, $gProject $gBugs database)
1485 my $repliedshow= join(', ',$replyto,
1486 determine_recipients(recipients => \%recipients,
1491 # -1 is the service.in log
1492 &filelock("lock/-1");
1493 open(AP,">>db-h/-1.log") || die "open db-h/-1.log: $!";
1495 "\2\n$repliedshow\n\5\n$reply\n\3\n".
1497 "<strong>Request received</strong> from <code>".
1498 html_escape($header{'from'})."</code>\n".
1499 "to <code>".html_escape($controlrequestaddr)."</code>\n".
1501 "\7\n",escape_log(@log),"\n\3\n") || die "writing db-h/-1.log: $!";
1502 close(AP) || die "open db-h/-1.log: $!";
1504 utime(time,time,"db-h");
1506 &sendmailmessage($reply,
1507 exists $header{'x-debbugs-no-ack'}?():$replyto,
1508 make_list(values %{{determine_recipients(recipients => \%recipients,
1514 unlink("incoming/P$nn") || die "unlinking incoming/P$nn: $!";
1516 sub sendmailmessage {
1517 my ($message,@recips) = @_;
1518 $message = "X-Loop: $gMaintainerEmail\n" . $message;
1519 send_mail_message(message => $message,
1520 recipients => \@recips,
1526 my ($template,$extra_var) = @_;
1528 my $variables = {config => \%config,
1529 defined($ref)?(ref => $ref):(),
1530 defined($data)?(data => $data):(),
1533 my $hole_var = {'&bugurl' =>
1535 'http://'.$config{cgi_domain}.'/'.
1536 Debbugs::CGI::bug_url($_[0]);
1539 return fill_in_template(template => $template,
1540 variables => $variables,
1541 hole_var => $hole_var,
1545 =head2 message_body_template
1547 message_body_template('mail/ack',{ref=>'foo'});
1549 Creates a message body using a template
1553 sub message_body_template{
1554 my ($template,$extra_var) = @_;
1556 my $body = fill_template($template,$extra_var);
1557 return fill_template('mail/message_body',
1566 &sendtxthelpraw("bug-maint-mailcontrol.txt","instructions for control\@$gEmailDomain")
1569 &sendtxthelpraw("bug-log-mailserver.txt","instructions for request\@$gEmailDomain");
1573 #sub unimplemented {
1574 # print {$transcript} "Sorry, command $_[0] not yet implemented.\n\n";
1576 our %checkmatch_values;
1578 my ($string,$mvarname,$svarvalue,@newmergelist) = @_;
1580 if (@newmergelist) {
1581 $mvarvalue = $checkmatch_values{$mvarname};
1582 print {$transcript} "D| checkmatch \`$string' /$mvarname/$mvarvalue/$svarvalue/\n"
1585 "Values for \`$string' don't match:\n".
1586 " #$newmergelist[0] has \`$mvarvalue';\n".
1587 " #$ref has \`$svarvalue'\n"
1588 if $mvarvalue ne $svarvalue;
1590 print {$transcript} "D| setupmatch \`$string' /$mvarname/$svarvalue/\n"
1592 $checkmatch_values{$mvarname} = $svarvalue;
1597 if (keys %limit_pkgs and not defined $limit_pkgs{$data->{package}}) {
1598 print {$transcript} "$gBug number $ref belongs to package $data->{package}, skipping.\n\n";
1610 my %h = map { $_ => 1 } split ' ', $list;
1617 return join ' ', sort keys %h;
1620 # High-level bug manipulation calls
1621 # Do announcements themselves
1623 # Possible calling sequences:
1624 # setbug (returns 0)
1626 # setbug (returns 1)
1627 # &transcript(something)
1630 # setbug (returns 1)
1631 # $action= (something)
1633 # (modify s_* variables)
1634 # } while (getnextbug);
1639 &dlen("nochangebug");
1640 $state eq 'single' || $state eq 'multiple' || die "$state ?";
1642 &endmerge if $manybugs;
1644 &dlex("nochangebug");
1648 our @thisbugmergelist;
1651 &dlen("setbug $ref");
1652 if ($ref =~ m/^-\d+/) {
1653 if (!defined $clonebugs{$ref}) {
1655 &dlex("setbug => noclone");
1658 $ref = $clonebugs{$ref};
1660 $state eq 'idle' || die "$state ?";
1663 &dlex("setbug => 0s");
1667 if (!&checkpkglimit) {
1672 @thisbugmergelist= split(/ /,$data->{mergedwith});
1673 if (!@thisbugmergelist) {
1678 &dlex("setbug => 1s");
1687 &dlex("setbug => 0mc");
1691 $state= 'multiple'; $sref=$ref;
1692 &dlex("setbug => 1m");
1697 &dlen("getnextbug");
1698 $state eq 'single' || $state eq 'multiple' || die "$state ?";
1700 if (!$manybugs || !@thisbugmergelist) {
1701 length($action) || die;
1702 print {$transcript} "$action\n$extramessage\n";
1703 &endmerge if $manybugs;
1705 &dlex("getnextbug => 0");
1708 $ref= shift(@thisbugmergelist);
1709 &getbug || die "bug $ref disappeared";
1711 &dlex("getnextbug => 1");
1715 # Low-level bug-manipulation calls
1716 # Do no announcements
1718 # getbug (returns 0)
1720 # getbug (returns 1)
1724 # $action= (something)
1725 # getbug (returns 1)
1727 # getbug (returns 1)
1729 # [getbug (returns 0)]
1730 # &transcript("$action\n\n")
1733 sub notfoundbug { print {$transcript} "$gBug number $ref not found. (Is it archived?)\n\n"; }
1734 sub foundbug { print {$transcript} "$gBug#$ref: $data->{subject}\n"; }
1738 $mergelowstate eq 'idle' || die "$mergelowstate ?";
1739 &filelock('lock/merge');
1740 $mergelowstate='locked';
1746 $mergelowstate eq 'locked' || die "$mergelowstate ?";
1748 $mergelowstate='idle';
1753 &dlen("getbug $ref");
1754 $lowstate eq 'idle' || die "$state ?";
1755 # Only use unmerged bugs here
1756 if (($data = &lockreadbug($ref,'db-h'))) {
1759 &dlex("getbug => 1");
1764 &dlex("getbug => 0");
1770 $lowstate eq 'open' || die "$state ?";
1777 &dlen("savebug $ref");
1778 $lowstate eq 'open' || die "$lowstate ?";
1779 length($action) || die;
1780 $ref == $sref || die "read $sref but saving $ref ?";
1781 append_action_to_log(bug => $ref,
1783 requester => $header{from},
1784 request_addr => $controlrequestaddr,
1788 unlockwritebug($ref, $data);
1795 print {$transcript} "C> @_ ($state $lowstate $mergelowstate)\n";
1800 print {$transcript} "R> @_ ($state $lowstate $mergelowstate)\n";
1807 my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
1808 $url =~ s/([<>&"])/\&$saniarray{$1};/g;
1814 print {$transcript} "\n";
1820 print {$transcript} "\n";
1826 sub sendtxthelpraw {
1827 my ($relpath,$description) = @_;
1829 if (not -e "$gDocDir/$relpath") {
1830 print {$transcript} "Unfortunatly, the help text doesn't exist, so it wasn't sent.\n";
1831 warn "Help text $gDocDir/$relpath not found";
1834 open(D,"$gDocDir/$relpath") || die "open doc file $relpath: $!";
1835 while(<D>) { $doc.=$_; }
1837 print {$transcript} "Sending $description in separate message.\n";
1838 &sendmailmessage(<<END.$doc,$replyto);
1839 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1841 Subject: $gProject $gBug help: $description
1842 References: $header{'message-id'}
1843 In-Reply-To: $header{'message-id'}
1844 Message-ID: <handler.s.$nn.help.$midix\@$gEmailDomain>
1846 X-$gProject-PR-Message: doc-text $relpath
1852 sub sendlynxdocraw {
1853 my ($relpath,$description) = @_;
1855 open(L,"lynx -nolist -dump http://$gCGIDomain/\Q$relpath\E 2>&1 |") || die "fork for lynx: $!";
1856 while(<L>) { $doc.=$_; }
1858 if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
1859 print {$transcript} "Information ($description) is not available -\n".
1860 "perhaps the $gBug does not exist or is not on the WWW yet.\n";
1863 print {$transcript} "Error getting $description (code $? $!):\n$doc\n";
1865 print {$transcript} "Sending $description.\n";
1866 &sendmailmessage(<<END.$doc,$replyto);
1867 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1869 Subject: $gProject $gBugs information: $description
1870 References: $header{'message-id'}
1871 In-Reply-To: $header{'message-id'}
1872 Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
1874 X-$gProject-PR-Message: doc-html $relpath
1883 my ($wherefrom,$path,$description) = @_;
1884 if ($wherefrom eq "ftp.d.o") {
1885 $doc = `lynx -nolist -dump http://ftp.debian.org/debian/indices/$path.gz 2>&1 | gunzip -cf` or die "fork for lynx/gunzip: $!";
1887 if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
1888 print {$transcript} "$description is not available.\n";
1891 print {$transcript} "Error getting $description (code $? $!):\n$doc\n";
1894 } elsif ($wherefrom eq "local") {
1896 $doc = do { local $/; <P> };
1899 print {$transcript} "internal errror: info files location unknown.\n";
1902 print {$transcript} "Sending $description.\n";
1903 &sendmailmessage(<<END.$doc,$replyto);
1904 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1906 Subject: $gProject $gBugs information: $description
1907 References: $header{'message-id'}
1908 In-Reply-To: $header{'message-id'}
1909 Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
1911 X-$gProject-PR-Message: getinfo
1913 $description follows:
1917 print {$transcript} "\n";