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         # if there isn't a package given, assume that we should unset
 968         # affects; otherwise default to adding
 969         if (not defined $packages or
 970             not length $packages) {
 971             $packages = '';
 972             $add_remove ||= '=';
 973         }
 974         elsif (not defined $add_remove or
 975                not length $add_remove) {
 976             $add_remove = '+';
 977         }
 978         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 979         eval {
 980              affects(@common_control_options,
 981                      bug => $ref,
 982                      package     => [splitpackages($3)],
 983                      ($add_remove eq '+'?(add => 1):()),
 984                      ($add_remove eq '-'?(remove => 1):()),
 985                     );
 986         };
 987         if ($@) {
 988             $errors++;
 989             print {$transcript} "Failed to mark $ref as affecting package(s): ".cleanup_eval_fail($@,$debug)."\n";
 990         }
 991
 992     } elsif (m/^summary\s+\#?(-?\d+)\s*(\d+|)\s*$/i) {
 993         $ok++;
 994         $ref = $1;
 995         my $summary_msg = length($2)?$2:undef;
 996         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
 997         eval {
 998             summary(@common_control_options,
 999                     bug          => $ref,
1000                     summary      => $summary_msg,
1001                    );
1002         };
1003         if ($@) {
1004             $errors++;
1005             print {$transcript} "Failed to give $ref a summary: ".cleanup_eval_fail($@,$debug)."\n";
1006         }
1007
1008     } elsif (m/^owner\s+\#?(-?\d+)\s+((?:\S.*\S)|\!)\s*$/i) {
1009         $ok++;
1010         $ref = $1;
1011         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1012         my $newowner = $2;
1013         if ($newowner eq '!') {
1014             $newowner = $replyto;
1015         }
1016         eval {
1017             owner(@common_control_options,
1018                   bug          => $ref,
1019                   owner        => $newowner,
1020                  );
1021         };
1022         if ($@) {
1023             $errors++;
1024             print {$transcript} "Failed to mark $ref as having an owner: ".cleanup_eval_fail($@,$debug)."\n";
1025         }
1026     } elsif (m/^noowner\s+\#?(-?\d+)\s*$/i) {
1027         $ok++;
1028         $ref = $1;
1029         $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1030         eval {
1031             owner(@common_control_options,
1032                   bug          => $ref,
1033                   owner        => undef,
1034                  );
1035         };
1036         if ($@) {
1037             $errors++;
1038             print {$transcript} "Failed to mark $ref as not having an owner: ".cleanup_eval_fail($@,$debug)."\n";
1039         }
1040     } elsif (m/^unarchive\s+#?(\d+)$/i) {
1041          $ok++;
1042          $ref = $1;
1043          $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1044          eval {
1045               bug_unarchive(@common_control_options,
1046                             bug        => $ref,
1047                             recipients => \%recipients,
1048                            );
1049          };
1050          if ($@) {
1051               $errors++;
1052          }
1053     } elsif (m/^archive\s+#?(\d+)$/i) {
1054          $ok++;
1055          $ref = $1;
1056          $ref = $clonebugs{$ref} if exists $clonebugs{$ref};
1057          eval {
1058               bug_archive(@common_control_options,
1059                           bug => $ref,
1060                           ignore_time => 1,
1061                           archive_unarchived => 0,
1062                          );
1063          };
1064          if ($@) {
1065               $errors++;
1066          }
1067     } else {
1068         print {$transcript} "Unknown command or malformed arguments to command.\n\n";
1069         $errors++;
1070         if (++$unknowns >= 5) {
1071             print {$transcript} "Too many unknown commands, stopping here.\n\n";
1072             last;
1073         }
1074     }
1075 }
1076 if ($procline>$#bodylines) {
1077     print {$transcript} ">\nEnd of message, stopping processing here.\n\n";
1078 }
1079 if (!$ok && !$quickabort) {
1080     $errors++;
1081     print {$transcript} "No commands successfully parsed; sending the help text(s).\n";
1082     &sendhelp;
1083     print {$transcript} "\n";
1084 }
1085
1086 my @maintccs = determine_recipients(recipients => \%recipients,
1087                                     address_only => 1,
1088                                     cc => 1,
1089                                    );
1090 my $maintccs = 'Cc: '.join(",\n    ",
1091                     determine_recipients(recipients => \%recipients,
1092                                          cc => 1,
1093                                         )
1094                    )."\n";
1095
1096 my $packagepr = '';
1097 $packagepr = "X-${gProject}-PR-Package: " . join(keys %affected_packages) . "\n" if keys %affected_packages;
1098
1099 # Add Bcc's to subscribed bugs
1100 # now handled by Debbugs::Recipients
1101 #push @bcc, map {"bugs=$_\@$gListDomain"} keys %bug_affected;
1102
1103 if (!defined $header{'subject'} || $header{'subject'} eq "") {
1104   $header{'subject'} = "your mail";
1105 }
1106
1107 # Error text here advertises how many errors there were
1108 my $error_text = $errors > 0 ? " (with $errors errors)":'';
1109
1110 my @common_headers;
1111 push @common_headers, 'X-Loop',$gMaintainerEmail;
1112
1113 my $temp_transcript = ${transcript_scalar};
1114 eval{
1115     $temp_transcript = decode("utf8",$temp_transcript,Encode::FB_CROAK);
1116 };
1117 my $reply =
1118     create_mime_message([From          => "$gMaintainerEmail ($gProject $gBug Tracking System)",
1119                          To            => $replyto,
1120                          @maintccs ? (Cc => join(', ',@maintccs)):(),
1121                          Subject       => "Processed${error_text}: $header{subject}",
1122                          'Message-ID'  => "<handler.s.$nn.transcript\@$gEmailDomain>",
1123                          'In-Reply-To' => $header{'message-id'},
1124                          References    => join(' ',grep {defined $_} $header{'message-id'},$data->{msgid}),
1125                          Precedence    => 'bulk',
1126                          keys %affected_packages ?("X-${gProject}-PR-Package" => join(' ',keys %affected_packages)):(),
1127                          keys %affected_packages ?("X-${gProject}-PR-Source" =>
1128                                                    join(' ',
1129                                                         map {defined $_ ?(ref($_)?@{$_}:$_):()}
1130                                                         binary_to_source(binary => [keys %affected_packages],
1131                                                                          source_only => 1))):(),
1132                          "X-$gProject-PR-Message" => 'transcript',
1133                          @common_headers,
1134                         ],
1135                         fill_template('mail/message_body',
1136                                       {body => "${temp_transcript}Please contact me if you need assistance."},
1137                                      ));
1138
1139 my $repliedshow= join(', ',$replyto,
1140                       determine_recipients(recipients => \%recipients,
1141                                            cc => 1,
1142                                            address_only => 1,
1143                                           )
1144                      );
1145
1146 # -1 is the service.in log
1147 &filelock("lock/-1");
1148 open(AP,">>db-h/-1.log") || die "open db-h/-1.log: $!";
1149 print(AP
1150       "\2\n$repliedshow\n\5\n$reply\n\3\n".
1151       "\6\n".
1152       "<strong>Request received</strong> from <code>".
1153       html_escape($header{'from'})."</code>\n".
1154       "to <code>".html_escape($controlrequestaddr)."</code>\n".
1155       "\3\n".
1156       "\7\n",escape_log(@log),"\n\3\n") || die "writing db-h/-1.log: $!";
1157 close(AP) || die "open db-h/-1.log: $!";
1158 &unfilelock;
1159 utime(time,time,"db-h");
1160
1161 &sendmailmessage($reply,
1162                  exists $header{'x-debbugs-no-ack'}?():$replyto,
1163                  make_list(values %{{determine_recipients(recipients => \%recipients,
1164                                                           address_only => 1,
1165                                                          )}}
1166                           ),
1167                 );
1168
1169 unlink("incoming/P$nn") || die "unlinking incoming/P$nn: $!";
1170
1171 sub sendmailmessage {
1172     my ($message,@recips) = @_;
1173     $message = "X-Loop: $gMaintainerEmail\n" . $message;
1174     send_mail_message(message    => $message,
1175                       recipients => \@recips,
1176                      );
1177     $midix++;
1178 }
1179
1180 sub fill_template{
1181      my ($template,$extra_var) = @_;
1182      $extra_var ||={};
1183      my $variables = {config => \%config,
1184                       defined($ref)?(ref    => $ref):(),
1185                       defined($data)?(data  => $data):(),
1186                       refs => [map {exists $clonebugs{$_}?$clonebugs{$_}:$_} keys %bug_affected],
1187                       %{$extra_var},
1188                      };
1189      my $hole_var = {'&bugurl' =>
1190                      sub{"$_[0]: ".
1191                               'http://'.$config{cgi_domain}.'/'.
1192                                    Debbugs::CGI::bug_links(bug=>$_[0],
1193                                                            links_only => 1,
1194                                                           );
1195                     }
1196                     };
1197      return fill_in_template(template => $template,
1198                              variables => $variables,
1199                              hole_var  => $hole_var,
1200                             );
1201 }
1202
1203 =head2 message_body_template
1204
1205      message_body_template('mail/ack',{ref=>'foo'});
1206
1207 Creates a message body using a template
1208
1209 =cut
1210
1211 sub message_body_template{
1212      my ($template,$extra_var) = @_;
1213      $extra_var ||={};
1214      my $body = fill_template($template,$extra_var);
1215      return fill_template('mail/message_body',
1216                           {%{$extra_var},
1217                            body => $body,
1218                           },
1219                          );
1220 }
1221
1222 sub sendhelp {
1223      if ($control) {
1224           &sendtxthelpraw("bug-maint-mailcontrol.txt","instructions for control\@$gEmailDomain")
1225      }
1226      else {
1227           &sendtxthelpraw("bug-log-mailserver.txt","instructions for request\@$gEmailDomain");
1228      }
1229 }
1230
1231 #sub unimplemented {
1232 #    print {$transcript} "Sorry, command $_[0] not yet implemented.\n\n";
1233 #}
1234 our %checkmatch_values;
1235 sub checkmatch {
1236     my ($string,$mvarname,$svarvalue,@newmergelist) = @_;
1237     my ($mvarvalue);
1238     if (@newmergelist) {
1239         $mvarvalue = $checkmatch_values{$mvarname};
1240         print {$transcript} "D| checkmatch \`$string' /$mvarname/$mvarvalue/$svarvalue/\n"
1241             if $dl;
1242         $mismatch .=
1243             "Values for \`$string' don't match:\n".
1244             " #$newmergelist[0] has \`$mvarvalue';\n".
1245             " #$ref has \`$svarvalue'\n"
1246             if $mvarvalue ne $svarvalue;
1247     } else {
1248          print {$transcript} "D| setupmatch \`$string' /$mvarname/$svarvalue/\n"
1249               if $dl;
1250          $checkmatch_values{$mvarname} = $svarvalue;
1251     }
1252 }
1253
1254 sub checkpkglimit {
1255     if (keys %limit_pkgs and not defined $limit_pkgs{$data->{package}}) {
1256         print {$transcript} "$gBug number $ref belongs to package $data->{package}, skipping.\n\n";
1257         $errors++;
1258         return 0;
1259     }
1260     return 1;
1261 }
1262
1263 sub manipset {
1264     my $list = shift;
1265     my $elt = shift;
1266     my $add = shift;
1267
1268     my %h = map { $_ => 1 } split ' ', $list;
1269     if ($add) {
1270         $h{$elt}=1;
1271     }
1272     else {
1273         delete $h{$elt};
1274     }
1275     return join ' ', sort keys %h;
1276 }
1277
1278 # High-level bug manipulation calls
1279 # Do announcements themselves
1280 #
1281 # Possible calling sequences:
1282 #    setbug (returns 0)
1283 #
1284 #    setbug (returns 1)
1285 #    &transcript(something)
1286 #    nochangebug
1287 #
1288 #    setbug (returns 1)
1289 #    $action= (something)
1290 #    do {
1291 #      (modify s_* variables)
1292 #    } while (getnextbug);
1293
1294 our $manybugs;
1295
1296 sub nochangebug {
1297     &dlen("nochangebug");
1298     $state eq 'single' || $state eq 'multiple' || die "$state ?";
1299     &cancelbug;
1300     &endmerge if $manybugs;
1301     $state= 'idle';
1302     &dlex("nochangebug");
1303 }
1304
1305 our $sref;
1306 our @thisbugmergelist;
1307
1308 sub setbug {
1309     &dlen("setbug $ref");
1310     if ($ref =~ m/^-\d+/) {
1311         if (!defined $clonebugs{$ref}) {
1312             &notfoundbug;
1313             &dlex("setbug => noclone");
1314             return 0;
1315         }
1316         $ref = $clonebugs{$ref};
1317     }
1318     $state eq 'idle' || die "$state ?";
1319     if (!&getbug) {
1320         &notfoundbug;
1321         &dlex("setbug => 0s");
1322         return 0;
1323     }
1324
1325     if (!&checkpkglimit) {
1326         &cancelbug;
1327         return 0;
1328     }
1329
1330     @thisbugmergelist= split(/ /,$data->{mergedwith});
1331     if (!@thisbugmergelist) {
1332         &foundbug;
1333         $manybugs= 0;
1334         $state= 'single';
1335         $sref=$ref;
1336         &dlex("setbug => 1s");
1337         return 1;
1338     }
1339     &cancelbug;
1340     &getmerge;
1341     $manybugs= 1;
1342     if (!&getbug) {
1343         &notfoundbug;
1344         &endmerge;
1345         &dlex("setbug => 0mc");
1346         return 0;
1347     }
1348     &foundbug;
1349     $state= 'multiple'; $sref=$ref;
1350     &dlex("setbug => 1m");
1351     return 1;
1352 }
1353
1354 sub getnextbug {
1355     &dlen("getnextbug");
1356     $state eq 'single' || $state eq 'multiple' || die "$state ?";
1357     &savebug;
1358     if (!$manybugs || !@thisbugmergelist) {
1359         length($action) || die;
1360         print {$transcript} "$action\n$extramessage\n";
1361         &endmerge if $manybugs;
1362         $state= 'idle';
1363         &dlex("getnextbug => 0");
1364         return 0;
1365     }
1366     $ref= shift(@thisbugmergelist);
1367     &getbug || die "bug $ref disappeared";
1368     &foundbug;
1369     &dlex("getnextbug => 1");
1370     return 1;
1371 }
1372
1373 # Low-level bug-manipulation calls
1374 # Do no announcements
1375 #
1376 #    getbug (returns 0)
1377 #
1378 #    getbug (returns 1)
1379 #    cancelbug
1380 #
1381 #    getmerge
1382 #    $action= (something)
1383 #    getbug (returns 1)
1384 #    savebug/cancelbug
1385 #    getbug (returns 1)
1386 #    savebug/cancelbug
1387 #    [getbug (returns 0)]
1388 #    &transcript("$action\n\n")
1389 #    endmerge
1390
1391 sub notfoundbug { print {$transcript} "$gBug number $ref not found. (Is it archived?)\n\n"; }
1392 sub foundbug { print {$transcript} "$gBug#$ref: $data->{subject}\n"; }
1393
1394 sub getmerge {
1395     &dlen("getmerge");
1396     $mergelowstate eq 'idle' || die "$mergelowstate ?";
1397     &filelock('lock/merge');
1398     $mergelowstate='locked';
1399     &dlex("getmerge");
1400 }
1401
1402 sub endmerge {
1403     &dlen("endmerge");
1404     $mergelowstate eq 'locked' || die "$mergelowstate ?";
1405     &unfilelock;
1406     $mergelowstate='idle';
1407     &dlex("endmerge");
1408 }
1409
1410 sub getbug {
1411     &dlen("getbug $ref");
1412     $lowstate eq 'idle' || die "$state ?";
1413     # Only use unmerged bugs here
1414     if (($data = &lockreadbug($ref,'db-h'))) {
1415         $sref= $ref;
1416         $lowstate= "open";
1417         &dlex("getbug => 1");
1418         $extramessage='';
1419         return 1;
1420     }
1421     $lowstate= 'idle';
1422     &dlex("getbug => 0");
1423     return 0;
1424 }
1425
1426 sub cancelbug {
1427     &dlen("cancelbug");
1428     $lowstate eq 'open' || die "$state ?";
1429     &unfilelock;
1430     $lowstate= 'idle';
1431     &dlex("cancelbug");
1432 }
1433
1434 sub savebug {
1435     &dlen("savebug $ref");
1436     $lowstate eq 'open' || die "$lowstate ?";
1437     length($action) || die;
1438     $ref == $sref || die "read $sref but saving $ref ?";
1439     append_action_to_log(bug => $ref,
1440                          action => $action,
1441                          requester => $header{from},
1442                          request_addr => $controlrequestaddr,
1443                          message => \@log,
1444                          get_lock => 0,
1445                         );
1446     unlockwritebug($ref, $data);
1447     $lowstate= "idle";
1448     &dlex("savebug");
1449 }
1450
1451 sub dlen {
1452     return if !$dl;
1453     print {$transcript} "C> @_ ($state $lowstate $mergelowstate)\n";
1454 }
1455
1456 sub dlex {
1457     return if !$dl;
1458     print {$transcript} "R> @_ ($state $lowstate $mergelowstate)\n";
1459 }
1460
1461 sub urlsanit {
1462     my $url = shift;
1463     $url =~ s/%/%25/g;
1464     $url =~ s/\+/%2b/g;
1465     my %saniarray = ('<','lt', '>','gt', '&','amp', '"','quot');
1466     $url =~ s/([<>&"])/\&$saniarray{$1};/g;
1467     return $url;
1468 }
1469
1470 sub sendlynxdoc {
1471     &sendlynxdocraw;
1472     print {$transcript} "\n";
1473     $ok++;
1474 }
1475
1476 sub sendtxthelp {
1477     &sendtxthelpraw;
1478     print {$transcript} "\n";
1479     $ok++;
1480 }
1481
1482
1483 our $doc;
1484 sub sendtxthelpraw {
1485     my ($relpath,$description) = @_;
1486     $doc='';
1487     if (not -e "$gDocDir/$relpath") {
1488         print {$transcript} "Unfortunatly, the help text doesn't exist, so it wasn't sent.\n";
1489         warn "Help text $gDocDir/$relpath not found";
1490         return;
1491     }
1492     open(D,"$gDocDir/$relpath") || die "open doc file $relpath: $!";
1493     while(<D>) { $doc.=$_; }
1494     close(D);
1495     print {$transcript} "Sending $description in separate message.\n";
1496     &sendmailmessage(<<END.$doc,$replyto);
1497 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1498 To: $replyto
1499 Subject: $gProject $gBug help: $description
1500 References: $header{'message-id'}
1501 In-Reply-To: $header{'message-id'}
1502 Message-ID: <handler.s.$nn.help.$midix\@$gEmailDomain>
1503 Precedence: bulk
1504 X-$gProject-PR-Message: doc-text $relpath
1505
1506 END
1507     $ok++;
1508 }
1509
1510 sub sendlynxdocraw {
1511     my ($relpath,$description) = @_;
1512     $doc='';
1513     open(L,"lynx -nolist -dump http://$gCGIDomain/\Q$relpath\E 2>&1 |") || die "fork for lynx: $!";
1514     while(<L>) { $doc.=$_; }
1515     $!=0; close(L);
1516     if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
1517         print {$transcript} "Information ($description) is not available -\n".
1518              "perhaps the $gBug does not exist or is not on the WWW yet.\n";
1519          $ok++;
1520     } elsif ($?) {
1521         print {$transcript} "Error getting $description (code $? $!):\n$doc\n";
1522     } else {
1523         print {$transcript} "Sending $description.\n";
1524         &sendmailmessage(<<END.$doc,$replyto);
1525 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1526 To: $replyto
1527 Subject: $gProject $gBugs information: $description
1528 References: $header{'message-id'}
1529 In-Reply-To: $header{'message-id'}
1530 Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
1531 Precedence: bulk
1532 X-$gProject-PR-Message: doc-html $relpath
1533
1534 END
1535          $ok++;
1536     }
1537 }
1538
1539
1540 sub sendinfo {
1541     my ($wherefrom,$path,$description) = @_;
1542     if ($wherefrom eq "ftp.d.o") {
1543       $doc = `lynx -nolist -dump http://ftp.debian.org/debian/indices/$path.gz 2>&1 | gunzip -cf` or die "fork for lynx/gunzip: $!";
1544       $! = 0;
1545       if ($? == 255 && $doc =~ m/^\n*lynx: Can\'t access start file/) {
1546           print {$transcript} "$description is not available.\n";
1547           $ok++; return;
1548       } elsif ($?) {
1549           print {$transcript} "Error getting $description (code $? $!):\n$doc\n";
1550           return;
1551       }
1552     } elsif ($wherefrom eq "local") {
1553       open P, "$path";
1554       $doc = do { local $/; <P> };
1555       close P;
1556     } else {
1557       print {$transcript} "internal errror: info files location unknown.\n";
1558       $ok++; return;
1559     }
1560     print {$transcript} "Sending $description.\n";
1561     &sendmailmessage(<<END.$doc,$replyto);
1562 From: $gMaintainerEmail ($gProject $gBug Tracking System)
1563 To: $replyto
1564 Subject: $gProject $gBugs information: $description
1565 References: $header{'message-id'}
1566 In-Reply-To: $header{'message-id'}
1567 Message-ID: <handler.s.$nn.info.$midix\@$gEmailDomain>
1568 Precedence: bulk
1569 X-$gProject-PR-Message: getinfo
1570
1571 $description follows:
1572
1573 END
1574     $ok++;
1575     print {$transcript} "\n";
1576 }