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