Debbugs/Control.pm

   1 # This module is part of debbugs, and is released
   2 # under the terms of the GPL version 2, or any later
   3 # version at your option.
   4 # See the file README and COPYING for more information.
   5 #
   6 # [Other people have contributed to this file; their copyrights should
   7 # go here too.]
   8 # Copyright 2007,2008,2009 by Don Armstrong <don@donarmstrong.com>.
   9
  10 package Debbugs::Control;
  11
  12 =head1 NAME
  13
  14 Debbugs::Control -- Routines for modifying the state of bugs
  15
  16 =head1 SYNOPSIS
  17
  18 use Debbugs::Control;
  19
  20
  21 =head1 DESCRIPTION
  22
  23 This module is an abstraction of a lot of functions which originally
  24 were only present in service.in, but as time has gone on needed to be
  25 called from elsewhere.
  26
  27 All of the public functions take the following options:
  28
  29 =over
  30
  31 =item debug -- scalar reference to which debbuging information is
  32 appended
  33
  34 =item transcript -- scalar reference to which transcript information
  35 is appended
  36
  37 =item affected_bugs -- hashref which is updated with bugs affected by
  38 this function
  39
  40
  41 =back
  42
  43 Functions which should (probably) append to the .log file take the
  44 following options:
  45
  46 =over
  47
  48 =item requester -- Email address of the individual who requested the change
  49
  50 =item request_addr -- Address to which the request was sent
  51
  52 =item request_nn -- Name of queue file which caused this request
  53
  54 =item request_msgid -- Message id of message which caused this request
  55
  56 =item location -- Optional location; currently ignored but may be
  57 supported in the future for updating archived bugs upon archival
  58
  59 =item message -- The original message which caused the action to be taken
  60
  61 =item append_log -- Whether or not to append information to the log.
  62
  63 =back
  64
  65 B<append_log> (for most functions) is a special option. When set to
  66 false, no appending to the log is done at all. When it is not present,
  67 the above information is faked, and appended to the log file. When it
  68 is true, the above options must be present, and their values are used.
  69
  70
  71 =head1 GENERAL FUNCTIONS
  72
  73 =cut
  74
  75 use warnings;
  76 use strict;
  77 use vars qw($VERSION $DEBUG %EXPORT_TAGS @EXPORT_OK @EXPORT);
  78 use base qw(Exporter);
  79
  80 BEGIN{
  81      $VERSION = 1.00;
  82      $DEBUG = 0 unless defined $DEBUG;
  83
  84      @EXPORT = ();
  85      %EXPORT_TAGS = (reopen    => [qw(reopen)],
  86                      submitter => [qw(set_submitter)],
  87                      severity => [qw(set_severity)],
  88                      affects => [qw(affects)],
  89                      summary => [qw(summary)],
  90                      owner   => [qw(owner)],
  91                      title   => [qw(set_title)],
  92                      forward => [qw(set_forwarded)],
  93                      found   => [qw(set_found set_fixed)],
  94                      fixed   => [qw(set_found set_fixed)],
  95                      package => [qw(set_package)],
  96                      block   => [qw(set_blocks)],
  97                      archive => [qw(bug_archive bug_unarchive),
  98                                 ],
  99                      log     => [qw(append_action_to_log),
 100                                 ],
 101                     );
 102      @EXPORT_OK = ();
 103      Exporter::export_ok_tags(keys %EXPORT_TAGS);
 104      $EXPORT_TAGS{all} = [@EXPORT_OK];
 105 }
 106
 107 use Debbugs::Config qw(:config);
 108 use Debbugs::Common qw(:lock buglog :misc get_hashname);
 109 use Debbugs::Status qw(bug_archiveable :read :hook writebug splitpackages split_status_fields);
 110 use Debbugs::CGI qw(html_escape);
 111 use Debbugs::Log qw(:misc);
 112 use Debbugs::Recipients qw(:add);
 113 use Debbugs::Packages qw(:versions :mapping);
 114
 115 use Params::Validate qw(validate_with :types);
 116 use File::Path qw(mkpath);
 117 use IO::File;
 118
 119 use Debbugs::Text qw(:templates);
 120
 121 use Debbugs::Mail qw(rfc822_date send_mail_message default_headers);
 122 use Debbugs::MIME qw(create_mime_message);
 123
 124 use Mail::RFC822::Address qw();
 125
 126 use POSIX qw(strftime);
 127
 128 use Storable qw(dclone nfreeze);
 129 use List::Util qw(first);
 130
 131 use Carp;
 132
 133 # These are a set of options which are common to all of these functions
 134
 135 my %common_options = (debug       => {type => SCALARREF|HANDLE,
 136                                       optional => 1,
 137                                      },
 138                       transcript  => {type => SCALARREF|HANDLE,
 139                                       optional => 1,
 140                                      },
 141                       affected_bugs => {type => HASHREF,
 142                                         optional => 1,
 143                                        },
 144                       affected_packages => {type => HASHREF,
 145                                             optional => 1,
 146                                            },
 147                       recipients    => {type => HASHREF,
 148                                         default => {},
 149                                        },
 150                       limit         => {type => HASHREF,
 151                                         default => {},
 152                                        },
 153                       show_bug_info => {type => BOOLEAN,
 154                                         default => 1,
 155                                        },
 156                       request_subject => {type => SCALAR,
 157                                           default => 'Unknown Subject',
 158                                          },
 159                       request_msgid    => {type => SCALAR,
 160                                            default => '',
 161                                           },
 162                       request_nn       => {type => SCALAR,
 163                                            optional => 1,
 164                                           },
 165                       request_replyto   => {type => SCALAR,
 166                                             optional => 1,
 167                                            },
 168                      );
 169
 170
 171 my %append_action_options =
 172      (action => {type => SCALAR,
 173                  optional => 1,
 174                 },
 175       requester => {type => SCALAR,
 176                     optional => 1,
 177                    },
 178       request_addr => {type => SCALAR,
 179                        optional => 1,
 180                       },
 181       location => {type => SCALAR,
 182                    optional => 1,
 183                   },
 184       message  => {type => SCALAR|ARRAYREF,
 185                    optional => 1,
 186                   },
 187       append_log => {type => BOOLEAN,
 188                      optional => 1,
 189                      depends => [qw(requester request_addr),
 190                                  qw(message),
 191                                 ],
 192                     },
 193      );
 194
 195
 196 # this is just a generic stub for Debbugs::Control functions.
 197 #
 198 # =head2 set_foo
 199 #
 200 #      eval {
 201 #           set_foo(bug          => $ref,
 202 #                   transcript   => $transcript,
 203 #                   ($dl > 0 ? (debug => $transcript):()),
 204 #                   requester    => $header{from},
 205 #                   request_addr => $controlrequestaddr,
 206 #                   message      => \@log,
 207 #                   affected_packages => \%affected_packages,
 208 #                   recipients   => \%recipients,
 209 #                   summary      => undef,
 210 #                  );
 211 #       };
 212 #       if ($@) {
 213 #           $errors++;
 214 #           print {$transcript} "Failed to set foo $ref bar: $@";
 215 #       }
 216 #
 217 # Foo frobinates
 218 #
 219 # =cut
 220 #
 221 # sub set_foo {
 222 #     my %param = validate_with(params => \@_,
 223 #                             spec   => {bug => {type   => SCALAR,
 224 #                                                regex  => qr/^\d+$/,
 225 #                                               },
 226 #                                        # specific options here
 227 #                                        %common_options,
 228 #                                        %append_action_options,
 229 #                                       },
 230 #                            );
 231 #     my %info =
 232 #       __begin_control(%param,
 233 #                       command  => 'foo'
 234 #                      );
 235 #     my ($debug,$transcript) =
 236 #       @info{qw(debug transcript)};
 237 #     my @data = @{$info{data}};
 238 #     my @bugs = @{$info{bugs}};
 239 #
 240 #     my $action = '';
 241 #     for my $data (@data) {
 242 #       append_action_to_log(bug => $data->{bug_num},
 243 #                            get_lock => 0,
 244 #                            __return_append_to_log_options(
 245 #                                                           %param,
 246 #                                                           action => $action,
 247 #                                                          ),
 248 #                           )
 249 #           if not exists $param{append_log} or $param{append_log};
 250 #       writebug($data->{bug_num},$data);
 251 #       print {$transcript} "$action\n";
 252 #     }
 253 #     __end_control(%info);
 254 # }
 255
 256
 257 =head2 set_blocks
 258
 259      eval {
 260             set_block(bug          => $ref,
 261                       transcript   => $transcript,
 262                       ($dl > 0 ? (debug => $transcript):()),
 263                       requester    => $header{from},
 264                       request_addr => $controlrequestaddr,
 265                       message      => \@log,
 266                       affected_packages => \%affected_packages,
 267                       recipients   => \%recipients,
 268                       block        => [],
 269                      );
 270         };
 271         if ($@) {
 272             $errors++;
 273             print {$transcript} "Failed to set blockers of $ref: $@";
 274         }
 275
 276 Alters the set of bugs that block this bug from being fixed
 277
 278 This requires altering both this bug (and those it's merged with) as
 279 well as the bugs that block this bug from being fixed (and those that
 280 it's merged with)
 281
 282 =over
 283
 284 =item block -- scalar or arrayref of blocking bugs to set, add or remove
 285
 286 =item add -- if true, add blocking bugs
 287
 288 =item remove -- if true, remove blocking bugs
 289
 290 =back
 291
 292 =cut
 293
 294 sub set_blocks {
 295     my %param = validate_with(params => \@_,
 296                               spec   => {bug => {type   => SCALAR,
 297                                                  regex  => qr/^\d+$/,
 298                                                 },
 299                                          # specific options here
 300                                          block => {type => SCALAR|ARRAYREF,
 301                                                    default => [],
 302                                                   },
 303                                          add    => {type => BOOLEAN,
 304                                                     default => 0,
 305                                                    },
 306                                          remove => {type => BOOLEAN,
 307                                                     default => 0,
 308                                                    },
 309                                          %common_options,
 310                                          %append_action_options,
 311                                         },
 312                              );
 313     if ($param{add} and $param{remove}) {
 314         croak "It's nonsensical to add and remove the same blocking bugs";
 315     }
 316     if (grep {$_ !~ /^\d+$/} make_list($param{block})) {
 317         croak "Invalid blocking bug(s):".
 318             join(', ',grep {$_ !~ /^\d+$/} make_list($param{block}));
 319     }
 320     my $mode = 'set';
 321     if (exists $param{add}) {
 322         $mode = 'add';
 323     }
 324     elsif (exists $param{remove}) {
 325         $mode = 'remove';
 326     }
 327
 328     my %info =
 329         __begin_control(%param,
 330                         command  => 'blocks'
 331                        );
 332     my ($debug,$transcript) =
 333         @info{qw(debug transcript)};
 334     my @data = @{$info{data}};
 335     my @bugs = @{$info{bugs}};
 336
 337
 338     # The first bit of this code is ugly, and should be cleaned up.
 339     # Its purpose is to populate %removed_blockers and %add_blockers
 340     # with all of the bugs that should be added or removed as blockers
 341     # of all of the bugs which are merged with $param{bug}
 342     my %ok_blockers;
 343     my %bad_blockers;
 344     for my $blocker (make_list($param{block})) {
 345         next if $ok_blockers{$blocker} or $bad_blockers{$blocker};
 346         my $data = read_bug(bug=>$blocker,
 347                            );
 348         if (defined $data and not $data->{archive}) {
 349             $data = split_status_fields($data);
 350             $ok_blockers{$blocker} = 1;
 351             my @merged_bugs;
 352             push @merged_bugs, make_list($data->{mergedwith});
 353             $ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs;
 354         }
 355         else {
 356             $bad_blockers{$blocker} = 1;
 357         }
 358     }
 359
 360     # throw an error if we are setting the blockers and there is a bad
 361     # blocker
 362     if (keys %bad_blockers and $mode eq 'set') {
 363         croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers).
 364             keys %ok_blockers?'':" and no known blocking bug(s)";
 365     }
 366     # if there are no ok blockers and we are not setting the blockers,
 367     # there's an error.
 368     if (not keys %ok_blockers and $mode ne 'set') {
 369         print {$transcript} "No valid blocking bug(s) given; not doing anything\n";
 370         if (keys %bad_blockers) {
 371             croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers);
 372         }
 373         __end_control(%info);
 374         return;
 375     }
 376
 377     my @change_blockers = keys %ok_blockers;
 378
 379     my %removed_blockers;
 380     my %added_blockers;
 381     my $action = '';
 382     my @blockers = map {split ' ', $_->{blockedby}} @data;
 383     my %blockers;
 384     @blockers{@blockers} = (1) x @blockers;
 385
 386     # it is nonsensical for a bug to block itself (or a merged
 387     # partner); We currently don't allow removal because we'd possibly
 388     # deadlock
 389
 390     my %bugs;
 391     @bugs{@bugs} = (1) x @bugs;
 392     for my $blocker (@change_blockers) {
 393         if ($bugs{$blocker}) {
 394             croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker";
 395         }
 396     }
 397     @blockers = keys %blockers;
 398     if ($param{add}) {
 399         %removed_blockers = ();
 400         for my $blocker (@change_blockers) {
 401             next if exists $blockers{$blocker};
 402             $blockers{$blocker} = 1;
 403             $added_blockers{$blocker} = 1;
 404         }
 405     }
 406     elsif ($param{remove}) {
 407         %added_blockers = ();
 408         for my $blocker (@change_blockers) {
 409             next if exists $removed_blockers{$blocker};
 410             delete $blockers{$blocker};
 411             $removed_blockers{$blocker} = 1;
 412         }
 413     }
 414     else {
 415         @removed_blockers{@blockers} = (1) x @blockers;
 416         %blockers = ();
 417         for my $blocker (@change_blockers) {
 418             next if exists $blockers{$blocker};
 419             $blockers{$blocker} = 1;
 420             if (exists $removed_blockers{$blocker}) {
 421                 delete $removed_blockers{$blocker};
 422             }
 423             else {
 424                 $added_blockers{$blocker} = 1;
 425             }
 426         }
 427     }
 428     my @new_blockers = keys %blockers;
 429     for my $data (@data) {
 430         my $old_data = dclone($data);
 431         # remove blockers and/or add new ones as appropriate
 432         if ($data->{blockedby} eq '') {
 433             print {$transcript} "Was not blocked by any bugs.\n";
 434         } else {
 435             print {$transcript} "Was blocked by: $data->{blockedby}\n";
 436         }
 437         my @changed;
 438         push @changed, 'added blocking bug(s) '.english_join([keys %added_blockers]) if keys %added_blockers;
 439         push @changed, 'removed blocking bug(s) '.english_join([keys %removed_blockers]) if keys %removed_blockers;
 440         $action = ucfirst(join ('; ',@changed)) if @changed;
 441         if (not @changed) {
 442             print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
 443                 unless __internal_request();
 444             next;
 445         }
 446         $data->{blockedby} = join(' ',keys %blockers);
 447         append_action_to_log(bug => $data->{bug_num},
 448                              command  => 'block',
 449                              old_data => $old_data,
 450                              new_data => $data,
 451                              get_lock => 0,
 452                              __return_append_to_log_options(
 453                                                             %param,
 454                                                             action => $action,
 455                                                            ),
 456                             )
 457             if not exists $param{append_log} or $param{append_log};
 458         writebug($data->{bug_num},$data);
 459         print {$transcript} "$action\n";
 460     }
 461     # we do this bit below to avoid code duplication
 462     my %mungable_blocks;
 463     $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers;
 464     $mungable_blocks{add} = \%added_blockers if keys %added_blockers;
 465     for my $add_remove (keys %mungable_blocks) {
 466         my @munge_blockers;
 467         my %munge_blockers;
 468         my $block_locks = 0;
 469         for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
 470             next if $munge_blockers{$blocker};
 471             my ($new_locks, @blocking_data) =
 472                 lock_read_all_merged_bugs($blocker,
 473                                           ($param{archived}?'archive':()));
 474             if (not @blocking_data) {
 475                 unfilelock() for $new_locks;
 476                 die "Unable to get file lock while trying to $add_remove blocker '$blocker'";
 477             }
 478             for (map {$_->{bug_num}} @blocking_data) {
 479                 $munge_blockers{$_} = 1;
 480             }
 481             for my $data (@blocking_data) {
 482                 my $old_data = dclone($data);
 483                 my %blocks;
 484                 %blocks = split ' ', $data->{blocks};
 485                 my @blocks;
 486                 for my $bug (@bugs) {
 487                     if ($add_remove eq 'remove') {
 488                         next unless exists $blocks{$bug};
 489                         delete $blocks{$bug};
 490                     }
 491                     else {
 492                         next if exists $blocks{$bug};
 493                         $blocks{$bug} = 1;
 494                     }
 495                     push @blocks, $bug;
 496                 }
 497                 $data->{blocks} = join(' ',sort keys %blocks);
 498                 my $action = ($add_remove eq 'add'?'Added':'Removed').
 499                     " indication that bug $data->{bug_num} blocks".
 500                     join(',',@blocks);
 501                 append_action_to_log(bug => $data->{bug_num},
 502                                      command => 'block',
 503                                      old_data => $old_data,
 504                                      new_data => $data,
 505                                      get_lock => 0,
 506                                      __return_append_to_log_options(%param,
 507                                                                    action => $action
 508                                                                    )
 509                                     );
 510             }
 511             __handle_affected_packages(%param,data=>\@blocking_data);
 512             add_recipients(recipients => $param{recipients},
 513                            actions_taken => {blocks => 1},
 514                            data       => \@blocking_data,
 515                            debug      => $debug,
 516                            transcript => $transcript,
 517                           );
 518
 519             unfilelock() for $new_locks;
 520         }
 521     }
 522     __end_control(%info);
 523 }
 524
 525
 526
 527 =head2 set_tag
 528
 529      eval {
 530             set_tag(bug          => $ref,
 531                     transcript   => $transcript,
 532                     ($dl > 0 ? (debug => $transcript):()),
 533                     requester    => $header{from},
 534                     request_addr => $controlrequestaddr,
 535                     message      => \@log,
 536                     affected_packages => \%affected_packages,
 537                     recipients   => \%recipients,
 538                     tag          => [],
 539                     add          => 1,
 540                    );
 541         };
 542         if ($@) {
 543             $errors++;
 544             print {$transcript} "Failed to set tag on $ref: $@";
 545         }
 546
 547
 548 Sets, adds, or removes the specified tags on a bug
 549
 550 =over
 551
 552 =item tag -- scalar or arrayref of tags to set, add or remove
 553
 554 =item add -- if true, add tags
 555
 556 =item remove -- if true, remove tags
 557
 558 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
 559 passed.
 560
 561 =back
 562
 563 =cut
 564
 565 sub set_tag {
 566     my %param = validate_with(params => \@_,
 567                               spec   => {bug => {type   => SCALAR,
 568                                                  regex  => qr/^\d+$/,
 569                                                 },
 570                                          # specific options here
 571                                          tag    => {type => SCALAR|ARRAYREF,
 572                                                     default => [],
 573                                                    },
 574                                          add      => {type => BOOLEAN,
 575                                                       default => 0,
 576                                                      },
 577                                          remove   => {type => BOOLEAN,
 578                                                       default => 0,
 579                                                      },
 580                                          warn_on_bad_tags => {type => BOOLEAN,
 581                                                               default => 1,
 582                                                              },
 583                                          %common_options,
 584                                          %append_action_options,
 585                                         },
 586                              );
 587     if ($param{add} and $param{remove}) {
 588         croak "It's nonsensical to add and remove the same tags";
 589     }
 590
 591     my %info =
 592         __begin_control(%param,
 593                         command  => 'tag'
 594                        );
 595     my ($debug,$transcript) =
 596         @info{qw(debug transcript)};
 597     my @data = @{$info{data}};
 598     my @bugs = @{$info{bugs}};
 599     my @tags = make_list($param{tag});
 600     if (not @tags and ($param{remove} or $param{add})) {
 601         if ($param{remove}) {
 602             print {$transcript} "Requested to remove no tags; doing nothing.\n";
 603         }
 604         else {
 605             print {$transcript} "Requested to add no tags; doing nothing.\n";
 606         }
 607         __end_control(%info);
 608         return;
 609     }
 610     # first things first, make the versions fully qualified source
 611     # versions
 612     for my $data (@data) {
 613         my $action = 'Did not alter tags';
 614         my %tag_added = ();
 615         my %tag_removed = ();
 616         my %fixed_removed = ();
 617         my @old_tags = split /\,\s*/, $data->{tags};
 618         my %tags;
 619         @tags{@old_tags} = (1) x @old_tags;
 620         my $reopened = 0;
 621         my $old_data = dclone($data);
 622         if (not $param{add} and not $param{remove}) {
 623             $tag_removed{$_} = 1 for @old_tags;
 624             %tags = ();
 625         }
 626         my @bad_tags = ();
 627         for my $tag (@tags) {
 628             if (not $param{remove} and
 629                 not defined first {$_ eq $tag} @{$config{tags}}) {
 630                 push @bad_tags, $tag;
 631                 next;
 632             }
 633             if ($param{add}) {
 634                 if (not exists $tags{$tag}) {
 635                     $tags{$tag} = 1;
 636                     $tag_added{$tag} = 1;
 637                 }
 638             }
 639             elsif ($param{remove}) {
 640                 if (exists $tags{$tag}) {
 641                     delete $tags{$tag};
 642                     $tag_removed{$tag} = 1;
 643                 }
 644             }
 645             else {
 646                 if (exists $tag_removed{$tag}) {
 647                     delete $tag_removed{$tag};
 648                 }
 649                 else {
 650                     $tag_added{$tag} = 1;
 651                 }
 652                 $tags{$tag} = 1;
 653             }
 654         }
 655         if (@bad_tags and $param{warn_on_bad_tags}) {
 656             print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
 657             print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
 658         }
 659         $data->{tags} = join(', ',keys %tags); # double check this
 660
 661         my @changed;
 662         push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
 663         push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
 664         $action = ucfirst(join ('; ',@changed)) if @changed;
 665         if (not @changed) {
 666             print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
 667                 unless __internal_request();
 668             next;
 669         }
 670         $action .= '.';
 671         append_action_to_log(bug => $data->{bug_num},
 672                              get_lock => 0,
 673                              command  => 'tag',
 674                              old_data => $old_data,
 675                              new_data => $data,
 676                              __return_append_to_log_options(
 677                                                             %param,
 678                                                             action => $action,
 679                                                            ),
 680                             )
 681             if not exists $param{append_log} or $param{append_log};
 682         writebug($data->{bug_num},$data);
 683         print {$transcript} "$action\n";
 684     }
 685     __end_control(%info);
 686 }
 687
 688
 689
 690 =head2 set_severity
 691
 692      eval {
 693             set_severity(bug          => $ref,
 694                          transcript   => $transcript,
 695                          ($dl > 0 ? (debug => $transcript):()),
 696                          requester    => $header{from},
 697                          request_addr => $controlrequestaddr,
 698                          message      => \@log,
 699                          affected_packages => \%affected_packages,
 700                          recipients   => \%recipients,
 701                          severity     => 'normal',
 702                         );
 703         };
 704         if ($@) {
 705             $errors++;
 706             print {$transcript} "Failed to set the severity of bug $ref: $@";
 707         }
 708
 709 Sets the severity of a bug. If severity is not passed, is undefined,
 710 or has zero length, sets the severity to the defafult severity.
 711
 712 =cut
 713
 714 sub set_severity {
 715     my %param = validate_with(params => \@_,
 716                               spec   => {bug => {type   => SCALAR,
 717                                                  regex  => qr/^\d+$/,
 718                                                 },
 719                                          # specific options here
 720                                          severity => {type => SCALAR|UNDEF,
 721                                                       default => $config{default_severity},
 722                                                      },
 723                                          %common_options,
 724                                          %append_action_options,
 725                                         },
 726                              );
 727     if (not defined $param{severity} or
 728         not length $param{severity}
 729        ) {
 730         $param{severity} = $config{default_severity};
 731     }
 732
 733     # check validity of new severity
 734     if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
 735         die "Severity '$param{severity}' is not a valid severity level";
 736     }
 737     my %info =
 738         __begin_control(%param,
 739                         command  => 'severity'
 740                        );
 741     my ($debug,$transcript) =
 742         @info{qw(debug transcript)};
 743     my @data = @{$info{data}};
 744     my @bugs = @{$info{bugs}};
 745
 746     my $action = '';
 747     for my $data (@data) {
 748         if (not defined $data->{severity}) {
 749             $data->{severity} = $param{severity};
 750             $action = "Severity set to '$param{severity}'\n";
 751         }
 752         else {
 753             if ($data->{severity} eq '') {
 754                 $data->{severity} = $config{default_severity};
 755             }
 756             if ($data->{severity} eq $param{severity}) {
 757                 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
 758                 next;
 759             }
 760             $action = "Severity set to '$param{severity}' from '$data->{severity}'\n";
 761             $data->{severity} = $param{severity};
 762         }
 763         append_action_to_log(bug => $data->{bug_num},
 764                              get_lock => 0,
 765                              __return_append_to_log_options(
 766                                                             %param,
 767                                                             action => $action,
 768                                                            ),
 769                             )
 770             if not exists $param{append_log} or $param{append_log};
 771         writebug($data->{bug_num},$data);
 772         print {$transcript} "$action\n";
 773     }
 774     __end_control(%info);
 775 }
 776
 777
 778 =head2 reopen
 779
 780      eval {
 781             set_foo(bug          => $ref,
 782                     transcript   => $transcript,
 783                     ($dl > 0 ? (debug => $transcript):()),
 784                     requester    => $header{from},
 785                     request_addr => $controlrequestaddr,
 786                     message      => \@log,
 787                   affected_packages => \%affected_packages,
 788                     recipients   => \%recipients,
 789                     summary      => undef,
 790                  );
 791         };
 792         if ($@) {
 793             $errors++;
 794             print {$transcript} "Failed to set foo $ref bar: $@";
 795         }
 796
 797 Foo frobinates
 798
 799 =cut
 800
 801 sub reopen {
 802     my %param = validate_with(params => \@_,
 803                               spec   => {bug => {type   => SCALAR,
 804                                                  regex  => qr/^\d+$/,
 805                                                 },
 806                                          # specific options here
 807                                          submitter => {type => SCALAR|UNDEF,
 808                                                        default => undef,
 809                                                       },
 810                                          %common_options,
 811                                          %append_action_options,
 812                                         },
 813                              );
 814
 815     $param{submitter} = undef if defined $param{submitter} and
 816         not length $param{submitter};
 817
 818     if (defined $param{submitter} and
 819         not Mail::RFC822::Address::valid($param{submitter})) {
 820         die "New submitter address $param{submitter} is not a valid e-mail address";
 821     }
 822
 823     my %info =
 824         __begin_control(%param,
 825                         command  => 'reopen'
 826                        );
 827     my ($debug,$transcript) =
 828         @info{qw(debug transcript)};
 829     my @data = @{$info{data}};
 830     my @bugs = @{$info{bugs}};
 831     my $action ='';
 832
 833     my $warn_fixed = 1; # avoid warning multiple times if there are
 834                         # fixed versions
 835     my @change_submitter = ();
 836     my @bugs_to_reopen = ();
 837     for my $data (@data) {
 838         if (not exists $data->{done} or
 839             not defined $data->{done} or
 840             not length $data->{done}) {
 841             print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
 842             __end_control(%info);
 843             return;
 844         }
 845         if (@{$data->{fixed_versions}} and $warn_fixed) {
 846             print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
 847             print {$transcript} "you may need to use 'found' to remove fixed versions.\n";
 848             $warn_fixed = 0;
 849         }
 850         if (defined $param{submitter} and length $param{submitter}
 851             and $data->{originator} ne $param{submitter}) {
 852             push @change_submitter,$data->{bug_num};
 853         }
 854     }
 855     __end_control(%info);
 856     my @params_for_subcalls =
 857         map {exists $param{$_}?($_,$param{$_}):()}
 858             (keys %common_options,
 859              keys %append_action_options,
 860             );
 861
 862     for my $bug (@change_submitter) {
 863         set_submitter(bug=>$bug,
 864                       submitter => $param{submitter},
 865                       @params_for_subcalls,
 866                      );
 867     }
 868     set_fixed(fixed => [],
 869               bug => $param{bug},
 870               reopen => 1,
 871              );
 872 }
 873
 874
 875 =head2 set_submitter
 876
 877      eval {
 878             set_submitter(bug          => $ref,
 879                           transcript   => $transcript,
 880                           ($dl > 0 ? (debug => $transcript):()),
 881                           requester    => $header{from},
 882                           request_addr => $controlrequestaddr,
 883                           message      => \@log,
 884                           affected_packages => \%affected_packages,
 885                           recipients   => \%recipients,
 886                           submitter    => $new_submitter,
 887                           notify_submitter => 1,
 888                           );
 889         };
 890         if ($@) {
 891             $errors++;
 892             print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
 893         }
 894
 895 Sets the submitter of a bug. If notify_submitter is true (the
 896 default), notifies the old submitter of a bug on changes
 897
 898 =cut
 899
 900 sub set_submitter {
 901     my %param = validate_with(params => \@_,
 902                               spec   => {bug => {type   => SCALAR,
 903                                                  regex  => qr/^\d+$/,
 904                                                 },
 905                                          # specific options here
 906                                          submitter => {type => SCALAR,
 907                                                       },
 908                                          notify_submitter => {type => BOOLEAN,
 909                                                               default => 1,
 910                                                              },
 911                                          %common_options,
 912                                          %append_action_options,
 913                                         },
 914                              );
 915     if (not Mail::RFC822::Address::valid($param{submitter})) {
 916         die "New submitter address $param{submitter} is not a valid e-mail address";
 917     }
 918     my %info =
 919         __begin_control(%param,
 920                         command  => 'submitter'
 921                        );
 922     my ($debug,$transcript) =
 923         @info{qw(debug transcript)};
 924     my @data = @{$info{data}};
 925     my @bugs = @{$info{bugs}};
 926     my $action = '';
 927     # here we only concern ourselves with the first of the merged bugs
 928     for my $data ($data[0]) {
 929         my $notify_old_submitter = 0;
 930         my $old_data = dclone($data);
 931         print {$debug} "Going to change bug submitter\n";
 932         if (((not defined $param{submitter} or not length $param{submitter}) and
 933               (not defined $data->{originator} or not length $data->{originator})) or
 934              (defined $param{submitter} and defined $data->{originator} and
 935               $param{submitter} eq $data->{originator})) {
 936             print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"
 937                 unless __internal_request();
 938             next;
 939         }
 940         else {
 941             if (defined $data->{originator} and length($data->{originator})) {
 942                 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
 943                 $notify_old_submitter = 1;
 944             }
 945             else {
 946                 $action= "Set $config{bug} submitter to '$param{submitter}'.";
 947             }
 948             $data->{originator} = $param{submitter};
 949         }
 950         append_action_to_log(bug => $data->{bug_num},
 951                              command => 'submitter',
 952                              new_data => $data,
 953                              old_data => $old_data,
 954                              get_lock => 0,
 955                              __return_append_to_log_options(
 956                                                             %param,
 957                                                             action => $action,
 958                                                            ),
 959                             )
 960             if not exists $param{append_log} or $param{append_log};
 961         writebug($data->{bug_num},$data);
 962         print {$transcript} "$action\n";
 963         # notify old submitter
 964         if ($notify_old_submitter and $param{notify_submitter}) {
 965             send_mail_message(message =>
 966                               create_mime_message([default_headers(queue_file => $param{request_nn},
 967                                                                    data => $data,
 968                                                                    msgid => $param{request_msgid},
 969                                                                    msgtype => 'ack',
 970                                                                    pr_msg  => 'submitter-changed',
 971                                                                    headers =>
 972                                                                    [To => $old_data->{submitter},
 973                                                                     Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
 974                                                                    ],
 975                                                                   )
 976                                                   ],
 977                                                   __message_body_template('mail/submitter_changed',
 978                                                                           {old_data => $old_data,
 979                                                                            data     => $data,
 980                                                                            replyto  => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
 981                                                                            config   => \%config,
 982                                                                           })
 983                                                  ),
 984                               recipients => $old_data->{submitter},
 985                              );
 986         }
 987     }
 988     __end_control(%info);
 989 }
 990
 991
 992
 993 =head2 set_forwarded
 994
 995      eval {
 996             set_forwarded(bug          => $ref,
 997                           transcript   => $transcript,
 998                           ($dl > 0 ? (debug => $transcript):()),
 999                           requester    => $header{from},
1000                           request_addr => $controlrequestaddr,
1001                           message      => \@log,
1002                           affected_packages => \%affected_packages,
1003                           recipients   => \%recipients,
1004                           forwarded    => $forward_to,
1005                           );
1006         };
1007         if ($@) {
1008             $errors++;
1009             print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1010         }
1011
1012 Sets the location to which a bug is forwarded. Given an undef
1013 forwarded, unsets forwarded.
1014
1015
1016 =cut
1017
1018 sub set_forwarded {
1019     my %param = validate_with(params => \@_,
1020                               spec   => {bug => {type   => SCALAR,
1021                                                  regex  => qr/^\d+$/,
1022                                                 },
1023                                          # specific options here
1024                                          forwarded => {type => SCALAR|UNDEF,
1025                                                       },
1026                                          %common_options,
1027                                          %append_action_options,
1028                                         },
1029                              );
1030     if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1031         die "Non-printable characters are not allowed in the forwarded field";
1032     }
1033     my %info =
1034         __begin_control(%param,
1035                         command  => 'forwarded'
1036                        );
1037     my ($debug,$transcript) =
1038         @info{qw(debug transcript)};
1039     my @data = @{$info{data}};
1040     my @bugs = @{$info{bugs}};
1041     my $action = '';
1042     for my $data (@data) {
1043         my $old_data = dclone($data);
1044         print {$debug} "Going to change bug forwarded\n";
1045         if (((not defined $param{forwarded} or not length $param{forwarded}) and
1046               (not defined $data->{forwarded} or not length $data->{forwarded})) or
1047              $param{forwarded} eq $data->{forwarded}) {
1048             print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
1049                 unless __internal_request();
1050             next;
1051         }
1052         else {
1053             if (not defined $param{forwarded}) {
1054                 $action= "Unset $config{bug} forwarded-to-address";
1055             }
1056             elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1057                 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1058             }
1059             else {
1060                 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1061             }
1062             $data->{forwarded} = $param{forwarded};
1063         }
1064         append_action_to_log(bug => $data->{bug_num},
1065                              command => 'forwarded',
1066                              new_data => $data,
1067                              old_data => $old_data,
1068                              get_lock => 0,
1069                              __return_append_to_log_options(
1070                                                             %param,
1071                                                             action => $action,
1072                                                            ),
1073                             )
1074             if not exists $param{append_log} or $param{append_log};
1075         writebug($data->{bug_num},$data);
1076         print {$transcript} "$action\n";
1077     }
1078     __end_control(%info);
1079 }
1080
1081
1082
1083
1084 =head2 set_title
1085
1086      eval {
1087             set_title(bug          => $ref,
1088                       transcript   => $transcript,
1089                       ($dl > 0 ? (debug => $transcript):()),
1090                       requester    => $header{from},
1091                       request_addr => $controlrequestaddr,
1092                       message      => \@log,
1093                       affected_packages => \%affected_packages,
1094                       recipients   => \%recipients,
1095                       title        => $new_title,
1096                       );
1097         };
1098         if ($@) {
1099             $errors++;
1100             print {$transcript} "Failed to set the title of $ref: $@";
1101         }
1102
1103 Sets the title of a specific bug
1104
1105
1106 =cut
1107
1108 sub set_title {
1109     my %param = validate_with(params => \@_,
1110                               spec   => {bug => {type   => SCALAR,
1111                                                  regex  => qr/^\d+$/,
1112                                                 },
1113                                          # specific options here
1114                                          title => {type => SCALAR,
1115                                                   },
1116                                          %common_options,
1117                                          %append_action_options,
1118                                         },
1119                              );
1120     if ($param{title} =~ /[^[:print:]]/) {
1121         die "Non-printable characters are not allowed in bug titles";
1122     }
1123
1124     my %info = __begin_control(%param,
1125                                command  => 'title',
1126                               );
1127     my ($debug,$transcript) =
1128         @info{qw(debug transcript)};
1129     my @data = @{$info{data}};
1130     my @bugs = @{$info{bugs}};
1131     my $action = '';
1132     for my $data (@data) {
1133         my $old_data = dclone($data);
1134         print {$debug} "Going to change bug title\n";
1135         if (defined $data->{subject} and length($data->{subject}) and
1136             $data->{subject} eq $param{title}) {
1137             print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"
1138                 unless __internal_request();
1139             next;
1140         }
1141         else {
1142             if (defined $data->{subject} and length($data->{subject})) {
1143                 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1144             } else {
1145                 $action= "Set $config{bug} title to '$param{title}'.";
1146             }
1147             $data->{subject} = $param{title};
1148         }
1149         append_action_to_log(bug => $data->{bug_num},
1150                              command => 'title',
1151                              new_data => $data,
1152                              old_data => $old_data,
1153                              get_lock => 0,
1154                              __return_append_to_log_options(
1155                                                             %param,
1156                                                             action => $action,
1157                                                            ),
1158                             )
1159             if not exists $param{append_log} or $param{append_log};
1160         writebug($data->{bug_num},$data);
1161         print {$transcript} "$action\n";
1162     }
1163     __end_control(%info);
1164 }
1165
1166
1167 =head2 set_package
1168
1169      eval {
1170             set_package(bug          => $ref,
1171                         transcript   => $transcript,
1172                         ($dl > 0 ? (debug => $transcript):()),
1173                         requester    => $header{from},
1174                         request_addr => $controlrequestaddr,
1175                         message      => \@log,
1176                         affected_packages => \%affected_packages,
1177                         recipients   => \%recipients,
1178                         package      => $new_package,
1179                         is_source    => 0,
1180                        );
1181         };
1182         if ($@) {
1183             $errors++;
1184             print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1185         }
1186
1187 Indicates that a bug is in a particular package. If is_source is true,
1188 indicates that the package is a source package. [Internally, this
1189 causes src: to be prepended to the package name.]
1190
1191 The default for is_source is 0. As a special case, if the package
1192 starts with 'src:', it is assumed to be a source package and is_source
1193 is overridden.
1194
1195 The package option must match the package_name_re regex.
1196
1197 =cut
1198
1199 sub set_package {
1200     my %param = validate_with(params => \@_,
1201                               spec   => {bug => {type   => SCALAR,
1202                                                  regex  => qr/^\d+$/,
1203                                                 },
1204                                          # specific options here
1205                                          package => {type => SCALAR|ARRAYREF,
1206                                                     },
1207                                          is_source => {type => BOOLEAN,
1208                                                        default => 0,
1209                                                       },
1210                                          %common_options,
1211                                          %append_action_options,
1212                                         },
1213                              );
1214     my @new_packages = map {splitpackages($_)} make_list($param{package});
1215     if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1216         croak "Invalid package name '".
1217             join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1218                 "'";
1219     }
1220     my %info = __begin_control(%param,
1221                                command  => 'package',
1222                               );
1223     my ($debug,$transcript) =
1224         @info{qw(debug transcript)};
1225     my @data = @{$info{data}};
1226     my @bugs = @{$info{bugs}};
1227     # clean up the new package
1228     my $new_package =
1229         join(',',
1230              map {my $temp = $_;
1231                   ($temp =~ s/^src:// or
1232                    $param{is_source}) ? 'src:'.$temp:$temp;
1233               } @new_packages);
1234
1235     my $action = '';
1236     my $package_reassigned = 0;
1237     for my $data (@data) {
1238         my $old_data = dclone($data);
1239         print {$debug} "Going to change assigned package\n";
1240         if (defined $data->{package} and length($data->{package}) and
1241             $data->{package} eq $new_package) {
1242             print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"
1243                 unless __internal_request();
1244             next;
1245         }
1246         else {
1247             if (defined $data->{package} and length($data->{package})) {
1248                 $package_reassigned = 1;
1249                 $action= "$config{bug} reassigned from package '$data->{package}'".
1250                     " to '$new_package'.";
1251             } else {
1252                 $action= "$config{bug} assigned to package '$new_package'.";
1253             }
1254             $data->{package} = $new_package;
1255         }
1256         append_action_to_log(bug => $data->{bug_num},
1257                              command => 'package',
1258                              new_data => $data,
1259                              old_data => $old_data,
1260                              get_lock => 0,
1261                              __return_append_to_log_options(
1262                                                             %param,
1263                                                             action => $action,
1264                                                            ),
1265                             )
1266             if not exists $param{append_log} or $param{append_log};
1267         writebug($data->{bug_num},$data);
1268         print {$transcript} "$action\n";
1269     }
1270     __end_control(%info);
1271     # Only clear the fixed/found versions if the package has been
1272     # reassigned
1273     if ($package_reassigned) {
1274         my @params_for_found_fixed =
1275             map {exists $param{$_}?($_,$param{$_}):()}
1276                 ('bug',
1277                  keys %common_options,
1278                  keys %append_action_options,
1279                 );
1280         set_found(found => [],
1281                   @params_for_found_fixed,
1282                  );
1283         set_fixed(fixed => [],
1284                   @params_for_found_fixed,
1285                  );
1286     }
1287 }
1288
1289 =head2 set_found
1290
1291      eval {
1292             set_found(bug          => $ref,
1293                       transcript   => $transcript,
1294                       ($dl > 0 ? (debug => $transcript):()),
1295                       requester    => $header{from},
1296                       request_addr => $controlrequestaddr,
1297                       message      => \@log,
1298                       affected_packages => \%affected_packages,
1299                       recipients   => \%recipients,
1300                       found        => [],
1301                       add          => 1,
1302                      );
1303         };
1304         if ($@) {
1305             $errors++;
1306             print {$transcript} "Failed to set found on $ref: $@";
1307         }
1308
1309
1310 Sets, adds, or removes the specified found versions of a package
1311
1312 If the version list is empty, and the bug is currently not "done",
1313 causes the done field to be cleared.
1314
1315 If any of the versions added to found are greater than any version in
1316 which the bug is fixed (or when the bug is found and there are no
1317 fixed versions) the done field is cleared.
1318
1319 =cut
1320
1321 sub set_found {
1322     my %param = validate_with(params => \@_,
1323                               spec   => {bug => {type   => SCALAR,
1324                                                  regex  => qr/^\d+$/,
1325                                                 },
1326                                          # specific options here
1327                                          found    => {type => SCALAR|ARRAYREF,
1328                                                       default => [],
1329                                                      },
1330                                          add      => {type => BOOLEAN,
1331                                                       default => 0,
1332                                                      },
1333                                          remove   => {type => BOOLEAN,
1334                                                       default => 0,
1335                                                      },
1336                                          %common_options,
1337                                          %append_action_options,
1338                                         },
1339                              );
1340     if ($param{add} and $param{remove}) {
1341         croak "It's nonsensical to add and remove the same versions";
1342     }
1343
1344     my %info =
1345         __begin_control(%param,
1346                         command  => 'found'
1347                        );
1348     my ($debug,$transcript) =
1349         @info{qw(debug transcript)};
1350     my @data = @{$info{data}};
1351     my @bugs = @{$info{bugs}};
1352     my %versions;
1353     for my $version (make_list($param{found})) {
1354         next unless defined $version;
1355         $versions{$version} =
1356             [make_source_versions(package => [splitpackages($data[0]{package})],
1357                                   warnings => $transcript,
1358                                   debug    => $debug,
1359                                   guess_source => 0,
1360                                   versions     => $version,
1361                                  )
1362             ];
1363         # This is really ugly, but it's what we have to do
1364         if (not @{$versions{$version}}) {
1365             print {$transcript} "Unable to make a source version for version '$version'\n";
1366         }
1367     }
1368     if (not keys %versions and ($param{remove} or $param{add})) {
1369         if ($param{remove}) {
1370             print {$transcript} "Requested to remove no versions; doing nothing.\n";
1371         }
1372         else {
1373             print {$transcript} "Requested to add no versions; doing nothing.\n";
1374         }
1375         __end_control(%info);
1376         return;
1377     }
1378     # first things first, make the versions fully qualified source
1379     # versions
1380     for my $data (@data) {
1381         # The 'done' field gets a bit weird with version tracking,
1382         # because a bug may be closed by multiple people in different
1383         # branches. Until we have something more flexible, we set it
1384         # every time a bug is fixed, and clear it when a bug is found
1385         # in a version greater than any version in which the bug is
1386         # fixed or when a bug is found and there is no fixed version
1387         my $action = 'Did not alter found versions';
1388         my %found_added = ();
1389         my %found_removed = ();
1390         my %fixed_removed = ();
1391         my $reopened = 0;
1392         my $old_data = dclone($data);
1393         if (not $param{add} and not $param{remove}) {
1394             $found_removed{$_} = 1 for @{$data->{found_versions}};
1395             $data->{found_versions} = [];
1396         }
1397         my %found_versions;
1398         @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1399         my %fixed_versions;
1400         @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1401         for my $version (keys %versions) {
1402             if ($param{add}) {
1403                 my @svers = @{$versions{$version}};
1404                 if (not @svers) {
1405                     @svers = $version;
1406                 }
1407                 for my $sver (@svers) {
1408                     if (not exists $found_versions{$sver}) {
1409                         $found_versions{$sver} = 1;
1410                         $found_added{$sver} = 1;
1411                     }
1412                     # if the found we are adding matches any fixed
1413                     # versions, remove them
1414                     my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
1415                     delete $fixed_versions{$_} for @temp;
1416                     $fixed_removed{$_} = 1 for @temp;
1417                 }
1418
1419                 # We only care about reopening the bug if the bug is
1420                 # not done
1421                 if (defined $data->{done} and length $data->{done}) {
1422                     my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1423                         map {m{([^/]+)$}; $1;} @svers;
1424                     # determine if we need to reopen
1425                     my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1426                         map {m{([^/]+)$}; $1;} keys %fixed_versions;
1427                     if (not @fixed_order or
1428                         (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1429                         $reopened = 1;
1430                         $data->{done} = '';
1431                     }
1432                 }
1433             }
1434             elsif ($param{remove}) {
1435                 # in the case of removal, we only concern ourself with
1436                 # the version passed, not the source version it maps
1437                 # to
1438                 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
1439                 delete $found_versions{$_} for @temp;
1440                 $found_removed{$_} = 1 for @temp;
1441             }
1442             else {
1443                 # set the keys to exactly these values
1444                 my @svers = @{$versions{$version}};
1445                 if (not @svers) {
1446                     @svers = $version;
1447                 }
1448                 for my $sver (@svers) {
1449                     if (not exists $found_versions{$sver}) {
1450                         $found_versions{$sver} = 1;
1451                         if (exists $found_removed{$sver}) {
1452                             delete $found_removed{$sver};
1453                         }
1454                         else {
1455                             $found_added{$sver} = 1;
1456                         }
1457                     }
1458                 }
1459             }
1460         }
1461
1462         $data->{found_versions} = [keys %found_versions];
1463         $data->{fixed_versions} = [keys %fixed_versions];
1464
1465         my @changed;
1466         push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1467         push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1468 #       push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1469         push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1470         $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1471         if ($reopened) {
1472             $action .= " and reopened"
1473         }
1474         if (not $reopened and not @changed) {
1475             print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"
1476                 unless __internal_request();
1477             next;
1478         }
1479         $action .= '.';
1480         append_action_to_log(bug => $data->{bug_num},
1481                              get_lock => 0,
1482                              command  => 'found',
1483                              old_data => $old_data,
1484                              new_data => $data,
1485                              __return_append_to_log_options(
1486                                                             %param,
1487                                                             action => $action,
1488                                                            ),
1489                             )
1490             if not exists $param{append_log} or $param{append_log};
1491         writebug($data->{bug_num},$data);
1492         print {$transcript} "$action\n";
1493     }
1494     __end_control(%info);
1495 }
1496
1497 =head2 set_fixed
1498
1499      eval {
1500             set_fixed(bug          => $ref,
1501                       transcript   => $transcript,
1502                       ($dl > 0 ? (debug => $transcript):()),
1503                       requester    => $header{from},
1504                       request_addr => $controlrequestaddr,
1505                       message      => \@log,
1506                       affected_packages => \%affected_packages,
1507                       recipients   => \%recipients,
1508                       fixed        => [],
1509                       add          => 1,
1510                       reopen       => 0,
1511                      );
1512         };
1513         if ($@) {
1514             $errors++;
1515             print {$transcript} "Failed to set fixed on $ref: $@";
1516         }
1517
1518
1519 Sets, adds, or removes the specified fixed versions of a package
1520
1521 If the fixed versions are empty (or end up being empty after this
1522 call) or the greatest fixed version is less than the greatest found
1523 version and the reopen option is true, the bug is reopened.
1524
1525 This function is also called by the reopen function, which causes all
1526 of the fixed versions to be cleared.
1527
1528 =cut
1529
1530 sub set_fixed {
1531     my %param = validate_with(params => \@_,
1532                               spec   => {bug => {type   => SCALAR,
1533                                                  regex  => qr/^\d+$/,
1534                                                 },
1535                                          # specific options here
1536                                          fixed    => {type => SCALAR|ARRAYREF,
1537                                                       default => [],
1538                                                      },
1539                                          add      => {type => BOOLEAN,
1540                                                       default => 0,
1541                                                      },
1542                                          remove   => {type => BOOLEAN,
1543                                                       default => 0,
1544                                                      },
1545                                          reopen   => {type => BOOLEAN,
1546                                                       default => 0,
1547                                                      },
1548                                          %common_options,
1549                                          %append_action_options,
1550                                         },
1551                              );
1552     if ($param{add} and $param{remove}) {
1553         croak "It's nonsensical to add and remove the same versions";
1554     }
1555     my %info =
1556         __begin_control(%param,
1557                         command  => 'fixed'
1558                        );
1559     my ($debug,$transcript) =
1560         @info{qw(debug transcript)};
1561     my @data = @{$info{data}};
1562     my @bugs = @{$info{bugs}};
1563     my %versions;
1564     for my $version (make_list($param{fixed})) {
1565         next unless defined $version;
1566         $versions{$version} =
1567             [make_source_versions(package => [splitpackages($data[0]{package})],
1568                                   warnings => $transcript,
1569                                   debug    => $debug,
1570                                   guess_source => 0,
1571                                   versions     => $version,
1572                                  )
1573             ];
1574         # This is really ugly, but it's what we have to do
1575         if (not @{$versions{$version}}) {
1576             print {$transcript} "Unable to make a source version for version '$version'\n";
1577         }
1578     }
1579     if (not keys %versions and ($param{remove} or $param{add})) {
1580         if ($param{remove}) {
1581             print {$transcript} "Requested to remove no versions; doing nothing.\n";
1582         }
1583         else {
1584             print {$transcript} "Requested to add no versions; doing nothing.\n";
1585         }
1586         __end_control(%info);
1587         return;
1588     }
1589     # first things first, make the versions fully qualified source
1590     # versions
1591     for my $data (@data) {
1592         my $old_data = dclone($data);
1593         # The 'done' field gets a bit weird with version tracking,
1594         # because a bug may be closed by multiple people in different
1595         # branches. Until we have something more flexible, we set it
1596         # every time a bug is fixed, and clear it when a bug is found
1597         # in a version greater than any version in which the bug is
1598         # fixed or when a bug is found and there is no fixed version
1599         my $action = 'Did not alter fixed versions';
1600         my %found_added = ();
1601         my %found_removed = ();
1602         my %fixed_added = ();
1603         my %fixed_removed = ();
1604         my $reopened = 0;
1605         if (not $param{add} and not $param{remove}) {
1606             $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1607             $data->{fixed_versions} = [];
1608         }
1609         my %found_versions;
1610         @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1611         my %fixed_versions;
1612         @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1613         for my $version (keys %versions) {
1614             if ($param{add}) {
1615                 my @svers = @{$versions{$version}};
1616                 if (not @svers) {
1617                     @svers = $version;
1618                 }
1619                 for my $sver (@svers) {
1620                     if (not exists $fixed_versions{$sver}) {
1621                         $fixed_versions{$sver} = 1;
1622                         $fixed_added{$sver} = 1;
1623                     }
1624                 }
1625             }
1626             elsif ($param{remove}) {
1627                 # in the case of removal, we only concern ourself with
1628                 # the version passed, not the source version it maps
1629                 # to
1630                 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1631                 delete $fixed_versions{$_} for @temp;
1632                 $fixed_removed{$_} = 1 for @temp;
1633             }
1634             else {
1635                 # set the keys to exactly these values
1636                 my @svers = @{$versions{$version}};
1637                 if (not @svers) {
1638                     @svers = $version;
1639                 }
1640                 for my $sver (@svers) {
1641                     if (not exists $fixed_versions{$sver}) {
1642                         $fixed_versions{$sver} = 1;
1643                         if (exists $fixed_removed{$sver}) {
1644                             delete $fixed_removed{$sver};
1645                         }
1646                         else {
1647                             $fixed_added{$sver} = 1;
1648                         }
1649                     }
1650                 }
1651             }
1652         }
1653
1654         $data->{found_versions} = [keys %found_versions];
1655         $data->{fixed_versions} = [keys %fixed_versions];
1656
1657         # If we're supposed to consider reopening, reopen if the
1658         # fixed versions are empty or the greatest found version
1659         # is greater than the greatest fixed version
1660         if ($param{reopen} and defined $data->{done}
1661             and length $data->{done}) {
1662             my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1663                 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1664             # determine if we need to reopen
1665             my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1666                     map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1667             if (not @fixed_order or
1668                 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1669                 $reopened = 1;
1670                 $data->{done} = '';
1671             }
1672         }
1673
1674         my @changed;
1675         push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1676         push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1677         push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1678         push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1679         $action = "$config{bug} ".ucfirst(join ('; ',@changed)) if @changed;
1680         if ($reopened) {
1681             $action .= " and reopened"
1682         }
1683         if (not $reopened and not @changed) {
1684             print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"
1685                 unless __internal_request();
1686             next;
1687         }
1688         $action .= '.';
1689         append_action_to_log(bug => $data->{bug_num},
1690                              command  => 'fixed',
1691                              new_data => $data,
1692                              old_data => $old_data,
1693                              get_lock => 0,
1694                              __return_append_to_log_options(
1695                                                             %param,
1696                                                             action => $action,
1697                                                            ),
1698                             )
1699             if not exists $param{append_log} or $param{append_log};
1700         writebug($data->{bug_num},$data);
1701         print {$transcript} "$action\n";
1702     }
1703     __end_control(%info);
1704 }
1705
1706
1707
1708 =head2 affects
1709
1710      eval {
1711             affects(bug          => $ref,
1712                     transcript   => $transcript,
1713                     ($dl > 0 ? (debug => $transcript):()),
1714                     requester    => $header{from},
1715                     request_addr => $controlrequestaddr,
1716                     message      => \@log,
1717                     affected_packages => \%affected_packages,
1718                     recipients   => \%recipients,
1719                     packages     => undef,
1720                     add          => 1,
1721                     remove       => 0,
1722                    );
1723         };
1724         if ($@) {
1725             $errors++;
1726             print {$transcript} "Failed to mark $ref as affecting $packages: $@";
1727         }
1728
1729 This marks a bug as affecting packages which the bug is not actually
1730 in. This should only be used in cases where fixing the bug instantly
1731 resolves the problem in the other packages.
1732
1733 By default, the packages are set to the list of packages passed.
1734 However, if you pass add => 1 or remove => 1, the list of packages
1735 passed are added or removed from the affects list, respectively.
1736
1737 =cut
1738
1739 sub affects {
1740     my %param = validate_with(params => \@_,
1741                               spec   => {bug => {type   => SCALAR,
1742                                                  regex  => qr/^\d+$/,
1743                                                 },
1744                                          # specific options here
1745                                          packages => {type => SCALAR|ARRAYREF,
1746                                                       default => [],
1747                                                      },
1748                                          add      => {type => BOOLEAN,
1749                                                       default => 0,
1750                                                      },
1751                                          remove   => {type => BOOLEAN,
1752                                                       default => 0,
1753                                                      },
1754                                          %common_options,
1755                                          %append_action_options,
1756                                         },
1757                              );
1758     if ($param{add} and $param{remove}) {
1759          croak "Asking to both add and remove affects is nonsensical";
1760     }
1761     my %info =
1762         __begin_control(%param,
1763                         command  => 'affects'
1764                        );
1765     my ($debug,$transcript) =
1766         @info{qw(debug transcript)};
1767     my @data = @{$info{data}};
1768     my @bugs = @{$info{bugs}};
1769     my $action = '';
1770     for my $data (@data) {
1771         $action = '';
1772          print {$debug} "Going to change affects\n";
1773          my @packages = splitpackages($data->{affects});
1774          my %packages;
1775          @packages{@packages} = (1) x @packages;
1776          if ($param{add}) {
1777               my @added = ();
1778               for my $package (make_list($param{packages})) {
1779                   next unless defined $package and length $package;
1780                   if (not $packages{$package}) {
1781                       $packages{$package} = 1;
1782                       push @added,$package;
1783                   }
1784               }
1785               if (@added) {
1786                    $action = "Added indication that $data->{bug_num} affects ".
1787                         english_join(\@added);
1788               }
1789          }
1790          elsif ($param{remove}) {
1791               my @removed = ();
1792               for my $package (make_list($param{packages})) {
1793                    if ($packages{$package}) {
1794                        next unless defined $package and length $package;
1795                         delete $packages{$package};
1796                         push @removed,$package;
1797                    }
1798               }
1799               $action = "Removed indication that $data->{bug_num} affects " .
1800                    english_join(\@removed);
1801          }
1802          else {
1803               my %added_packages = ();
1804               my %removed_packages = %packages;
1805               %packages = ();
1806               for my $package (make_list($param{packages})) {
1807                    next unless defined $package and length $package;
1808                    $packages{$package} = 1;
1809                    delete $removed_packages{$package};
1810                    $added_packages{$package} = 1;
1811               }
1812               if (keys %removed_packages) {
1813                   $action = "Removed indication that $data->{bug_num} affects ".
1814                       english_join([keys %removed_packages]);
1815                   $action .= "\n" if keys %added_packages;
1816               }
1817               if (keys %added_packages) {
1818                   $action .= "Added indication that $data->{bug_num} affects " .
1819                    english_join([%added_packages]);
1820               }
1821          }
1822         if (not length $action) {
1823             print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
1824                 unless __internal_request();
1825         }
1826          my $old_data = dclone($data);
1827          $data->{affects} = join(',',keys %packages);
1828          append_action_to_log(bug => $data->{bug_num},
1829                               get_lock => 0,
1830                               command => 'affects',
1831                               new_data => $data,
1832                               old_data => $old_data,
1833                               __return_append_to_log_options(
1834                                                              %param,
1835                                                              action => $action,
1836                                                             ),
1837                              )
1838                if not exists $param{append_log} or $param{append_log};
1839           writebug($data->{bug_num},$data);
1840           print {$transcript} "$action\n";
1841      }
1842     __end_control(%info);
1843 }
1844
1845
1846 =head1 SUMMARY FUNCTIONS
1847
1848 =head2 summary
1849
1850      eval {
1851             summary(bug          => $ref,
1852                     transcript   => $transcript,
1853                     ($dl > 0 ? (debug => $transcript):()),
1854                     requester    => $header{from},
1855                     request_addr => $controlrequestaddr,
1856                     message      => \@log,
1857                     affected_packages => \%affected_packages,
1858                     recipients   => \%recipients,
1859                     summary      => undef,
1860                    );
1861         };
1862         if ($@) {
1863             $errors++;
1864             print {$transcript} "Failed to mark $ref with summary foo: $@";
1865         }
1866
1867 Handles all setting of summary fields
1868
1869 If summary is undef, unsets the summary
1870
1871 If summary is 0, sets the summary to the first paragraph contained in
1872 the message passed.
1873
1874 If summary is numeric, sets the summary to the message specified.
1875
1876
1877 =cut
1878
1879
1880 sub summary {
1881     my %param = validate_with(params => \@_,
1882                               spec   => {bug => {type   => SCALAR,
1883                                                  regex  => qr/^\d+$/,
1884                                                 },
1885                                          # specific options here
1886                                          summary => {type => SCALAR|UNDEF,
1887                                                      default => 0,
1888                                                     },
1889                                          %common_options,
1890                                          %append_action_options,
1891                                         },
1892                              );
1893     croak "summary must be numeric or undef" if
1894         defined $param{summary} and not $param{summary} =~ /^\d+$/;
1895     my %info =
1896         __begin_control(%param,
1897                         command  => 'summary'
1898                        );
1899     my ($debug,$transcript) =
1900         @info{qw(debug transcript)};
1901     my @data = @{$info{data}};
1902     my @bugs = @{$info{bugs}};
1903     # figure out the log that we're going to use
1904     my $summary = '';
1905     my $summary_msg = '';
1906     my $action = '';
1907     if (not defined $param{summary}) {
1908          # do nothing
1909          print {$debug} "Removing summary fields\n";
1910          $action = 'Removed summary';
1911     }
1912     else {
1913          my $log = [];
1914          my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
1915          if ($param{summary} == 0) {
1916               $log = $param{message};
1917               $summary_msg = @records + 1;
1918          }
1919          else {
1920               if (($param{summary} - 1 ) > $#records) {
1921                    die "Message number '$param{summary}' exceeds the maximum message '$#records'";
1922               }
1923               my $record = $records[($param{summary} - 1 )];
1924               if ($record->{type} !~ /incoming-recv|recips/) {
1925                    die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
1926               }
1927               $summary_msg = $param{summary};
1928               $log = [$record->{text}];
1929          }
1930          my $p_o = Debbugs::MIME::parse(join('',@{$log}));
1931          my $body = $p_o->{body};
1932          my $in_pseudoheaders = 0;
1933          my $paragraph = '';
1934          # walk through body until we get non-blank lines
1935          for my $line (@{$body}) {
1936               if ($line =~ /^\s*$/) {
1937                    if (length $paragraph) {
1938                         if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
1939                              $paragraph = '';
1940                              next;
1941                         }
1942                         last;
1943                    }
1944                    $in_pseudoheaders = 0;
1945                    next;
1946               }
1947               # skip a paragraph if it looks like it's control or
1948               # pseudo-headers
1949               if ($line =~ m{^\s*(?:(?:Package|Source|Version)\:| #pseudo headers
1950                                  (?:package|(?:no|)owner|severity|tag|summary| #control
1951                                       reopen|close|(?:not|)(?:fixed|found)|clone|
1952                                       (?:force|)merge|user(?:category|tag|)
1953                                  )
1954                             )\s+\S}x) {
1955                    if (not length $paragraph) {
1956                         print {$debug} "Found control/pseudo-headers and skiping them\n";
1957                         $in_pseudoheaders = 1;
1958                         next;
1959                    }
1960               }
1961               next if $in_pseudoheaders;
1962               $paragraph .= $line ." \n";
1963          }
1964          print {$debug} "Summary is going to be '$paragraph'\n";
1965          $summary = $paragraph;
1966          $summary =~ s/[\n\r]/ /g;
1967          if (not length $summary) {
1968               die "Unable to find summary message to use";
1969          }
1970          # trim off a trailing spaces
1971          $summary =~ s/\ *$//;
1972     }
1973     for my $data (@data) {
1974          print {$debug} "Going to change summary\n";
1975          if (((not defined $summary or not length $summary) and
1976               (not defined $data->{summary} or not length $data->{summary})) or
1977              $summary eq $data->{summary}) {
1978              print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
1979                  unless __internal_request();
1980              next;
1981          }
1982          if (length $summary) {
1983               if (length $data->{summary}) {
1984                    $action = "Summary replaced with message bug $param{bug} message $summary_msg";
1985               }
1986               else {
1987                    $action = "Summary recorded from message bug $param{bug} message $summary_msg";
1988               }
1989          }
1990          my $old_data = dclone($data);
1991          $data->{summary} = $summary;
1992          append_action_to_log(bug => $data->{bug_num},
1993                               command => 'summary',
1994                               old_data => $old_data,
1995                               new_data => $data,
1996                               get_lock => 0,
1997                               __return_append_to_log_options(
1998                                                              %param,
1999                                                              action => $action,
2000                                                             ),
2001                              )
2002                if not exists $param{append_log} or $param{append_log};
2003           writebug($data->{bug_num},$data);
2004           print {$transcript} "$action\n";
2005      }
2006     __end_control(%info);
2007 }
2008
2009
2010
2011
2012 =head1 OWNER FUNCTIONS
2013
2014 =head2 owner
2015
2016      eval {
2017             owner(bug          => $ref,
2018                   transcript   => $transcript,
2019                   ($dl > 0 ? (debug => $transcript):()),
2020                   requester    => $header{from},
2021                   request_addr => $controlrequestaddr,
2022                   message      => \@log,
2023                   recipients   => \%recipients,
2024                   owner        => undef,
2025                  );
2026         };
2027         if ($@) {
2028             $errors++;
2029             print {$transcript} "Failed to mark $ref as having an owner: $@";
2030         }
2031
2032 Handles all setting of the owner field; given an owner of undef or of
2033 no length, indicates that a bug is not owned by anyone.
2034
2035 =cut
2036
2037 sub owner {
2038      my %param = validate_with(params => \@_,
2039                                spec   => {bug => {type   => SCALAR,
2040                                                   regex  => qr/^\d+$/,
2041                                                  },
2042                                           owner => {type => SCALAR|UNDEF,
2043                                                    },
2044                                           %common_options,
2045                                           %append_action_options,
2046                                          },
2047                               );
2048      my %info =
2049          __begin_control(%param,
2050                          command  => 'owner',
2051                         );
2052      my ($debug,$transcript) =
2053         @info{qw(debug transcript)};
2054      my @data = @{$info{data}};
2055      my @bugs = @{$info{bugs}};
2056      my $action = '';
2057      for my $data (@data) {
2058           print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2059           print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2060           if (not defined $param{owner} or not length $param{owner}) {
2061               if (not defined $data->{owner} or not length $data->{owner}) {
2062                   print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2063                       unless __internal_request();
2064                   next;
2065               }
2066               $param{owner} = '';
2067               $action = "Removed annotation that $config{bug} was owned by " .
2068                   "$data->{owner}.";
2069           }
2070           else {
2071               if ($data->{owner} eq $param{owner}) {
2072                   print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2073                   next;
2074               }
2075               if (length $data->{owner}) {
2076                   $action = "Owner changed from $data->{owner} to $param{owner}.";
2077               }
2078               else {
2079                   $action = "Owner recorded as $param{owner}."
2080               }
2081           }
2082           my $old_data = dclone($data);
2083           $data->{owner} = $param{owner};
2084           append_action_to_log(bug => $data->{bug_num},
2085                                command => 'owner',
2086                                new_data => $data,
2087                                old_data => $old_data,
2088                                get_lock => 0,
2089                __return_append_to_log_options(
2090                                               %param,
2091                                               action => $action,
2092                                              ),
2093                               )
2094                if not exists $param{append_log} or $param{append_log};
2095           writebug($data->{bug_num},$data);
2096           print {$transcript} "$action\n";
2097      }
2098      __end_control(%info);
2099 }
2100
2101
2102 =head1 ARCHIVE FUNCTIONS
2103
2104
2105 =head2 bug_archive
2106
2107      my $error = '';
2108      eval {
2109         bug_archive(bug => $bug_num,
2110                     debug => \$debug,
2111                     transcript => \$transcript,
2112                    );
2113      };
2114      if ($@) {
2115         $errors++;
2116         transcript("Unable to archive $bug_num\n");
2117         warn $@;
2118      }
2119      transcript($transcript);
2120
2121
2122 This routine archives a bug
2123
2124 =over
2125
2126 =item bug -- bug number
2127
2128 =item check_archiveable -- check wether a bug is archiveable before
2129 archiving; defaults to 1
2130
2131 =item archive_unarchived -- whether to archive bugs which have not
2132 previously been archived; defaults to 1. [Set to 0 when used from
2133 control@]
2134
2135 =item ignore_time -- whether to ignore time constraints when archiving
2136 a bug; defaults to 0.
2137
2138 =back
2139
2140 =cut
2141
2142 sub bug_archive {
2143      my %param = validate_with(params => \@_,
2144                                spec   => {bug => {type   => SCALAR,
2145                                                   regex  => qr/^\d+$/,
2146                                                  },
2147                                           check_archiveable => {type => BOOLEAN,
2148                                                                 default => 1,
2149                                                                },
2150                                           archive_unarchived => {type => BOOLEAN,
2151                                                                  default => 1,
2152                                                                 },
2153                                           ignore_time => {type => BOOLEAN,
2154                                                           default => 0,
2155                                                          },
2156                                           %common_options,
2157                                           %append_action_options,
2158                                          },
2159                               );
2160      my %info = __begin_control(%param,
2161                                 command => 'archive',
2162                                 );
2163      my ($debug,$transcript) = @info{qw(debug transcript)};
2164      my @data = @{$info{data}};
2165      my @bugs = @{$info{bugs}};
2166      my $action = "$config{bug} archived.";
2167      if ($param{check_archiveable} and
2168          not bug_archiveable(bug=>$param{bug},
2169                              ignore_time => $param{ignore_time},
2170                             )) {
2171           print {$transcript} "Bug $param{bug} cannot be archived\n";
2172           die "Bug $param{bug} cannot be archived";
2173      }
2174      print {$debug} "$param{bug} considering\n";
2175      if (not $param{archive_unarchived} and
2176          not exists $data[0]{unarchived}
2177         ) {
2178           print {$transcript} "$param{bug} has not been archived previously\n";
2179           die "$param{bug} has not been archived previously";
2180      }
2181      add_recipients(recipients => $param{recipients},
2182                     data => \@data,
2183                     debug      => $debug,
2184                     transcript => $transcript,
2185                    );
2186      print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2187      for my $bug (@bugs) {
2188          if ($param{check_archiveable}) {
2189              die "Bug $bug cannot be archived (but $param{bug} can?)"
2190                  unless bug_archiveable(bug=>$bug,
2191                                         ignore_time => $param{ignore_time},
2192                                        );
2193          }
2194      }
2195      # If we get here, we can archive/remove this bug
2196      print {$debug} "$param{bug} removing\n";
2197      for my $bug (@bugs) {
2198           #print "$param{bug} removing $bug\n" if $debug;
2199           my $dir = get_hashname($bug);
2200           # First indicate that this bug is being archived
2201           append_action_to_log(bug => $bug,
2202                                get_lock => 0,
2203                                command => 'archive',
2204                                # we didn't actually change the data
2205                                # when we archived, so we don't pass
2206                                # a real new_data or old_data
2207                                new_data => {},
2208                                old_data => {},
2209                                __return_append_to_log_options(
2210                                  %param,
2211                                  action => $action,
2212                                 )
2213                               )
2214                if not exists $param{append_log} or $param{append_log};
2215           my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
2216           if ($config{save_old_bugs}) {
2217                mkpath("$config{spool_dir}/archive/$dir");
2218                foreach my $file (@files_to_remove) {
2219                    link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2220                        copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2221                            # we need to bail out here if things have
2222                            # gone horribly wrong to avoid removing a
2223                            # bug altogether
2224                            die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
2225                }
2226
2227                print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
2228           }
2229           unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
2230           print {$transcript} "deleted $bug (from $param{bug})\n";
2231      }
2232      bughook_archive(@bugs);
2233      __end_control(%info);
2234 }
2235
2236 =head2 bug_unarchive
2237
2238      my $error = '';
2239      eval {
2240         bug_unarchive(bug => $bug_num,
2241                       debug => \$debug,
2242                       transcript => \$transcript,
2243                      );
2244      };
2245      if ($@) {
2246         $errors++;
2247         transcript("Unable to archive bug: $bug_num");
2248      }
2249      transcript($transcript);
2250
2251 This routine unarchives a bug
2252
2253 =cut
2254
2255 sub bug_unarchive {
2256      my %param = validate_with(params => \@_,
2257                                spec   => {bug => {type   => SCALAR,
2258                                                   regex  => qr/^\d+/,
2259                                                  },
2260                                           %common_options,
2261                                           %append_action_options,
2262                                          },
2263                               );
2264
2265      my %info = __begin_control(%param,
2266                                 archived=>1,
2267                                 command=>'unarchive');
2268      my ($debug,$transcript) =
2269          @info{qw(debug transcript)};
2270      my @data = @{$info{data}};
2271      my @bugs = @{$info{bugs}};
2272      my $action = "$config{bug} unarchived.";
2273      my @files_to_remove;
2274      for my $bug (@bugs) {
2275           print {$debug} "$param{bug} removing $bug\n";
2276           my $dir = get_hashname($bug);
2277           my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
2278           mkpath("archive/$dir");
2279           foreach my $file (@files_to_copy) {
2280                # die'ing here sucks
2281                link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2282                     copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2283                          die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
2284           }
2285           push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
2286           print {$transcript} "Unarchived $config{bug} $bug\n";
2287      }
2288      unlink(@files_to_remove) or die "Unable to unlink bugs";
2289      # Indicate that this bug has been archived previously
2290      for my $bug (@bugs) {
2291           my $newdata = readbug($bug);
2292           my $old_data = dclone($newdata);
2293           if (not defined $newdata) {
2294                print {$transcript} "$config{bug} $bug disappeared!\n";
2295                die "Bug $bug disappeared!";
2296           }
2297           $newdata->{unarchived} = time;
2298           append_action_to_log(bug => $bug,
2299                                get_lock => 0,
2300                                command => 'unarchive',
2301                                new_data => $newdata,
2302                                old_data => $old_data,
2303                                __return_append_to_log_options(
2304                                  %param,
2305                                  action => $action,
2306                                 )
2307                               )
2308                if not exists $param{append_log} or $param{append_log};
2309           writebug($bug,$newdata);
2310      }
2311      __end_control(%info);
2312 }
2313
2314 =head2 append_action_to_log
2315
2316      append_action_to_log
2317
2318 This should probably be moved to Debbugs::Log; have to think that out
2319 some more.
2320
2321 =cut
2322
2323 sub append_action_to_log{
2324      my %param = validate_with(params => \@_,
2325                                spec   => {bug => {type   => SCALAR,
2326                                                   regex  => qr/^\d+/,
2327                                                  },
2328                                           new_data => {type => HASHREF,
2329                                                        optional => 1,
2330                                                       },
2331                                           old_data => {type => HASHREF,
2332                                                        optional => 1,
2333                                                       },
2334                                           command  => {type => SCALAR,
2335                                                        optional => 1,
2336                                                       },
2337                                           action => {type => SCALAR,
2338                                                     },
2339                                           requester => {type => SCALAR,
2340                                                         default => '',
2341                                                        },
2342                                           request_addr => {type => SCALAR,
2343                                                            default => '',
2344                                                           },
2345                                           location => {type => SCALAR,
2346                                                        optional => 1,
2347                                                       },
2348                                           message  => {type => SCALAR|ARRAYREF,
2349                                                        default => '',
2350                                                       },
2351                                           desc       => {type => SCALAR,
2352                                                          default => '',
2353                                                         },
2354                                           get_lock   => {type => BOOLEAN,
2355                                                          default => 1,
2356                                                         },
2357                                           # we don't use
2358                                           # append_action_options here
2359                                           # because some of these
2360                                           # options aren't actually
2361                                           # optional, even though the
2362                                           # original function doesn't
2363                                           # require them
2364                                          },
2365                               );
2366      # Fix this to use $param{location}
2367      my $log_location = buglog($param{bug});
2368      die "Unable to find .log for $param{bug}"
2369           if not defined $log_location;
2370      if ($param{get_lock}) {
2371           filelock("lock/$param{bug}");
2372      }
2373      my $log = IO::File->new(">>$log_location") or
2374           die "Unable to open $log_location for appending: $!";
2375      # determine difference between old and new
2376      my $data_diff = '';
2377      if (exists $param{old_data} and exists $param{new_data}) {
2378          my $old_data = dclone($param{old_data});
2379          my $new_data = dclone($param{new_data});
2380          for my $key (keys %{$old_data}) {
2381              if (not exists $Debbugs::Status::fields{$key}) {
2382                  delete $old_data->{$key};
2383                  next;
2384              }
2385              next unless exists $new_data->{$key};
2386              next unless defined $new_data->{$key};
2387              if (not defined $old_data->{$key}) {
2388                  delete $old_data->{$key};
2389                  next;
2390              }
2391              if (ref($new_data->{$key}) and
2392                  ref($old_data->{$key}) and
2393                  ref($new_data->{$key}) eq ref($old_data->{$key})) {
2394                 local $Storable::canonical = 1;
2395                 # print STDERR Dumper($new_data,$old_data,$key);
2396                 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2397                     delete $new_data->{$key};
2398                     delete $old_data->{$key};
2399                 }
2400              }
2401              elsif ($new_data->{$key} eq $old_data->{$key}) {
2402                  delete $new_data->{$key};
2403                  delete $old_data->{$key};
2404              }
2405          }
2406          for my $key (keys %{$new_data}) {
2407              if (not exists $Debbugs::Status::fields{$key}) {
2408                  delete $new_data->{$key};
2409                  next;
2410              }
2411              next unless exists $old_data->{$key};
2412              next unless defined $old_data->{$key};
2413              if (not defined $new_data->{$key} or
2414                  not exists $Debbugs::Status::fields{$key}) {
2415                  delete $new_data->{$key};
2416                  next;
2417              }
2418              if (ref($new_data->{$key}) and
2419                  ref($old_data->{$key}) and
2420                  ref($new_data->{$key}) eq ref($old_data->{$key})) {
2421                 local $Storable::canonical = 1;
2422                 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2423                     delete $new_data->{$key};
2424                     delete $old_data->{$key};
2425                 }
2426              }
2427              elsif ($new_data->{$key} eq $old_data->{$key}) {
2428                  delete $new_data->{$key};
2429                  delete $old_data->{$key};
2430              }
2431          }
2432          $data_diff .= "<!-- new_data:\n";
2433          my %nd;
2434          for my $key (keys %{$new_data}) {
2435              if (not exists $Debbugs::Status::fields{$key}) {
2436                  warn "No such field $key";
2437                  next;
2438              }
2439              $nd{$key} = $new_data->{$key};
2440              # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
2441          }
2442          $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
2443          $data_diff .= "-->\n";
2444          $data_diff .= "<!-- old_data:\n";
2445          my %od;
2446          for my $key (keys %{$old_data}) {
2447              if (not exists $Debbugs::Status::fields{$key}) {
2448                  warn "No such field $key";
2449                  next;
2450              }
2451              $od{$key} = $old_data->{$key};
2452              # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
2453          }
2454          $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
2455          $data_diff .= "-->\n";
2456      }
2457      my $msg = join('',"\6\n",
2458                     (exists $param{command} ?
2459                      "<!-- command:".html_escape($param{command})." -->\n":""
2460                     ),
2461                     (length $param{requester} ?
2462                      "<!-- requester: ".html_escape($param{requester})." -->\n":""
2463                     ),
2464                     (length $param{request_addr} ?
2465                      "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
2466                     ),
2467                     "<!-- time:".time()." -->\n",
2468                     $data_diff,
2469                     "<strong>".html_escape($param{action})."</strong>\n");
2470      if (length $param{requester}) {
2471           $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
2472      }
2473      if (length $param{request_addr}) {
2474           $msg .= "to <code>".html_escape($param{request_addr})."</code>";
2475      }
2476      if (length $param{desc}) {
2477           $msg .= ":<br>\n$param{desc}\n";
2478      }
2479      else {
2480           $msg .= ".\n";
2481      }
2482      $msg .= "\3\n";
2483      if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
2484           $msg .= "\7\n".join('',escape_log(make_list($param{message})))."\n\3\n"
2485                or die "Unable to append to $log_location: $!";
2486      }
2487      print {$log} $msg or die "Unable to append to $log_location: $!";
2488      close $log or die "Unable to close $log_location: $!";
2489      if ($param{get_lock}) {
2490           unfilelock();
2491      }
2492
2493
2494 }
2495
2496
2497 =head1 PRIVATE FUNCTIONS
2498
2499 =head2 __handle_affected_packages
2500
2501      __handle_affected_packages(affected_packages => {},
2502                                 data => [@data],
2503                                )
2504
2505
2506
2507 =cut
2508
2509 sub __handle_affected_packages{
2510      my %param = validate_with(params => \@_,
2511                                spec   => {%common_options,
2512                                           data => {type => ARRAYREF|HASHREF
2513                                                   },
2514                                          },
2515                                allow_extra => 1,
2516                               );
2517      for my $data (make_list($param{data})) {
2518           next unless exists $data->{package} and defined $data->{package};
2519           my @packages = split /\s*,\s*/,$data->{package};
2520           @{$param{affected_packages}}{@packages} = (1) x @packages;
2521       }
2522 }
2523
2524 =head2 __handle_debug_transcript
2525
2526      my ($debug,$transcript) = __handle_debug_transcript(%param);
2527
2528 Returns a debug and transcript filehandle
2529
2530
2531 =cut
2532
2533 sub __handle_debug_transcript{
2534      my %param = validate_with(params => \@_,
2535                                spec   => {%common_options},
2536                                allow_extra => 1,
2537                               );
2538      my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
2539      my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
2540      return ($debug,$transcript);
2541 }
2542
2543 =head2 __bug_info
2544
2545      __bug_info($data)
2546
2547 Produces a small bit of bug information to kick out to the transcript
2548
2549 =cut
2550
2551 sub __bug_info{
2552      my $return = '';
2553      for my $data (@_) {
2554          next unless defined $data and exists $data->{bug_num};
2555           $return .= "Bug #".($data->{bug_num}||'').
2556               ((defined $data->{done} and length $data->{done})?
2557                 " {Done: $data->{done}}":''
2558                ).
2559                " [".($data->{package}||'(no package)'). "] ".
2560                     ($data->{subject}||'(no subject)')."\n";
2561      }
2562      return $return;
2563 }
2564
2565
2566 =head2 __internal_request
2567
2568      __internal_request()
2569      __internal_request($level)
2570
2571 Returns true if the caller of the function calling __internal_request
2572 belongs to __PACKAGE__
2573
2574 This allows us to be magical, and don't bother to print bug info if
2575 the second caller is from this package, amongst other things.
2576
2577 An optional level is allowed, which increments the number of levels to
2578 check by the given value. [This is basically for use by internal
2579 functions like __begin_control which are always called by
2580 C<__PACKAGE__>.
2581
2582 =cut
2583
2584 sub __internal_request{
2585     my ($l) = @_;
2586     $l = 0 if not defined $l;
2587     if (defined +(caller(2+$l))[0] and +(caller(2+$l))[0] eq __PACKAGE__) {
2588         return 1;
2589     }
2590     return 0;
2591 }
2592
2593 sub __return_append_to_log_options{
2594      my %param = @_;
2595      my $action = $param{action} if exists $param{action};
2596      if (not exists $param{requester}) {
2597           $param{requester} = $config{control_internal_requester};
2598      }
2599      if (not exists $param{request_addr}) {
2600           $param{request_addr} = $config{control_internal_request_addr};
2601      }
2602      if (not exists $param{message}) {
2603           my $date = rfc822_date();
2604           $param{message} = fill_in_template(template  => 'mail/fake_control_message',
2605                                              variables => {request_addr => $param{request_addr},
2606                                                            requester    => $param{requester},
2607                                                            date         => $date,
2608                                                            action       => $action
2609                                                           },
2610                                             );
2611      }
2612      if (not defined $action) {
2613           carp "Undefined action!";
2614           $action = "unknown action";
2615      }
2616      return (action => $action,
2617              (map {exists $append_action_options{$_}?($_,$param{$_}):()}
2618               keys %param),
2619             );
2620 }
2621
2622 =head2 __begin_control
2623
2624      my %info = __begin_control(%param,
2625                                 archived=>1,
2626                                 command=>'unarchive');
2627      my ($debug,$transcript) = @info{qw(debug transcript)};
2628      my @data = @{$info{data}};
2629      my @bugs = @{$info{bugs}};
2630
2631
2632 Starts the process of modifying a bug; handles all of the generic
2633 things that almost every control request needs
2634
2635 Returns a hash containing
2636
2637 =over
2638
2639 =item new_locks -- number of new locks taken out by this call
2640
2641 =item debug -- the debug file handle
2642
2643 =item transcript -- the transcript file handle
2644
2645 =item data -- an arrayref containing the data of the bugs
2646 corresponding to this request
2647
2648 =item bugs -- an arrayref containing the bug numbers of the bugs
2649 corresponding to this request
2650
2651 =back
2652
2653 =cut
2654
2655 our $locks = 0;
2656
2657 sub __begin_control {
2658     my %param = validate_with(params => \@_,
2659                               spec   => {bug => {type   => SCALAR,
2660                                                  regex  => qr/^\d+/,
2661                                                 },
2662                                          archived => {type => BOOLEAN,
2663                                                       default => 0,
2664                                                      },
2665                                          command  => {type => SCALAR,
2666                                                       optional => 1,
2667                                                      },
2668                                          %common_options,
2669                                         },
2670                               allow_extra => 1,
2671                              );
2672     my $new_locks;
2673     my ($debug,$transcript) = __handle_debug_transcript(@_);
2674     print {$debug} "$param{bug} considering\n";
2675     my @data = ();
2676     my $old_die = $SIG{__DIE__};
2677     $SIG{__DIE__} = *sig_die{CODE};
2678
2679     ($new_locks, @data) =
2680         lock_read_all_merged_bugs($param{bug},
2681                                   ($param{archived}?'archive':()));
2682     $locks += $new_locks;
2683     if (not @data) {
2684         die "Unable to read any bugs successfully.";
2685     }
2686     if (not __check_limit(data => \@data,
2687                           exists $param{limit}?(limit => $param{limit}):(),
2688                          )) {
2689         die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2690     }
2691
2692     __handle_affected_packages(%param,data => \@data);
2693     print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
2694     print {$debug} "$param{bug} read $locks locks\n";
2695     if (not @data or not defined $data[0]) {
2696         print {$transcript} "No bug found for $param{bug}\n";
2697         die "No bug found for $param{bug}";
2698     }
2699
2700     add_recipients(data => \@data,
2701                    recipients => $param{recipients},
2702                    (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2703                    debug      => $debug,
2704                    transcript => $transcript,
2705                   );
2706
2707     print {$debug} "$param{bug} read done\n";
2708     my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
2709     print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2710     return (data       => \@data,
2711             bugs       => \@bugs,
2712             old_die    => $old_die,
2713             new_locks  => $new_locks,
2714             debug      => $debug,
2715             transcript => $transcript,
2716             param      => \%param,
2717            );
2718 }
2719
2720 =head2 __end_control
2721
2722      __end_control(%info);
2723
2724 Handles tearing down from a control request
2725
2726 =cut
2727
2728 sub __end_control {
2729     my %info = @_;
2730     if (exists $info{new_locks} and $info{new_locks} > 0) {
2731         print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
2732         for (1..$info{new_locks}) {
2733             unfilelock();
2734         }
2735     }
2736     $SIG{__DIE__} = $info{old_die};
2737     if (exists $info{param}{bugs_affected}) {
2738         @{$info{param}{bugs_affected}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
2739     }
2740     add_recipients(recipients => $info{param}{recipients},
2741                    (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
2742                    data       => $info{data},
2743                    debug      => $info{debug},
2744                    transcript => $info{transcript},
2745                   );
2746     __handle_affected_packages(%{$info{param}},data=>$info{data});
2747 }
2748
2749
2750 =head2 __check_limit
2751
2752      __check_limit(data => \@data, limit => $param{limit});
2753
2754
2755 Checks to make sure that bugs match any limits; each entry of @data
2756 much satisfy the limit.
2757
2758 Returns true if there are no entries in data, or there are no keys in
2759 limit; returns false (0) if there are any entries which do not match.
2760
2761 The limit hashref elements can contain an arrayref of scalars to
2762 match; regexes are also acccepted. At least one of the entries in each
2763 element needs to match the corresponding field in all data for the
2764 limit to succeed.
2765
2766 =cut
2767
2768
2769 sub __check_limit{
2770     my %param = validate_with(params => \@_,
2771                               spec   => {data  => {type => ARRAYREF|SCALAR,
2772                                                   },
2773                                          limit => {type => HASHREF|UNDEF,
2774                                                   },
2775                                         },
2776                              );
2777     my @data = make_list($param{data});
2778     if (not @data or
2779         not defined $param{limit} or
2780         not keys %{$param{limit}}) {
2781         return 1;
2782     }
2783     for my $data (@data) {
2784         for my $field (keys %{$param{limit}}) {
2785             next unless exists $param{limit}{$field};
2786             my $match = 0;
2787             for my $limit (make_list($param{limit}{$field})) {
2788                 if (not ref $limit) {
2789                     if ($data->{$field} eq $limit) {
2790                         $match = 1;
2791                         last;
2792                     }
2793                 }
2794                 elsif (ref($limit) eq 'Regexp') {
2795                     if ($data->{$field} =~ $limit) {
2796                         $match = 1;
2797                         last;
2798                     }
2799                 }
2800                 else {
2801                     warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
2802                 }
2803             }
2804             if (not $match) {
2805                 return 0;
2806             }
2807         }
2808     }
2809     return 1;
2810 }
2811
2812
2813 =head2 die
2814
2815      sig_die "foo"
2816
2817 We override die to specially handle unlocking files in the cases where
2818 we are called via eval. [If we're not called via eval, it doesn't
2819 matter.]
2820
2821 =cut
2822
2823 sub sig_die{
2824     #if ($^S) { # in eval
2825         if ($locks) {
2826             for (1..$locks) { unfilelock(); }
2827             $locks = 0;
2828         }
2829     #}
2830 }
2831
2832
2833 # =head2 __message_body_template
2834 #
2835 #      message_body_template('mail/ack',{ref=>'foo'});
2836 #
2837 # Creates a message body using a template
2838 #
2839 # =cut
2840
2841 sub __message_body_template{
2842      my ($template,$extra_var) = @_;
2843      $extra_var ||={};
2844      my $hole_var = {'&bugurl' =>
2845                      sub{"$_[0]: ".
2846                              'http://'.$config{cgi_domain}.'/'.
2847                                  Debbugs::CGI::bug_url($_[0]);
2848                      }
2849                     };
2850
2851      my $body = fill_in_template(template => $template,
2852                                  variables => {config => \%config,
2853                                                %{$extra_var},
2854                                               },
2855                                  hole_var => $hole_var,
2856                                 );
2857      return fill_in_template(template => 'mail/message_body',
2858                              variables => {config => \%config,
2859                                            %{$extra_var},
2860                                            body => $body,
2861                                           },
2862                              hole_var => $hole_var,
2863                             );
2864 }
2865
2866
2867 1;
2868
2869 __END__