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