scripts/service

   1 #!/usr/bin/perl
   2 # $Id: service.in,v 1.118 2005/10/19 01:22:14 don Exp $
   3 #
   4 # Usage: service <code>.nn
   5 # Temps:  incoming/P<code>.nn
   6
   7 use warnings;
   8 use strict;
   9
  10
  11 use Debbugs::Config qw(:globals :config);
  12
  13 use File::Copy;
  14 use MIME::Parser;
  15
  16 use Params::Validate qw(:types validate_with);
  17
  18 use Debbugs::Common qw(:util :quit :misc :lock);
  19
  20 use Debbugs::Status qw(:read :status :write :versions :hook);
  21
  22 use Debbugs::MIME qw(decode_rfc1522 encode_rfc1522);
  23 use Debbugs::Mail qw(send_mail_message);
  24 use Debbugs::User;
  25 use Debbugs::Recipients qw(:all);
  26 use HTML::Entities qw(encode_entities);
  27 use Debbugs::Versions::Dpkg;
  28
  29 use Debbugs::Status qw(splitpackages);
  30
  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);
  35
  36 use Scalar::Util qw(looks_like_number);
  37
  38 use List::Util qw(first);
  39
  40 use Mail::RFC822::Address;
  41
  42 chdir($config{spool_dir}) or
  43      die "Unable to chdir to spool_dir '$config{spool_dir}': $!";
  44
  45 my $debug = 0;
  46 umask(002);
  47
  48 my ($nn,$control) = $ARGV[0] =~ m/^(([RC])\.\d+)$/;
  49 if (not defined $control or not defined $nn) {
  50      die "Bad argument to service.in";
  51 }
  52 if (!rename("incoming/G$nn","incoming/P$nn")) {
  53     defined $! and $! =~ m/no such file or directory/i and exit 0;
  54     die "Failed to rename incoming/G$nn to incoming/P$nn: $!";
  55 }
  56
  57 my $log_fh = IO::File->new("incoming/P$nn",'r') or
  58      die "Unable to open incoming/P$nn for reading: $!";
  59 my @log=<$log_fh>;
  60 my @msg=@log;
  61 close($log_fh);
  62
  63 chomp @msg;
  64
  65 print "###\n",join("##\n",@msg),"\n###\n" if $debug;
  66
  67 # Bug numbers to send e-mail to, hash so that we don't send to the
  68 # same bug twice.
  69 my (%bug_affected);
  70
  71 my (@headerlines,@bodylines);
  72
  73 my $parse_output = Debbugs::MIME::parse(join('',@log));
  74 @headerlines = @{$parse_output->{header}};
  75 @bodylines = @{$parse_output->{body}};
  76
  77 my %header;
  78 for (@headerlines) {
  79     $_ = decode_rfc1522($_);
  80     s/\n\s/ /g;
  81     print ">$_<\n" if $debug;
  82     if (s/^(\S+):\s*//) {
  83         my $v = lc $1;
  84         print ">$v=$_<\n" if $debug;
  85         $header{$v} = $_;
  86     } else {
  87         print "!>$_<\n" if $debug;
  88     }
  89 }
  90 $header{'message-id'} ||= '';
  91 $header{subject} ||= '';
  92
  93 grep(s/\s+$//,@bodylines);
  94
  95 print "***\n",join("\n",@bodylines),"\n***\n" if $debug;
  96
  97 if (defined $header{'resent-from'} && !defined $header{'from'}) {
  98     $header{'from'} = $header{'resent-from'};
  99 }
 100
 101 defined($header{'from'}) || die "no From header";
 102
 103 delete $header{'reply-to'}
 104         if ( defined($header{'reply-to'}) && $header{'reply-to'} =~ m/^\s*$/ );
 105
 106 my $replyto;
 107 if ( defined($header{'reply-to'}) && $header{'reply-to'} ne "" ) {
 108     $replyto = $header{'reply-to'};
 109 } else {
 110     $replyto = $header{'from'};
 111 }
 112
 113 # This is an error counter which should be incremented every time there is an error.
 114 my $errors = 0;
 115 my $controlrequestaddr= ($control ? 'control' : 'request').'@'.$config{email_domain};
 116 my $transcript_scalar = '';
 117 my $transcript = IO::Scalar->new(\$transcript_scalar) or
 118      die "Unable to create new IO::Scalar";
 119 print {$transcript} "Processing commands for $controlrequestaddr:\n\n";
 120
 121
 122 my $dl = 0;
 123 my %affected_packages;
 124 my %recipients;
 125
 126 my @common_control_options =
 127     (($dl > 0 ? (debug => $transcript):()),
 128      transcript        => $transcript,
 129      requester         => $header{from},
 130      request_addr      => $controlrequestaddr,
 131      request_msgid     => $header{'message-id'},
 132      request_subject   => $header{subject},
 133      request_nn        => $nn,
 134      request_replyto   => $replyto,
 135      message           => \@log,
 136      affected_packages => \%affected_packages,
 137      recipients        => \%recipients,
 138     );
 139
 140 my $state= 'idle';
 141 my $lowstate= 'idle';
 142 my $mergelowstate= 'idle';
 143 my $midix=0;
 144
 145 my $user = $replyto;
 146 $user =~ s/,.*//;
 147 $user =~ s/^.*<(.*)>.*$/$1/;
 148 $user =~ s/[(].*[)]//;
 149 $user =~ s/^\s*(\S+)\s+.*$/$1/;
 150 $user = "" unless (Debbugs::User::is_valid_user($user));
 151 my $indicated_user = 0;
 152
 153 my $quickabort = 0;
 154
 155
 156 if (@gExcludeFromControl and grep {$replyto =~ m/\Q$_\E/} @gExcludeFromControl) {
 157         print {$transcript} fill_template('mail/excluded_from_control');
 158         $quickabort = 1;
 159 }
 160
 161 my %limit_pkgs = ();
 162 my %clonebugs = ();
 163 my %bcc = ();
 164
 165
 166 my @bcc;
 167 sub addbcc {
 168     push @bcc, $_[0] unless grep { $_ eq $_[0] } @bcc;
 169 }
 170
 171 our $data;
 172 our $message;
 173 our $extramessage;
 174 our $ref;
 175
 176 our $mismatch;
 177 our $action;
 178
 179
 180 my $ok = 0;
 181 my $unknowns = 0;
 182 my $procline=0;
 183 for ($procline=0; $procline<=$#bodylines; $procline++) {
 184     my $noriginator;
 185     my $newsubmitter;
 186     my $oldsubmitter;
 187     my $newowner;
 188     $state eq 'idle' || print "state: $state ?\n";
 189     $lowstate eq 'idle' || print "lowstate: $lowstate ?\n";
 190     $mergelowstate eq 'idle' || print "mergelowstate: $mergelowstate ?\n";
 191     if ($quickabort) {
 192          print {$transcript} "Stopping processing here.\n\n";
 193          last;
 194     }
 195     $_= $bodylines[$procline]; s/\s+$//;
 196     # Remove BOM markers from UTF-8 strings
 197     # Fixes #488554
 198     s/\xef\xbb\xbf//g;
 199     next unless m/\S/;
 200     print {$transcript} "> $_\n";
 201     next if m/^\s*\#/;
 202     $action= '';
 203     if (m/^stop\s*$/i || m/^quit\s*$/i || m/^--\s*$/ || m/^thank(?:s|\s*you)?\s*$/i || m/^kthxbye\s*$/i) {
 204         print {$transcript} "Stopping processing here.\n\n";
 205         last;
 206     } elsif (m/^debug\s+(\d+)$/i && $1 >= 0 && $1 <= 1000) {
 207         $dl= $1+0;
 208         print {$transcript} "Debug level $dl.\n\n";
 209     } elsif (m/^(send|get)\s+\#?(\d{2,})$/i) {
 210         $ref= $2+0;
 211         &sendlynxdoc("bugreport.cgi?bug=$ref","logs for $gBug#$ref");
 212     } elsif (m/^send-detail\s+\#?(\d{2,})$/i) {
 213         $ref= $1+0;
 214         &sendlynxdoc("bugreport.cgi?bug=$ref&boring=yes",
 215                      "detailed logs for $gBug#$ref");
 216     } elsif (m/^index(\s+full)?$/i) {
 217         print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
 218         $errors++;
 219         $ok++; # well, it's not really ok, but it fixes #81224 :)
 220     } elsif (m/^index-summary\s+by-package$/i) {
 221         print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
 222         $errors++;
 223         $ok++; # well, it's not really ok, but it fixes #81224 :)
 224     } elsif (m/^index-summary(\s+by-number)?$/i) {
 225         print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
 226         $errors++;
 227         $ok++; # well, it's not really ok, but it fixes #81224 :)
 228     } elsif (m/^index(\s+|-)pack(age)?s?$/i) {
 229         &sendlynxdoc("pkgindex.cgi?indexon=pkg",'index of packages');
 230     } elsif (m/^index(\s+|-)maints?$/i) {
 231         &sendlynxdoc("pkgindex.cgi?indexon=maint",'index of maintainers');
 232     } elsif (m/^index(\s+|-)maint\s+(\S+)$/i) {
 233         my $maint = $2;
 234         &sendlynxdoc("pkgreport.cgi?maint=" . urlsanit($maint),
 235                      "$gBug list for maintainer \`$maint'");
 236         $ok++;
 237     } elsif (m/^index(\s+|-)pack(age)?s?\s+(\S.*\S)$/i) {
 238         my $package = $+;
 239         &sendlynxdoc("pkgreport.cgi?pkg=" . urlsanit($package),
 240                      "$gBug list for package $package");
 241         $ok++;
 242     } elsif (m/^send-unmatched(\s+this|\s+-?0)?$/i) {
 243         print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
 244         $errors++;
 245         $ok++; # well, it's not really ok, but it fixes #81224 :)
 246     } elsif (m/^send-unmatched\s+(last|-1)$/i) {
 247         print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
 248         $errors++;
 249         $ok++; # well, it's not really ok, but it fixes #81224 :)
 250     } elsif (m/^send-unmatched\s+(old|-2)$/i) {
 251         print {$transcript} "This BTS function is currently disabled, sorry.\n\n";
 252         $errors++;
 253         $ok++; # well, it's not really ok, but it fixes #81224 :)
 254     } elsif (m/^getinfo\s+([\w.-]+)$/i) {
 255         # the following is basically a Debian-specific kludge, but who cares
 256         my $req = $1;
 257         if ($req =~ /^maintainers$/i && -f "$gConfigDir/Maintainers") {
 258             &sendinfo("local", "$gConfigDir/Maintainers", "Maintainers file");
 259         } elsif ($req =~ /^override\.(\w+)\.([\w.-]+)$/i) {
 260             $req =~ s/.gz$//;
 261             &sendinfo("ftp.d.o", "$req", "override file for $2 part of $1 distribution");
 262         } elsif ($req =~ /^pseudo-packages\.(description|maintainers)$/i && -f "$gConfigDir/$req") {
 263             &sendinfo("local", "$gConfigDir/$req", "$req file");
 264         } else {
 265             print {$transcript} "Info file $req does not exist.\n\n";
 266         }
 267     } elsif (m/^help/i) {
 268         &sendhelp;
 269         print {$transcript} "\n";
 270         $ok++;
 271     } elsif (m/^refcard/i) {
 272         &sendtxthelp("bug-mailserver-refcard.txt","mail servers' reference card");
 273     } elsif (m/^subscribe/i) {
 274         print {$transcript} <<END;
 275 There is no $gProject $gBug mailing list.  If you wish to review bug reports
 276 please do so via http://$gWebDomain/ or ask this mail server
 277 to send them to you.
 278 soon: MAILINGLISTS_TEXT
 279 END
 280     } elsif (m/^unsubscribe/i) {
 281         print {$transcript} <<END;
 282 soon: UNSUBSCRIBE_TEXT
 283 soon: MAILINGLISTS_TEXT
 284 END
 285     } elsif (m/^user\s+(\S+)\s*$/i) {
 286         my $newuser = $1;
 287         if (Debbugs::User::is_valid_user($newuser)) {
 288             my $olduser = ($user ne "" ? " (was $user)" : "");
 289             print {$transcript} "Setting user to $newuser$olduser.\n";
 290             $user = $newuser;
 291             $indicated_user = 1;
 292         } else {
 293             print {$transcript} "Selected user id ($newuser) invalid, sorry\n";
 294             $errors++;
 295             $user = "";
 296             $indicated_user = 1;
 297         }
 298     } elsif (m/^usercategory\s+(\S+)(\s+\[hidden\])?\s*$/i) {
 299         $ok++;
 300         my $catname = $1;
 301         my $hidden = (defined $2 and $2 ne "");
 302
 303         my $prefix = "";
 304         my @cats;
 305         my $bad = 0;
 306         my $catsec = 0;
 307         if ($user eq "") {
 308             print {$transcript} "No valid user selected\n";
 309             $errors++;
 310             next;
 311         }
 312         if (not $indicated_user and defined $user) {
 313              print {$transcript} "User is $user\n";
 314              $indicated_user = 1;
 315         }
 316         my @ords = ();
 317         while (++$procline <= $#bodylines) {
 318             unless ($bodylines[$procline] =~ m/^\s*([*+])\s*(\S.*)$/) {
 319                 $procline--;
 320                 last;
 321             }
 322             print {$transcript} "> $bodylines[$procline]\n";
 323             next if $bad;
 324             my ($o, $txt) = ($1, $2);
 325             if ($#cats == -1 && $o eq "+") {
 326                 print {$transcript} "User defined category specification must start with a category name. Skipping.\n\n";
 327                 $errors++;
 328                 $bad = 1;
 329                 next;
 330             }
 331             if ($o eq "+") {
 332                 unless (ref($cats[-1]) eq "HASH") {
 333                     $cats[-1] = { "nam" => $cats[-1],
 334                                   "pri" => [], "ttl" => [] };
 335                 }
 336                 $catsec++;
 337                 my ($desc, $ord, $op);
 338                 if ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?\]\s*$/) {
 339                     $desc = $1; $ord = $3; $op = "";
 340                 } elsif ($txt =~ m/^(.*\S)\s*\[((\d+):\s*)?(\S+)\]\s*$/) {
 341                     $desc = $1; $ord = $3; $op = $4;
 342                 } elsif ($txt =~ m/^([^[\s]+)\s*$/) {
 343                     $desc = ""; $op = $1;
 344                 } else {
 345                     print {$transcript} "Unrecognised syntax for category section. Skipping.\n\n";
 346                     $errors++;
 347                     $bad = 1;
 348                     next;
 349                 }
 350                 $ord = 999 unless defined $ord;
 351
 352                 if ($op) {
 353                     push @{$cats[-1]->{"pri"}}, $prefix . $op;
 354                     push @{$cats[-1]->{"ttl"}}, $desc;
 355                     push @ords, "$ord $catsec";
 356                 } else {
 357                     $cats[-1]->{"def"} = $desc;
 358                     push @ords, "$ord DEF";
 359                     $catsec--;
 360                 }
 361                 @ords = sort {
 362                     my ($a1, $a2, $b1, $b2) = split / /, "$a $b";
 363                     ((looks_like_number($a1) and looks_like_number($a2))?$a1 <=> $b1:$a1 cmp $b1) ||
 364                     ((looks_like_number($a2) and looks_like_number($b2))?$a2 <=> $b2:$a2 cmp $b2);
 365                 } @ords;
 366                 $cats[-1]->{"ord"} = [map { m/^.* (\S+)/; $1 eq "DEF" ? $catsec + 1 : $1 } @ords];
 367             } elsif ($o eq "*") {
 368                 $catsec = 0;
 369                 my ($name);
 370                 if ($txt =~ m/^(.*\S)(\s*\[(\S+)\])\s*$/) {
 371                     $name = $1; $prefix = $3;
 372                 } else {
 373                     $name = $txt; $prefix = "";
 374                 }
 375                 push @cats, $name;
 376             }
 377         }
 378         # XXX: got @cats, now do something with it
 379         my $u = Debbugs::User::get_user($user);
 380         if (@cats) {
 381             print {$transcript} "Added usercategory $catname.\n\n";
 382             $u->{"categories"}->{$catname} = [ @cats ];
 383             if (not $hidden) {
 384                  push @{$u->{visible_cats}},$catname;
 385             }
 386         } else {
 387             print {$transcript} "Removed usercategory $catname.\n\n";
 388             delete $u->{"categories"}->{$catname};
 389             @{$u->{visible_cats}} = grep {$_ ne $catname} @{$u->{visible_cats}};
 390         }
 391         $u->write();
 392     } elsif (m/^usertags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
 393         $ok++;
 394         $ref = $1;
 395         my $addsubcode = $3 || "+";
 396         my $tags = $4;
 397         if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
 398              $ref = $clonebugs{$ref};
 399         }
 400         if ($user eq "") {
 401             print {$transcript} "No valid user selected\n";
 402             $errors++;
 403             $indicated_user = 1;
 404         } elsif (&setbug) {
 405             if (not $indicated_user and defined $user) {
 406                  print {$transcript} "User is $user\n";
 407                  $indicated_user = 1;
 408             }
 409             &nochangebug;
 410             my %ut;
 411             Debbugs::User::read_usertags(\%ut, $user);
 412             my @oldtags = (); my @newtags = (); my @badtags = ();
 413             my %chtags;
 414             if (defined $tags and length $tags) {
 415                  for my $t (split /[,\s]+/, $tags) {
 416                       if ($t =~ m/^[a-zA-Z0-9.+\@-]+$/) {
 417                            $chtags{$t} = 1;
 418                       } else {
 419                            push @badtags, $t;
 420                       }
 421                  }
 422             }
 423             if (@badtags) {
 424                 print {$transcript} "Ignoring illegal tag/s: ".join(', ', @badtags).".\nPlease use only alphanumerics, at, dot, plus and dash.\n";
 425                 $errors++;
 426             }
 427             for my $t (keys %chtags) {
 428                 $ut{$t} = [] unless defined $ut{$t};
 429             }
 430             for my $t (keys %ut) {
 431                 my %res = map { ($_, 1) } @{$ut{$t}};
 432                 push @oldtags, $t if defined $res{$ref};
 433                 my $addop = ($addsubcode eq "+" or $addsubcode eq "=");
 434                 my $del = (defined $chtags{$t} ? $addsubcode eq "-"
 435                                                : $addsubcode eq "=");
 436                 $res{$ref} = 1 if ($addop && defined $chtags{$t});
 437                 delete $res{$ref} if ($del);
 438                 push @newtags, $t if defined $res{$ref};
 439                 $ut{$t} = [ sort { $a <=> $b } (keys %res) ];
 440             }
 441             if (@oldtags == 0) {
 442                 print {$transcript} "There were no usertags set.\n";
 443             } else {
 444                 print {$transcript} "Usertags were: " . join(" ", @oldtags) . ".\n";
 445             }
 446             print {$transcript} "Usertags are now: " . join(" ", @newtags) . ".\n";
 447             Debbugs::User::write_usertags(\%ut, $user);
 448         }
 449     } elsif (!$control) {
 450         print {$transcript} <<END;
 451 Unknown command or malformed arguments to command.
 452 (Use control\@$gEmailDomain to manipulate reports.)
 453
 454 END
 455         $errors++;
 456         if (++$unknowns >= 3) {
 457             print {$transcript} "Too many unknown commands, stopping here.\n\n";
 458             last;
 459         }
 460 #### "developer only" ones start here
 461     } elsif (m/^close\s+\#?(-?\d+)(?:\s+(\d.*))?$/i) {
 462         $ok++;
 463         $ref= $1;
 464         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 465         $bug_affected{$ref}=1;
 466         my $version= $2;
 467         if (&setbug) {
 468             print {$transcript} "'close' is deprecated; see http://$gWebDomain/Developer$gHTMLSuffix#closing.\n";
 469             if (length($data->{done}) and not defined($version)) {
 470                 print {$transcript} "$gBug is already closed, cannot re-close.\n\n";
 471                 &nochangebug;
 472             } else {
 473                 $action= "$gBug " .
 474                     (defined($version) ?
 475                         "marked as fixed in version $version" :
 476                         "closed") .
 477                     ", send any further explanations to $data->{originator}";
 478                 do {
 479                    $affected_packages{$data->{package}} = 1;
 480                    add_recipients(data => $data,
 481                                   recipients => \%recipients,
 482                                   actions_taken => {done => 1},
 483                                   transcript   => $transcript,
 484                                   ($dl > 0 ? (debug => $transcript):()),
 485                                  );
 486                     $data->{done}= $replyto;
 487                     my @keywords= split ' ', $data->{keywords};
 488                     my $extramessage = '';
 489                     if (grep $_ eq 'pending', @keywords) {
 490                         $extramessage= "Removed pending tag.\n";
 491                         $data->{keywords}= join ' ', grep $_ ne 'pending',
 492                                                 @keywords;
 493                     }
 494                     addfixedversions($data, $data->{package}, $version, 'binary');
 495
 496                     my $message= <<END;
 497 From: $gMaintainerEmail ($gProject $gBug Tracking System)
 498 To: $data->{originator}
 499 Subject: $gBug#$ref acknowledged by developer
 500          ($header{'subject'})
 501 References: $header{'message-id'} $data->{msgid}
 502 In-Reply-To: $data->{msgid}
 503 Message-ID: <handler.$ref.$nn.notifdonectrl.$midix\@$gEmailDomain>
 504 Reply-To: $ref\@$gEmailDomain
 505 X-$gProject-PR-Message: they-closed-control $ref
 506
 507 This is an automatic notification regarding your $gBug report
 508 #$ref: $data->{subject},
 509 which was filed against the $data->{package} package.
 510
 511 It has been marked as closed by one of the developers, namely
 512 $replyto.
 513
 514 You should be hearing from them with a substantive response shortly,
 515 in case you haven't already. If not, please contact them directly.
 516
 517 $gMaintainer
 518 (administrator, $gProject $gBugs database)
 519
 520 END
 521                     &sendmailmessage($message,$data->{originator});
 522                 } while (&getnextbug);
 523             }
 524         }
 525     } elsif (m/^reassign\s+\#?(-?\d+)\s+ # bug and command
 526                (?:(?:((?:src:|source:)?$config{package_name_re}) # new package
 527                (?:\s+((?:$config{package_name_re}\/)?
 528                        $config{package_version_re}))?)| # optional version
 529                ((?:src:|source:)?$config{package_name_re} # multiple package form
 530                (?:\s*\,\s*(?:src:|source:)?$config{package_name_re})+))
 531                \s*$/xi) {
 532         $ok++;
 533         $ref= $1;
 534         my @new_packages;
 535         if (not defined $2) {
 536             push @new_packages, split /\s*\,\s*/,$4;
 537         }
 538         else {
 539             push @new_packages, $2;
 540         }
 541         @new_packages = map {y/A-Z/a-z/; s/^(?:src|source):/src:/; $_;} @new_packages;
 542         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 543         $bug_affected{$ref}=1;
 544         my $version= $3;
 545         eval {
 546             set_package(@common_control_options,
 547                         bug          => $ref,
 548                         package      => \@new_packages,
 549                        );
 550             # if there is a version passed, we make an internal call
 551             # to set_found
 552             if (defined($version) && length $version) {
 553                 set_found(@common_control_options,
 554                           bug          => $ref,
 555                           version      => $version,
 556                          );
 557             }
 558         };
 559         if ($@) {
 560             $errors++;
 561             print {$transcript} "Failed to clear fixed versions and reopen on $ref: $@";
 562         }
 563     } elsif (m/^reopen\s+\#?(-?\d+)(?:\s+([\=\!]|(?:\S.*\S)))?$/i) {
 564         $ok++;
 565         $ref= $1;
 566         $bug_affected{$ref}=1;
 567         my $new_submitter = $2;
 568         if (defined $new_submitter) {
 569             if ($new_submitter eq '=') {
 570                 undef $new_submitter;
 571             }
 572             elsif ($new_submitter eq '!') {
 573                 $new_submitter = $replyto;
 574             }
 575         }
 576         eval {
 577             reopen(@common_control_options,
 578                    bug          => $ref,
 579                    submitter    => $new_submitter,
 580                   );
 581         };
 582         if ($@) {
 583             $errors++;
 584             print {$transcript} "Failed to reopen $ref: $@";
 585         }
 586     } elsif (m{^(?:(?i)found)\s+\#?(-?\d+)
 587                (?:\s+((?:$config{package_name_re}\/)?
 588                     $config{package_version_re}
 589                 # allow for multiple packages
 590                 (?:\s*,\s*(?:$config{package_name_re}\/)?
 591                     $config{package_version_re})*)
 592             )?$}x) {
 593         $ok++;
 594         $ref= $1;
 595         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 596         my @versions;
 597         if (defined $2) {
 598             @versions = split /\s*,\s*/,$2;
 599             eval {
 600                 set_found(@common_control_options,
 601                           bug          => $ref,
 602                           found        => \@versions,
 603                           add          => 1,
 604                          );
 605             };
 606             if ($@) {
 607                 $errors++;
 608                 print {$transcript} "Failed to add found on $ref: $@";
 609             }
 610         }
 611         else {
 612             eval {
 613                 set_fixed(@common_control_options,
 614                           bug          => $ref,
 615                           fixed        => [],
 616                           reopen       => 1,
 617                          );
 618             };
 619             if ($@) {
 620                 $errors++;
 621                 print {$transcript} "Failed to clear fixed versions and reopen on $ref: $@";
 622             }
 623         }
 624     }
 625     elsif (m{^(?:(?i)notfound)\s+\#?(-?\d+)
 626              \s+((?:$config{package_name_re}\/)?
 627                  $config{package_version_re}
 628                 # allow for multiple packages
 629                 (?:\s*,\s*(?:$config{package_name_re}\/)?
 630                     $config{package_version_re})*
 631             )$}x) {
 632         $ok++;
 633         $ref= $1;
 634         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 635         my @versions;
 636         @versions = split /\s*,\s*/,$2;
 637         eval {
 638             set_found(@common_control_options,
 639                       bug          => $ref,
 640                       found        => \@versions,
 641                       remove       => 1,
 642                      );
 643         };
 644         if ($@) {
 645             $errors++;
 646             print {$transcript} "Failed to remove found on $ref: $@";
 647         }
 648     }
 649     elsif (m{^(?:(?i)fixed)\s+\#?(-?\d+)
 650              \s+((?:$config{package_name_re}\/)?
 651                     $config{package_version_re}
 652                 # allow for multiple packages
 653                 (?:\s*,\s*(?:$config{package_name_re}\/)?
 654                     $config{package_version_re})*)
 655             \s*$}x) {
 656         $ok++;
 657         $ref= $1;
 658         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 659         my @versions;
 660         @versions = split /\s*,\s*/,$2;
 661         eval {
 662             set_fixed(@common_control_options,
 663                       bug          => $ref,
 664                       fixed        => \@versions,
 665                       add          => 1,
 666                      );
 667         };
 668         if ($@) {
 669             $errors++;
 670             print {$transcript} "Failed to add fixed on $ref: $@";
 671         }
 672     }
 673     elsif (m{^(?:(?i)notfixed)\s+\#?(-?\d+)
 674              \s+((?:$config{package_name_re}\/)?
 675                     $config{package_version_re}
 676                 # allow for multiple packages
 677                 (?:\s*,\s*(?:$config{package_name_re}\/)?
 678                     $config{package_version_re})*)
 679             \s*$}x) {
 680         $ok++;
 681         $ref= $1;
 682         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 683         my @versions;
 684         @versions = split /\s*,\s*/,$2;
 685         eval {
 686             set_fixed(@common_control_options,
 687                       bug          => $ref,
 688                       fixed        => \@versions,
 689                       remove       => 1,
 690                      );
 691         };
 692         if ($@) {
 693             $errors++;
 694             print {$transcript} "Failed to remove fixed on $ref: $@";
 695         }
 696     }
 697     elsif (m/^submitter\s+\#?(-?\d+)\s+(\!|\S.*\S)$/i) {
 698         $ok++;
 699         $ref= $1;
 700         $bug_affected{$ref}=1;
 701         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 702         my $newsubmitter = $2 eq '!' ? $replyto : $2;
 703         if (not Mail::RFC822::Address::valid($newsubmitter)) {
 704              print {$transcript} "$newsubmitter is not a valid e-mail address; not changing submitter\n";
 705              $errors++;
 706         }
 707         else {
 708             eval {
 709                 set_submitter(@common_control_options,
 710                               bug       => $ref,
 711                               submitter => $newsubmitter,
 712                              );
 713             };
 714             if ($@) {
 715                 $errors++;
 716                 print {$transcript} "Failed to set submitter on $ref: $@";
 717             }
 718         }
 719     } elsif (m/^forwarded\s+\#?(-?\d+)\s+(\S.*\S)$/i) {
 720         $ok++;
 721         $ref= $1;
 722         my $forward_to= $2;
 723         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 724         $bug_affected{$ref} = 1;
 725         eval {
 726             set_forwarded(@common_control_options,
 727                           bug          => $ref,
 728                           forwarded    => $forward_to,
 729                           );
 730         };
 731         if ($@) {
 732             $errors++;
 733             print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
 734         }
 735     } elsif (m/^notforwarded\s+\#?(-?\d+)$/i) {
 736         $ok++;
 737         $ref= $1;
 738         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 739         $bug_affected{$ref} = 1;
 740         eval {
 741             set_forwarded(@common_control_options,
 742                           bug          => $ref,
 743                           forwarded    => undef,
 744                           );
 745         };
 746         if ($@) {
 747             $errors++;
 748             print {$transcript} "Failed to clear the forwarded-to-address of $ref: $@";
 749         }
 750     } elsif (m/^(?:severity|priority)\s+\#?(-?\d+)\s+([-0-9a-z]+)$/i) {
 751         $ok++;
 752         $ref= $1;
 753         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 754         $bug_affected{$ref}=1;
 755         my $newseverity= $2;
 756         if (exists $gObsoleteSeverities{$newseverity}) {
 757             print {$transcript} "Severity level \`$newseverity' is obsolete. " .
 758                  "Use $gObsoleteSeverities{$newseverity} instead.\n\n";
 759                 $errors++;
 760         } elsif (not defined first {$_ eq $newseverity}
 761             (@gSeverityList, "$gDefaultSeverity")) {
 762              print {$transcript} "Severity level \`$newseverity' is not known.\n".
 763                   "Recognized are: $gShowSeverities.\n\n";
 764             $errors++;
 765         } else {
 766             eval {
 767                 set_severity(@common_control_options,
 768                              bug => $ref,
 769                              severity => $newseverity,
 770                             );
 771             };
 772             if ($@) {
 773                 $errors++;
 774                 print {$transcript} "Failed to set severity of $config{bug} $ref to $newseverity: $@";
 775             }
 776         }
 777     } elsif (m/^tags?\s+\#?(-?\d+)\s+(([=+-])\s*)?(\S.*)?$/i) {
 778         ### TODO: [#505189] Consider altering this to accept tag #nnn + foo - bar - baz
 779         $ok++;
 780         $ref = $1;
 781         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 782         $bug_affected{$ref}=1;
 783         my $addsubcode = $3;
 784         my @add_remove_option = ();
 785         if (defined $addsubcode) {
 786             if ($addsubcode eq '-') {
 787                 push @add_remove_option,(remove => 1);
 788             }
 789             elsif ($addsubcode eq '+') {
 790                 push @add_remove_option,(add => 1);
 791             }
 792         }
 793         my $tags = $4;
 794         my @tags = split /[\s,]+/, $tags;
 795         my @badtags = ();
 796         foreach my $tag (@tags) {
 797             if (not defined first {$_ eq $tag} @{$config{tags}}) {
 798                 push @badtags, $tag;
 799             }
 800         }
 801         if (@badtags) {
 802             print {$transcript} "Unknown tag/s: ".join(', ', @badtags).".\n".
 803                  "Recognized are: ".join(' ', @gTags).".\n\n";
 804             $errors++;
 805         }
 806         eval {
 807             set_tags(@common_control_options,
 808                      bug => $ref,
 809                      tags => [@tags],
 810                      warn_on_bad_tags => 0, # don't warn on bad tags,
 811                                             # 'cause we do that above
 812                      @add_remove_option,
 813                     );
 814         };
 815         if ($@) {
 816             # we intentionally have two errors here if there is a bad
 817             # tag and the above fails for some reason
 818             $errors++;
 819             print {$transcript} "Failed to alter tags of $config{bug} $ref: $@";
 820         }
 821     } elsif (m/^(un)?block\s+\#?(-?\d+)\s+(?:by|with)\s+(\S.*)?$/i) {
 822         $ok++;
 823         $ref= $2;
 824         my $add_remove = defined $1 && $1 eq 'un';
 825         my @blockers = split /[\s,]+/, $3;
 826         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 827         $bug_affected{$ref} = 1;
 828         eval {
 829              set_blocks(@common_control_options,
 830                         bug          => $ref,
 831                         block        => \@blockers,
 832                         $add_remove ? (remove => 1):(add => 1),
 833                        );
 834         };
 835         if ($@) {
 836             $errors++;
 837             print {$transcript} "Failed to set blocking bugs of $ref: $@";
 838         }
 839     } elsif (m/^retitle\s+\#?(-?\d+)\s+(\S.*\S)\s*$/i) {
 840         $ok++;
 841         $ref= $1; my $newtitle= $2;
 842         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 843         $bug_affected{$ref} = 1;
 844         eval {
 845              set_title(@common_control_options,
 846                        bug          => $ref,
 847                        title        => $newtitle,
 848                       );
 849         };
 850         if ($@) {
 851             $errors++;
 852             print {$transcript} "Failed to set the title of $ref: $@";
 853         }
 854     } elsif (m/^unmerge\s+\#?(-?\d+)$/i) {
 855         $ok++;
 856         $ref= $1;
 857         $bug_affected{$ref} = 1;
 858         if (&setbug) {
 859             if (!length($data->{mergedwith})) {
 860                 print {$transcript} "$gBug is not marked as being merged with any others.\n\n";
 861                 &nochangebug;
 862             } else {
 863                 $mergelowstate eq 'locked' || die "$mergelowstate ?";
 864                 $action= "Disconnected #$ref from all other report(s).";
 865                 my @newmergelist= split(/ /,$data->{mergedwith});
 866                 my $discref= $ref;
 867                 @bug_affected{@newmergelist} = 1 x @newmergelist;
 868                 do {
 869                     $affected_packages{$data->{package}} = 1;
 870                     add_recipients(data => $data,
 871                                    recipients => \%recipients,
 872                                    transcript   => $transcript,
 873                                    ($dl > 0 ? (debug => $transcript):()),
 874                                   );
 875                     $data->{mergedwith}= ($ref == $discref) ? ''
 876                         : join(' ',grep($_ ne $ref,@newmergelist));
 877                 } while (&getnextbug);
 878             }
 879         }
 880     } elsif (m/^merge\s+#?(-?\d+(\s+#?-?\d+)+)\s*$/i) {
 881         $ok++;
 882         my @tomerge= sort { $a <=> $b } split(/\s+#?/,$1);
 883         my @newmergelist= ();
 884         my %tags = ();
 885         my %found = ();
 886         my %fixed = ();
 887         &getmerge;
 888         while (defined($ref= shift(@tomerge))) {
 889             print {$transcript} "D| checking merge $ref\n" if $dl;
 890             $ref+= 0;
 891             if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
 892                 $ref = $clonebugs{$ref};
 893             }
 894             next if grep($_ == $ref,@newmergelist);
 895             if (!&getbug) { &notfoundbug; @newmergelist=(); last }
 896             if (!&checkpkglimit) { &cancelbug; @newmergelist=(); last; }
 897             &foundbug;
 898             print {$transcript} "D| adding $ref ($data->{mergedwith})\n" if $dl;
 899             $mismatch= '';
 900             &checkmatch('package','m_package',$data->{package},@newmergelist);
 901             &checkmatch('forwarded addr','m_forwarded',$data->{forwarded},@newmergelist);
 902             $data->{severity} = '$gDefaultSeverity' if $data->{severity} eq '';
 903             &checkmatch('severity','m_severity',$data->{severity},@newmergelist);
 904             &checkmatch('blocks','m_blocks',$data->{blocks},@newmergelist);
 905             &checkmatch('blocked-by','m_blockedby',$data->{blockedby},@newmergelist);
 906             &checkmatch('done mark','m_done',length($data->{done}) ? 'done' : 'open',@newmergelist);
 907             &checkmatch('owner','m_owner',$data->{owner},@newmergelist);
 908             &checkmatch('summary','m_summary',$data->{summary},@newmergelist);
 909             &checkmatch('affects','m_affects',$data->{affects},@newmergelist);
 910             foreach my $t (split /\s+/, $data->{keywords}) { $tags{$t} = 1; }
 911             foreach my $f (@{$data->{found_versions}}) { $found{$f} = 1; }
 912             foreach my $f (@{$data->{fixed_versions}}) { $fixed{$f} = 1; }
 913             if (length($mismatch)) {
 914                 print {$transcript} "Mismatch - only $gBugs in same state can be merged:\n".
 915                      $mismatch."\n";
 916                 $errors++;
 917                 &cancelbug; @newmergelist=(); last;
 918             }
 919             push(@newmergelist,$ref);
 920             push(@tomerge,split(/ /,$data->{mergedwith}));
 921             &cancelbug;
 922         }
 923         if (@newmergelist) {
 924             @newmergelist= sort { $a <=> $b } @newmergelist;
 925             $action= "Merged @newmergelist.";
 926             delete @fixed{keys %found};
 927             for $ref (@newmergelist) {
 928                 &getbug || die "huh ?  $gBug $ref disappeared during merge";
 929                 $affected_packages{$data->{package}} = 1;
 930                 add_recipients(data => $data,
 931                                recipients => \%recipients,
 932                                transcript   => $transcript,
 933                                ($dl > 0 ? (debug => $transcript):()),
 934                               );
 935                 @bug_affected{@newmergelist} = 1 x @newmergelist;
 936                 $data->{mergedwith}= join(' ',grep($_ != $ref,@newmergelist));
 937                 $data->{keywords}= join(' ', keys %tags);
 938                 $data->{found_versions}= [sort keys %found];
 939                 $data->{fixed_versions}= [sort keys %fixed];
 940                 &savebug;
 941             }
 942             print {$transcript} "$action\n\n";
 943         }
 944         &endmerge;
 945     } elsif (m/^forcemerge\s+\#?(-?\d+(?:\s+\#?-?\d+)+)\s*$/i) {
 946         $ok++;
 947         my @temp = split /\s+\#?/,$1;
 948         my $master_bug = shift @temp;
 949         my $master_bug_data;
 950         my @tomerge = sort { $a <=> $b } @temp;
 951         unshift @tomerge,$master_bug;
 952         print {$transcript} "D| force merging ".join(',',@tomerge)."\n" if $dl;
 953         my @newmergelist= ();
 954         my %tags = ();
 955         my %found = ();
 956         my %fixed = ();
 957         # Here we try to do the right thing.
 958         # First, if the bugs are in the same package, we merge all of the found, fixed, and tags.
 959         # If not, we discard the found and fixed.
 960         # Everything else we set to the values of the first bug.
 961         &getmerge;
 962         while (defined($ref= shift(@tomerge))) {
 963             print {$transcript} "D| checking merge $ref\n" if $dl;
 964             $ref+= 0;
 965             if ($ref =~ m/^-\d+$/ && defined $clonebugs{$ref}) {
 966                 $ref = $clonebugs{$ref};
 967             }
 968             next if grep($_ == $ref,@newmergelist);
 969             if (!&getbug) { &notfoundbug; @newmergelist=(); last }
 970             if (!&checkpkglimit) { &cancelbug; @newmergelist=(); last; }
 971             &foundbug;
 972             print {$transcript} "D| adding $ref ($data->{mergedwith})\n" if $dl;
 973             $master_bug_data = $data if not defined $master_bug_data;
 974             if ($data->{package} ne $master_bug_data->{package}) {
 975                  print {$transcript} "Mismatch - only $gBugs in the same package can be forcibly merged:\n".
 976                      "$gBug $ref is not in the same package as $master_bug\n";
 977                 $errors++;
 978                 &cancelbug; @newmergelist=(); last;
 979             }
 980             for my $t (split /\s+/,$data->{keywords}) {
 981                  $tags{$t} = 1;
 982             }
 983             @found{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
 984             @fixed{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
 985             push(@newmergelist,$ref);
 986             push(@tomerge,split(/ /,$data->{mergedwith}));
 987             &cancelbug;
 988         }
 989         if (@newmergelist) {
 990             @newmergelist= sort { $a <=> $b } @newmergelist;
 991             $action= "Forcibly Merged @newmergelist.";
 992             delete @fixed{keys %found};
 993             for $ref (@newmergelist) {
 994                 &getbug || die "huh ?  $gBug $ref disappeared during merge";
 995                 $affected_packages{$data->{package}} = 1;
 996                 add_recipients(data => $data,
 997                                recipients => \%recipients,
 998                                transcript   => $transcript,
 999                                ($dl > 0 ? (debug => $transcript):()),
1000                               );
1001                 @bug_affected{@newmergelist} = 1 x @newmergelist;
1002                 $data->{mergedwith}= join(' ',grep($_ != $ref,@newmergelist));
1003                 $data->{keywords}= join(' ', keys %tags);
1004                 $data->{found_versions}= [sort keys %found];
1005                 $data->{fixed_versions}= [sort keys %fixed];
1006                 my @field_list = qw(forwarded package severity blocks blockedby owner done affects summary);
1007                 @{$data}{@field_list} = @{$master_bug_data}{@field_list};
1008                 &savebug;
1009             }
1010             print {$transcript} "$action\n\n";
1011         }
1012         &endmerge;
1013     } elsif (m/^clone\s+#?(\d+)\s+((-\d+\s+)*-\d+)\s*$/i) {
1014         $ok++;
1015
1016         my $origref = $1;
1017         my @newclonedids = split /\s+/, $2;
1018         my $newbugsneeded = scalar(@newclonedids);
1019
1020         $ref = $origref;
1021         $bug_affected{$ref} = 1;
1022         if (&setbug) {
1023             $affected_packages{$data->{package}} = 1;
1024             if (length($data->{mergedwith})) {
1025                 print {$transcript} "$gBug is marked as being merged with others. Use an existing clone.\n\n";
1026                 $errors++;
1027                 &nochangebug;
1028             } else {
1029                 &filelock("nextnumber.lock");
1030                 open(N,"nextnumber") || die "nextnumber: read: $!";
1031                 my $v=<N>; $v =~ s/\n$// || die "nextnumber bad format";
1032                 my $firstref= $v+0;  $v += $newbugsneeded;
1033                 open(NN,">nextnumber"); print NN "$v\n"; close(NN);
1034                 &unfilelock;
1035
1036                 my $lastref = $firstref + $newbugsneeded - 1;
1037
1038                 if ($newbugsneeded == 1) {
1039                     $action= "$gBug $origref cloned as bug $firstref.";
1040                 } else {
1041                     $action= "$gBug $origref cloned as bugs $firstref-$lastref.";
1042                 }
1043
1044                 my $blocks = $data->{blocks};
1045                 my $blockedby = $data->{blockedby};
1046
1047                 &getnextbug;
1048                 my $ohash = get_hashname($origref);
1049                 my $clone = $firstref;
1050                 @bug_affected{@newclonedids} = 1 x @newclonedids;
1051                 for my $newclonedid (@newclonedids) {
1052                     $clonebugs{$newclonedid} = $clone;
1053
1054                     my $hash = get_hashname($clone);
1055                     copy("db-h/$ohash/$origref.log", "db-h/$hash/$clone.log");
1056                     copy("db-h/$ohash/$origref.status", "db-h/$hash/$clone.status");
1057                     copy("db-h/$ohash/$origref.summary", "db-h/$hash/$clone.summary");
1058                     copy("db-h/$ohash/$origref.report", "db-h/$hash/$clone.report");
1059                     &bughook('new', $clone, $data);
1060
1061                     # Update blocking info of bugs blocked by or blocking the
1062                     # cloned bug.
1063                     foreach $ref (split ' ', $blocks) {
1064                         &getbug;
1065                         $data->{blockedby} = manipset($data->{blockedby}, $clone, 1);
1066                         &savebug;
1067                     }
1068                     foreach $ref (split ' ', $blockedby) {
1069                         &getbug;
1070                         $data->{blocks} = manipset($data->{blocks}, $clone, 1);
1071                         &savebug;
1072                     }
1073
1074                     $clone++;
1075                 }
1076             }
1077         }
1078     } elsif (m/^package\:?\s+(\S.*\S)?\s*$/i) {
1079         $ok++;
1080         my @pkgs = split /\s+/, $1;
1081         if (scalar(@pkgs) > 0) {
1082                 %limit_pkgs = map { ($_, 1) } @pkgs;
1083                 print {$transcript} "Ignoring bugs not assigned to: " .
1084                         join(" ", keys(%limit_pkgs)) . "\n\n";
1085         } else {
1086                 %limit_pkgs = ();
1087                 print {$transcript} "Not ignoring any bugs.\n\n";
1088         }
1089     } elsif (m/^affects?\s+\#?(-?\d+)(?:\s+((?:[=+-])?)\s*(\S.*)?)?\s*$/i) {
1090         $ok++;
1091         $ref = $1;
1092         my $add_remove = $2 || '';
1093         my $packages = $3 || '';
1094         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1095         $bug_affected{$ref} = 1;
1096         eval {
1097              affects(@common_control_options,
1098                      bug => $ref,
1099                      packages     => [splitpackages($3)],
1100                      ($add_remove eq '+'?(add => 1):()),
1101                      ($add_remove eq '-'?(remove => 1):()),
1102                     );
1103         };
1104         if ($@) {
1105             $errors++;
1106             print {$transcript} "Failed to mark $ref as affecting package(s): $@";
1107         }
1108
1109     } elsif (m/^summary\s+\#?(-?\d+)\s*(\d+|)\s*$/i) {
1110         $ok++;
1111         $ref = $1;
1112         my $summary_msg = length($2)?$2:undef;
1113         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1114         $bug_affected{$ref} = 1;
1115         eval {
1116             summary(@common_control_options,
1117                     bug          => $ref,
1118                     summary      => $summary_msg,
1119                    );
1120         };
1121         if ($@) {
1122             $errors++;
1123             print {$transcript} "Failed to give $ref a summary: $@";
1124         }
1125
1126     } elsif (m/^owner\s+\#?(-?\d+)\s+((?:\S.*\S)|\!)\s*$/i) {
1127         $ok++;
1128         $ref = $1;
1129         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1130         my $newowner = $2;
1131         if ($newowner eq '!') {
1132             $newowner = $replyto;
1133         }
1134         $bug_affected{$ref} = 1;
1135         eval {
1136             owner(@common_control_options,
1137                   bug          => $ref,
1138                   owner        => $newowner,
1139                  );
1140         };
1141         if ($@) {
1142             $errors++;
1143             print {$transcript} "Failed to mark $ref as having an owner: $@";
1144         }
1145     } elsif (m/^noowner\s+\#?(-?\d+)\s*$/i) {
1146         $ok++;
1147         $ref = $1;
1148         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1149         $bug_affected{$ref} = 1;
1150         eval {
1151             owner(@common_control_options,
1152                   bug          => $ref,
1153                   owner        => undef,
1154                  );
1155         };
1156         if ($@) {
1157             $errors++;
1158             print {$transcript} "Failed to mark $ref as not having an owner: $@";
1159         }
1160     } elsif (m/^unarchive\s+#?(\d+)$/i) {
1161          $ok++;
1162          $ref = $1;
1163          $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1164          $bug_affected{$ref} = 1;
1165          eval {
1166               bug_unarchive(@common_control_options,
1167                             bug        => $ref,
1168                             recipients => \%recipients,
1169                            );
1170          };
1171          if ($@) {
1172               $errors++;
1173          }
1174     } elsif (m/^archive\s+#?(\d+)$/i) {
1175          $ok++;
1176          $ref = $1;
1177          $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1178          $bug_affected{$ref} = 1;
1179          eval {
1180               bug_archive(@common_control_options,
1181                           bug => $ref,
1182                           ignore_time => 1,
1183                           archive_unarchived => 0,
1184                          );
1185          };
1186          if ($@) {
1187               $errors++;
1188          }
1189     } else {
1190         print {$transcript} "Unknown command or malformed arguments to command.\n\n";
1191         $errors++;
1192         if (++$unknowns >= 5) {
1193             print {$transcript} "Too many unknown commands, stopping here.\n\n";
1194             last;
1195         }
1196     }
1197 }
1198 if ($procline>$#bodylines) {
1199     print {$transcript} ">\nEnd of message, stopping processing here.\n\n";
1200 }
1201 if (!$ok && !$quickabort) {
1202     $errors++;
1203     print {$transcript} "No commands successfully parsed; sending the help text(s).\n";
1204     &sendhelp;
1205     print {$transcript} "\n";
1206 }
1207
1208 my @maintccs = determine_recipients(recipients => \%recipients,
1209                                     address_only => 1,
1210                                     cc => 1,
1211                                    );
1212 my $maintccs = 'Cc: '.join(",\n    ",
1213                     determine_recipients(recipients => \%recipients,
1214                                          cc => 1,
1215                                         )
1216                    )."\n";
1217
1218 my $packagepr = '';
1219 $packagepr = "X-${gProject}-PR-Package: " . join(keys %affected_packages) . "\n" if keys %affected_packages;
1220
1221 # Add Bcc's to subscribed bugs
1222 # now handled by Debbugs::Recipients
1223 #push @bcc, map {"bugs=$_\@$gListDomain"} keys %bug_affected;
1224
1225 if (!defined $header{'subject'} || $header{'subject'} eq "") {
1226   $header{'subject'} = "your mail";
1227 }
1228
1229 # Error text here advertises how many errors there were
1230 my $error_text = $errors > 0 ? " (with $errors errors)":'';
1231
1232 my $reply= <<END;
1233 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1234 To: $replyto
1235 ${maintccs}Subject: Processed${error_text}: $header{'subject'}
1236 In-Reply-To: $header{'message-id'}
1237 END
1238 $reply .= <<END;
1239 References: $header{'message-id'}
1240 Message-ID: <handler.s.$nn.transcript\@$gEmailDomain>
1241 Precedence: bulk
1242 ${packagepr}X-$gProject-PR-Message: transcript
1243
1244 ${transcript_scalar}Please contact me if you need assistance.
1245
1246 $gMaintainer
1247 (administrator, $gProject $gBugs database)
1248 END
1249
1250 my $repliedshow= join(', ',$replyto,
1251                       determine_recipients(recipients => \%recipients,
1252                                            cc => 1,
1253                                            address_only => 1,
1254                                           )
1255                      );
1256 # -1 is the service.in log
1257 &filelock("lock/-1");
1258 open(AP,">>db-h/-1.log") || die "open db-h/-1.log: $!";
1259 print(AP
1260       "\2\n$repliedshow\n\5\n$reply\n\3\n".
1261       "\6\n".
1262       "<strong>Request received</strong> from <code>".
1263       html_escape($header{'from'})."</code>\n".
1264       "to <code>".html_escape($controlrequestaddr)."</code>\n".
1265       "\3\n".
1266       "\7\n",escape_log(@log),"\n\3\n") || die "writing db-h/-1.log: $!";
1267 close(AP) || die "open db-h/-1.log: $!";
1268 &unfilelock;
1269 utime(time,time,"db-h");
1270
1271 &sendmailmessage($reply,
1272                  exists $header{'x-debbugs-no-ack'}?():$replyto,
1273                  make_list(values %{{determine_recipients(recipients => \%recipients,
1274                                                           address_only => 1,
1275                                                          )}}
1276                           ),
1277                 );
1278
1279 unlink("incoming/P$nn") || die "unlinking incoming/P$nn: $!";
1280
1281 sub sendmailmessage {
1282     my ($message,@recips) = @_;
1283     $message = "X-Loop: $gMaintainerEmail\n" . $message;
1284     send_mail_message(message    => $message,
1285                       recipients => \@recips,
1286                      );
1287     $midix++;
1288 }
1289
1290 sub fill_template{
1291      my ($template,$extra_var) = @_;
1292      $extra_var ||={};
1293      my $variables = {config => \%config,
1294                       defined($ref)?(ref    => $ref):(),
1295                       defined($data)?(data  => $data):(),
1296                       %{$extra_var},
1297                      };
1298      my $hole_var = {'&bugurl' =>
1299                      sub{"$_[0]: ".
1300                               'http://'.$config{cgi_domain}.'/'.
1301                                    Debbugs::CGI::bug_url($_[0]);
1302                     }
1303                     };
1304      return fill_in_template(template => $template,
1305                              variables => $variables,
1306                              hole_var  => $hole_var,
1307                             );
1308 }
1309
1310 =head2 message_body_template
1311
1312      message_body_template('mail/ack',{ref=>'foo'});
1313
1314 Creates a message body using a template
1315
1316 =cut
1317
1318 sub message_body_template{
1319      my ($template,$extra_var) = @_;
1320      $extra_var ||={};
1321      my $body = fill_template($template,$extra_var);
1322      return fill_template('mail/message_body',
1323                           {%{$extra_var},
1324                            body => $body,
1325                           },
1326                          );
1327 }
1328
1329 sub sendhelp {
1330      if ($control) {
1331           &sendtxthelpraw("bug-maint-mailcontrol.txt","instructions for control\@$gEmailDomain")
1332      }
1333      else {
1334           &sendtxthelpraw("bug-log-mailserver.txt","instructions for request\@$gEmailDomain");
1335      }
1336 }
1337
1338 #sub unimplemented {
1339 #    print {$transcript} "Sorry, command $_[0] not yet implemented.\n\n";
1340 #}
1341 our %checkmatch_values;
1342 sub checkmatch {
1343     my ($string,$mvarname,$svarvalue,@newmergelist) = @_;
1344     my ($mvarvalue);
1345     if (@newmergelist) {
1346         $mvarvalue = $checkmatch_values{$mvarname};
1347         print {$transcript} "D| checkmatch \`$string' /$mvarname/$mvarvalue/$svarvalue/\n"
1348             if $dl;
1349         $mismatch .=
1350             "Values for \`$string' don't match:\n".
1351             " #$newmergelist[0] has \`$mvarvalue';\n".
1352             " #$ref has \`$svarvalue'\n"
1353             if $mvarvalue ne $svarvalue;
1354     } else {
1355          print {$transcript} "D| setupmatch \`$string' /$mvarname/$svarvalue/\n"
1356               if $dl;
1357          $checkmatch_values{$mvarname} = $svarvalue;
1358     }
1359 }
1360
1361 sub checkpkglimit {
1362     if (keys %limit_pkgs and not defined $limit_pkgs{$data->{package}}) {
1363         print {$transcript} "$gBug number $ref belongs to package $data->{package}, skipping.\n\n";
1364         $errors++;
1365         return 0;
1366     }
1367     return 1;
1368 }
1369
1370 sub manipset {
1371     my $list = shift;
1372     my $elt = shift;
1373     my $add = shift;
1374
1375     my %h = map { $_ => 1 } split ' ', $list;
1376     if ($add) {
1377         $h{$elt}=1;
1378     }
1379     else {
1380         delete $h{$elt};
1381     }
1382     return join ' ', sort keys %h;
1383 }
1384
1385 # High-level bug manipulation calls
1386 # Do announcements themselves
1387 #
1388 # Possible calling sequences:
1389 #    setbug (returns 0)
1390 #
1391 #    setbug (returns 1)
1392 #    &transcript(something)
1393 #    nochangebug
1394 #
1395 #    setbug (returns 1)
1396 #    $action= (something)
1397 #    do {
1398 #      (modify s_* variables)
1399 #    } while (getnextbug);
1400
1401 our $manybugs;
1402
1403 sub nochangebug {
1404     &dlen("nochangebug");
1405     $state eq 'single' || $state eq 'multiple' || die "$state ?";
1406     &cancelbug;
1407     &endmerge if $manybugs;
1408     $state= 'idle';
1409     &dlex("nochangebug");
1410 }
1411
1412 our $sref;
1413 our @thisbugmergelist;
1414
1415 sub setbug {
1416     &dlen("setbug $ref");
1417     if ($ref =~ m/^-\d+/) {
1418         if (!defined $clonebugs{$ref}) {
1419             &notfoundbug;
1420             &dlex("setbug => noclone");
1421             return 0;
1422         }
1423         $ref = $clonebugs{$ref};
1424     }
1425     $state eq 'idle' || die "$state ?";
1426     if (!&getbug) {
1427         &notfoundbug;
1428         &dlex("setbug => 0s");
1429         return 0;
1430     }
1431
1432     if (!&checkpkglimit) {
1433         &cancelbug;
1434         return 0;
1435     }
1436
1437     @thisbugmergelist= split(/ /,$data->{mergedwith});
1438     if (!@thisbugmergelist) {
1439         &foundbug;
1440         $manybugs= 0;
1441         $state= 'single';
1442         $sref=$ref;
1443         &dlex("setbug => 1s");
1444         return 1;
1445     }
1446     &cancelbug;
1447     &getmerge;
1448     $manybugs= 1;
1449     if (!&getbug) {
1450         &notfoundbug;
1451         &endmerge;
1452         &dlex("setbug => 0mc");
1453         return 0;
1454     }
1455     &foundbug;
1456     $state= 'multiple'; $sref=$ref;
1457     &dlex("setbug => 1m");
1458     return 1;
1459 }
1460
1461 sub getnextbug {
1462     &dlen("getnextbug");
1463     $state eq 'single' || $state eq 'multiple' || die "$state ?";
1464     &savebug;
1465     if (!$manybugs || !@thisbugmergelist) {
1466         length($action) || die;
1467         print {$transcript} "$action\n$extramessage\n";
1468         &endmerge if $manybugs;
1469         $state= 'idle';
1470         &dlex("getnextbug => 0");
1471         return 0;
1472     }
1473     $ref= shift(@thisbugmergelist);
1474     &getbug || die "bug $ref disappeared";
1475     &foundbug;
1476     &dlex("getnextbug => 1");
1477     return 1;
1478 }
1479
1480 # Low-level bug-manipulation calls
1481 # Do no announcements
1482 #
1483 #    getbug (returns 0)
1484 #
1485 #    getbug (returns 1)
1486 #    cancelbug
1487 #
1488 #    getmerge
1489 #    $action= (something)
1490 #    getbug (returns 1)
1491 #    savebug/cancelbug
1492 #    getbug (returns 1)
1493 #    savebug/cancelbug
1494 #    [getbug (returns 0)]
1495 #    &transcript("$action\n\n")
1496 #    endmerge
1497
1498 sub notfoundbug { print {$transcript} "$gBug number $ref not found. (Is it archived?)\n\n"; }
1499 sub foundbug { print {$transcript} "$gBug#$ref: $data->{subject}\n"; }
1500
1501 sub getmerge {
1502     &dlen("getmerge");
1503     $mergelowstate eq 'idle' || die "$mergelowstate ?";
1504     &filelock('lock/merge');
1505     $mergelowstate='locked';
1506     &dlex("getmerge");
1507 }
1508
1509 sub endmerge {
1510     &dlen("endmerge");
1511     $mergelowstate eq 'locked' || die "$mergelowstate ?";
1512     &unfilelock;
1513     $mergelowstate='idle';
1514     &dlex("endmerge");
1515 }
1516
1517 sub getbug {
1518     &dlen("getbug $ref");
1519     $lowstate eq 'idle' || die "$state ?";
1520     # Only use unmerged bugs here
1521     if (($data = &lockreadbug($ref,'db-h'))) {
1522         $sref= $ref;
1523         $lowstate= "open";
1524         &dlex("getbug => 1");
1525         $extramessage='';
1526         return 1;
1527     }
1528     $lowstate= 'idle';
1529     &dlex("getbug => 0");
1530     return 0;
1531 }
1532
1533 sub cancelbug {
1534     &dlen("cancelbug");
1535     $lowstate eq 'open' || die "$state ?";
1536     &unfilelock;
1537     $lowstate= 'idle';
1538     &dlex("cancelbug");
1539 }
1540
1541 sub savebug {
1542     &dlen("savebug $ref");
1543     $lowstate eq 'open' || die "$lowstate ?";
1544     length($action) || die;
1545     $ref == $sref || die "read $sref but saving $ref ?";
1546     append_action_to_log(bug => $ref,
1547                          action => $action,
1548                          requester => $header{from},
1549                          request_addr => $controlrequestaddr,
1550                          message => \@log,
1551                          get_lock => 0,
1552                         );
1553     unlockwritebug($ref, $data);
1554     $lowstate= "idle";
1555     &dlex("savebug");
1556 }
1557
1558 sub dlen {
1559     return if !$dl;
1560     print {$transcript} "C> @_ ($state $lowstate $mergelowstate)\n";
1561 }
1562
1563 sub dlex {
1564     return if !$dl;
1565     print {$transcript} "R> @_ ($state $lowstate $mergelowstate)\n";
1566 }
1567
1568 sub urlsanit {
1569     my $url = shift;
1570     $url =~ s/%/%25/g;
1571     $url =~ s/\+/%2b/g;
1572     my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
1573     $url =~ s/([<>&"])/\&$saniarray{$1};/g;
1574     return $url;
1575 }
1576
1577 sub sendlynxdoc {
1578     &sendlynxdocraw;
1579     print {$transcript} "\n";
1580     $ok++;
1581 }
1582
1583 sub sendtxthelp {
1584     &sendtxthelpraw;
1585     print {$transcript} "\n";
1586     $ok++;
1587 }
1588
1589
1590 our $doc;
1591 sub sendtxthelpraw {
1592     my ($relpath,$description) = @_;
1593     $doc='';
1594     if (not -e "$gDocDir/$relpath") {
1595         print {$transcript} "Unfortunatly, the help text doesn't exist, so it wasn't sent.\n";
1596         warn "Help text $gDocDir/$relpath not found";
1597         return;
1598     }
1599     open(D,"$gDocDir/$relpath") || die "open doc file $relpath: $!";
1600     while(<D>) { $doc.=$_; }
1601     close(D);
1602     print {$transcript} "Sending $description in separate message.\n";
1603     &sendmailmessage(<<END.$doc,$replyto);
1604 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1605 To: $replyto
1606 Subject: $gProject $gBug help: $description
1607 References: $header{'message-id'}
1608 In-Reply-To: $header{'message-id'}
1609 Message-ID: <handler.s.$nn.help.$midix\@$gEmailDomain>
1610 Precedence: bulk
1611 X-$gProject-PR-Message: doc-text $relpath
1612
1613 END
1614     $ok++;
1615 }
1616
1617 sub sendlynxdocraw {
1618     my ($relpath,$description) = @_;
1619     $doc='';
1620     open(L,"lynx -nolist -dump http://$gCGIDomain/\Q$relpath\E 2>&1 |") || die "fork for lynx: $!";
1621     while(<L>) { $doc.=$_; }
1622     $!=0; close(L);
1623     if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
1624         print {$transcript} "Information ($description) is not available -\n".
1625              "perhaps the $gBug does not exist or is not on the WWW yet.\n";
1626          $ok++;
1627     } elsif ($?) {
1628         print {$transcript} "Error getting $description (code $? $!):\n$doc\n";
1629     } else {
1630         print {$transcript} "Sending $description.\n";
1631         &sendmailmessage(<<END.$doc,$replyto);
1632 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1633 To: $replyto
1634 Subject: $gProject $gBugs information: $description
1635 References: $header{'message-id'}
1636 In-Reply-To: $header{'message-id'}
1637 Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
1638 Precedence: bulk
1639 X-$gProject-PR-Message: doc-html $relpath
1640
1641 END
1642          $ok++;
1643     }
1644 }
1645
1646
1647 sub sendinfo {
1648     my ($wherefrom,$path,$description) = @_;
1649     if ($wherefrom eq "ftp.d.o") {
1650       $doc = `lynx -nolist -dump http://ftp.debian.org/debian/indices/$path.gz 2>&1 | gunzip -cf` or die "fork for lynx/gunzip: $!";
1651       $! = 0;
1652       if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
1653           print {$transcript} "$description is not available.\n";
1654           $ok++; return;
1655       } elsif ($?) {
1656           print {$transcript} "Error getting $description (code $? $!):\n$doc\n";
1657           return;
1658       }
1659     } elsif ($wherefrom eq "local") {
1660       open P, "$path";
1661       $doc = do { local $/; <P> };
1662       close P;
1663     } else {
1664       print {$transcript} "internal errror: info files location unknown.\n";
1665       $ok++; return;
1666     }
1667     print {$transcript} "Sending $description.\n";
1668     &sendmailmessage(<<END.$doc,$replyto);
1669 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1670 To: $replyto
1671 Subject: $gProject $gBugs information: $description
1672 References: $header{'message-id'}
1673 In-Reply-To: $header{'message-id'}
1674 Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
1675 Precedence: bulk
1676 X-$gProject-PR-Message: getinfo
1677
1678 $description follows:
1679
1680 END
1681     $ok++;
1682     print {$transcript} "\n";
1683 }