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