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) of '.$data->{bug_num}.': '.english_join([keys %added_blockers]) if keys %added_blockers;
 440         push @changed, 'removed blocking bug(s) of '.$data->{bug_num}.': '.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);
 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|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
1952                   $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
1953                                  \#|reopen|close|(?:not|)(?:fixed|found)|clone|
1954                                  debug|(?:not|)forwarded|priority|
1955                                  (?:un|)block|limit|(?:un|)archive|
1956                                  reassign|retitle|affects|wrongpackage
1957                                  (?:un|force|)merge|user(?:category|tags?|)
1958                              )\s+\S}xis) {
1959                    if (not length $paragraph) {
1960                         print {$debug} "Found control/pseudo-headers and skiping them\n";
1961                         $in_pseudoheaders = 1;
1962                         next;
1963                    }
1964               }
1965               next if $in_pseudoheaders;
1966               $paragraph .= $line ." \n";
1967          }
1968          print {$debug} "Summary is going to be '$paragraph'\n";
1969          $summary = $paragraph;
1970          $summary =~ s/[\n\r]/ /g;
1971          if (not length $summary) {
1972               die "Unable to find summary message to use";
1973          }
1974          # trim off a trailing spaces
1975          $summary =~ s/\ *$//;
1976     }
1977     for my $data (@data) {
1978          print {$debug} "Going to change summary\n";
1979          if (((not defined $summary or not length $summary) and
1980               (not defined $data->{summary} or not length $data->{summary})) or
1981              $summary eq $data->{summary}) {
1982              print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
1983                  unless __internal_request();
1984              next;
1985          }
1986          if (length $summary) {
1987               if (length $data->{summary}) {
1988                    $action = "Summary replaced with message bug $param{bug} message $summary_msg";
1989               }
1990               else {
1991                    $action = "Summary recorded from message bug $param{bug} message $summary_msg";
1992               }
1993          }
1994          my $old_data = dclone($data);
1995          $data->{summary} = $summary;
1996          append_action_to_log(bug => $data->{bug_num},
1997                               command => 'summary',
1998                               old_data => $old_data,
1999                               new_data => $data,
2000                               get_lock => 0,
2001                               __return_append_to_log_options(
2002                                                              %param,
2003                                                              action => $action,
2004                                                             ),
2005                              )
2006                if not exists $param{append_log} or $param{append_log};
2007           writebug($data->{bug_num},$data);
2008           print {$transcript} "$action\n";
2009      }
2010     __end_control(%info);
2011 }
2012
2013
2014
2015
2016 =head1 OWNER FUNCTIONS
2017
2018 =head2 owner
2019
2020      eval {
2021             owner(bug          => $ref,
2022                   transcript   => $transcript,
2023                   ($dl > 0 ? (debug => $transcript):()),
2024                   requester    => $header{from},
2025                   request_addr => $controlrequestaddr,
2026                   message      => \@log,
2027                   recipients   => \%recipients,
2028                   owner        => undef,
2029                  );
2030         };
2031         if ($@) {
2032             $errors++;
2033             print {$transcript} "Failed to mark $ref as having an owner: $@";
2034         }
2035
2036 Handles all setting of the owner field; given an owner of undef or of
2037 no length, indicates that a bug is not owned by anyone.
2038
2039 =cut
2040
2041 sub owner {
2042      my %param = validate_with(params => \@_,
2043                                spec   => {bug => {type   => SCALAR,
2044                                                   regex  => qr/^\d+$/,
2045                                                  },
2046                                           owner => {type => SCALAR|UNDEF,
2047                                                    },
2048                                           %common_options,
2049                                           %append_action_options,
2050                                          },
2051                               );
2052      my %info =
2053          __begin_control(%param,
2054                          command  => 'owner',
2055                         );
2056      my ($debug,$transcript) =
2057         @info{qw(debug transcript)};
2058      my @data = @{$info{data}};
2059      my @bugs = @{$info{bugs}};
2060      my $action = '';
2061      for my $data (@data) {
2062           print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2063           print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2064           if (not defined $param{owner} or not length $param{owner}) {
2065               if (not defined $data->{owner} or not length $data->{owner}) {
2066                   print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2067                       unless __internal_request();
2068                   next;
2069               }
2070               $param{owner} = '';
2071               $action = "Removed annotation that $config{bug} was owned by " .
2072                   "$data->{owner}.";
2073           }
2074           else {
2075               if ($data->{owner} eq $param{owner}) {
2076                   print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2077                   next;
2078               }
2079               if (length $data->{owner}) {
2080                   $action = "Owner changed from $data->{owner} to $param{owner}.";
2081               }
2082               else {
2083                   $action = "Owner recorded as $param{owner}."
2084               }
2085           }
2086           my $old_data = dclone($data);
2087           $data->{owner} = $param{owner};
2088           append_action_to_log(bug => $data->{bug_num},
2089                                command => 'owner',
2090                                new_data => $data,
2091                                old_data => $old_data,
2092                                get_lock => 0,
2093                __return_append_to_log_options(
2094                                               %param,
2095                                               action => $action,
2096                                              ),
2097                               )
2098                if not exists $param{append_log} or $param{append_log};
2099           writebug($data->{bug_num},$data);
2100           print {$transcript} "$action\n";
2101      }
2102      __end_control(%info);
2103 }
2104
2105
2106 =head1 ARCHIVE FUNCTIONS
2107
2108
2109 =head2 bug_archive
2110
2111      my $error = '';
2112      eval {
2113         bug_archive(bug => $bug_num,
2114                     debug => \$debug,
2115                     transcript => \$transcript,
2116                    );
2117      };
2118      if ($@) {
2119         $errors++;
2120         transcript("Unable to archive $bug_num\n");
2121         warn $@;
2122      }
2123      transcript($transcript);
2124
2125
2126 This routine archives a bug
2127
2128 =over
2129
2130 =item bug -- bug number
2131
2132 =item check_archiveable -- check wether a bug is archiveable before
2133 archiving; defaults to 1
2134
2135 =item archive_unarchived -- whether to archive bugs which have not
2136 previously been archived; defaults to 1. [Set to 0 when used from
2137 control@]
2138
2139 =item ignore_time -- whether to ignore time constraints when archiving
2140 a bug; defaults to 0.
2141
2142 =back
2143
2144 =cut
2145
2146 sub bug_archive {
2147      my %param = validate_with(params => \@_,
2148                                spec   => {bug => {type   => SCALAR,
2149                                                   regex  => qr/^\d+$/,
2150                                                  },
2151                                           check_archiveable => {type => BOOLEAN,
2152                                                                 default => 1,
2153                                                                },
2154                                           archive_unarchived => {type => BOOLEAN,
2155                                                                  default => 1,
2156                                                                 },
2157                                           ignore_time => {type => BOOLEAN,
2158                                                           default => 0,
2159                                                          },
2160                                           %common_options,
2161                                           %append_action_options,
2162                                          },
2163                               );
2164      my %info = __begin_control(%param,
2165                                 command => 'archive',
2166                                 );
2167      my ($debug,$transcript) = @info{qw(debug transcript)};
2168      my @data = @{$info{data}};
2169      my @bugs = @{$info{bugs}};
2170      my $action = "$config{bug} archived.";
2171      if ($param{check_archiveable} and
2172          not bug_archiveable(bug=>$param{bug},
2173                              ignore_time => $param{ignore_time},
2174                             )) {
2175           print {$transcript} "Bug $param{bug} cannot be archived\n";
2176           die "Bug $param{bug} cannot be archived";
2177      }
2178      print {$debug} "$param{bug} considering\n";
2179      if (not $param{archive_unarchived} and
2180          not exists $data[0]{unarchived}
2181         ) {
2182           print {$transcript} "$param{bug} has not been archived previously\n";
2183           die "$param{bug} has not been archived previously";
2184      }
2185      add_recipients(recipients => $param{recipients},
2186                     data => \@data,
2187                     debug      => $debug,
2188                     transcript => $transcript,
2189                    );
2190      print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2191      for my $bug (@bugs) {
2192          if ($param{check_archiveable}) {
2193              die "Bug $bug cannot be archived (but $param{bug} can?)"
2194                  unless bug_archiveable(bug=>$bug,
2195                                         ignore_time => $param{ignore_time},
2196                                        );
2197          }
2198      }
2199      # If we get here, we can archive/remove this bug
2200      print {$debug} "$param{bug} removing\n";
2201      for my $bug (@bugs) {
2202           #print "$param{bug} removing $bug\n" if $debug;
2203           my $dir = get_hashname($bug);
2204           # First indicate that this bug is being archived
2205           append_action_to_log(bug => $bug,
2206                                get_lock => 0,
2207                                command => 'archive',
2208                                # we didn't actually change the data
2209                                # when we archived, so we don't pass
2210                                # a real new_data or old_data
2211                                new_data => {},
2212                                old_data => {},
2213                                __return_append_to_log_options(
2214                                  %param,
2215                                  action => $action,
2216                                 )
2217                               )
2218                if not exists $param{append_log} or $param{append_log};
2219           my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
2220           if ($config{save_old_bugs}) {
2221                mkpath("$config{spool_dir}/archive/$dir");
2222                foreach my $file (@files_to_remove) {
2223                    link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2224                        copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2225                            # we need to bail out here if things have
2226                            # gone horribly wrong to avoid removing a
2227                            # bug altogether
2228                            die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
2229                }
2230
2231                print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
2232           }
2233           unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
2234           print {$transcript} "deleted $bug (from $param{bug})\n";
2235      }
2236      bughook_archive(@bugs);
2237      __end_control(%info);
2238 }
2239
2240 =head2 bug_unarchive
2241
2242      my $error = '';
2243      eval {
2244         bug_unarchive(bug => $bug_num,
2245                       debug => \$debug,
2246                       transcript => \$transcript,
2247                      );
2248      };
2249      if ($@) {
2250         $errors++;
2251         transcript("Unable to archive bug: $bug_num");
2252      }
2253      transcript($transcript);
2254
2255 This routine unarchives a bug
2256
2257 =cut
2258
2259 sub bug_unarchive {
2260      my %param = validate_with(params => \@_,
2261                                spec   => {bug => {type   => SCALAR,
2262                                                   regex  => qr/^\d+/,
2263                                                  },
2264                                           %common_options,
2265                                           %append_action_options,
2266                                          },
2267                               );
2268
2269      my %info = __begin_control(%param,
2270                                 archived=>1,
2271                                 command=>'unarchive');
2272      my ($debug,$transcript) =
2273          @info{qw(debug transcript)};
2274      my @data = @{$info{data}};
2275      my @bugs = @{$info{bugs}};
2276      my $action = "$config{bug} unarchived.";
2277      my @files_to_remove;
2278      for my $bug (@bugs) {
2279           print {$debug} "$param{bug} removing $bug\n";
2280           my $dir = get_hashname($bug);
2281           my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
2282           mkpath("archive/$dir");
2283           foreach my $file (@files_to_copy) {
2284                # die'ing here sucks
2285                link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2286                     copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
2287                          die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
2288           }
2289           push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
2290           print {$transcript} "Unarchived $config{bug} $bug\n";
2291      }
2292      unlink(@files_to_remove) or die "Unable to unlink bugs";
2293      # Indicate that this bug has been archived previously
2294      for my $bug (@bugs) {
2295           my $newdata = readbug($bug);
2296           my $old_data = dclone($newdata);
2297           if (not defined $newdata) {
2298                print {$transcript} "$config{bug} $bug disappeared!\n";
2299                die "Bug $bug disappeared!";
2300           }
2301           $newdata->{unarchived} = time;
2302           append_action_to_log(bug => $bug,
2303                                get_lock => 0,
2304                                command => 'unarchive',
2305                                new_data => $newdata,
2306                                old_data => $old_data,
2307                                __return_append_to_log_options(
2308                                  %param,
2309                                  action => $action,
2310                                 )
2311                               )
2312                if not exists $param{append_log} or $param{append_log};
2313           writebug($bug,$newdata);
2314      }
2315      __end_control(%info);
2316 }
2317
2318 =head2 append_action_to_log
2319
2320      append_action_to_log
2321
2322 This should probably be moved to Debbugs::Log; have to think that out
2323 some more.
2324
2325 =cut
2326
2327 sub append_action_to_log{
2328      my %param = validate_with(params => \@_,
2329                                spec   => {bug => {type   => SCALAR,
2330                                                   regex  => qr/^\d+/,
2331                                                  },
2332                                           new_data => {type => HASHREF,
2333                                                        optional => 1,
2334                                                       },
2335                                           old_data => {type => HASHREF,
2336                                                        optional => 1,
2337                                                       },
2338                                           command  => {type => SCALAR,
2339                                                        optional => 1,
2340                                                       },
2341                                           action => {type => SCALAR,
2342                                                     },
2343                                           requester => {type => SCALAR,
2344                                                         default => '',
2345                                                        },
2346                                           request_addr => {type => SCALAR,
2347                                                            default => '',
2348                                                           },
2349                                           location => {type => SCALAR,
2350                                                        optional => 1,
2351                                                       },
2352                                           message  => {type => SCALAR|ARRAYREF,
2353                                                        default => '',
2354                                                       },
2355                                           desc       => {type => SCALAR,
2356                                                          default => '',
2357                                                         },
2358                                           get_lock   => {type => BOOLEAN,
2359                                                          default => 1,
2360                                                         },
2361                                           # we don't use
2362                                           # append_action_options here
2363                                           # because some of these
2364                                           # options aren't actually
2365                                           # optional, even though the
2366                                           # original function doesn't
2367                                           # require them
2368                                          },
2369                               );
2370      # Fix this to use $param{location}
2371      my $log_location = buglog($param{bug});
2372      die "Unable to find .log for $param{bug}"
2373           if not defined $log_location;
2374      if ($param{get_lock}) {
2375           filelock("lock/$param{bug}");
2376      }
2377      my $log = IO::File->new(">>$log_location") or
2378           die "Unable to open $log_location for appending: $!";
2379      # determine difference between old and new
2380      my $data_diff = '';
2381      if (exists $param{old_data} and exists $param{new_data}) {
2382          my $old_data = dclone($param{old_data});
2383          my $new_data = dclone($param{new_data});
2384          for my $key (keys %{$old_data}) {
2385              if (not exists $Debbugs::Status::fields{$key}) {
2386                  delete $old_data->{$key};
2387                  next;
2388              }
2389              next unless exists $new_data->{$key};
2390              next unless defined $new_data->{$key};
2391              if (not defined $old_data->{$key}) {
2392                  delete $old_data->{$key};
2393                  next;
2394              }
2395              if (ref($new_data->{$key}) and
2396                  ref($old_data->{$key}) and
2397                  ref($new_data->{$key}) eq ref($old_data->{$key})) {
2398                 local $Storable::canonical = 1;
2399                 # print STDERR Dumper($new_data,$old_data,$key);
2400                 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2401                     delete $new_data->{$key};
2402                     delete $old_data->{$key};
2403                 }
2404              }
2405              elsif ($new_data->{$key} eq $old_data->{$key}) {
2406                  delete $new_data->{$key};
2407                  delete $old_data->{$key};
2408              }
2409          }
2410          for my $key (keys %{$new_data}) {
2411              if (not exists $Debbugs::Status::fields{$key}) {
2412                  delete $new_data->{$key};
2413                  next;
2414              }
2415              next unless exists $old_data->{$key};
2416              next unless defined $old_data->{$key};
2417              if (not defined $new_data->{$key} or
2418                  not exists $Debbugs::Status::fields{$key}) {
2419                  delete $new_data->{$key};
2420                  next;
2421              }
2422              if (ref($new_data->{$key}) and
2423                  ref($old_data->{$key}) and
2424                  ref($new_data->{$key}) eq ref($old_data->{$key})) {
2425                 local $Storable::canonical = 1;
2426                 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
2427                     delete $new_data->{$key};
2428                     delete $old_data->{$key};
2429                 }
2430              }
2431              elsif ($new_data->{$key} eq $old_data->{$key}) {
2432                  delete $new_data->{$key};
2433                  delete $old_data->{$key};
2434              }
2435          }
2436          $data_diff .= "<!-- new_data:\n";
2437          my %nd;
2438          for my $key (keys %{$new_data}) {
2439              if (not exists $Debbugs::Status::fields{$key}) {
2440                  warn "No such field $key";
2441                  next;
2442              }
2443              $nd{$key} = $new_data->{$key};
2444              # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
2445          }
2446          $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
2447          $data_diff .= "-->\n";
2448          $data_diff .= "<!-- old_data:\n";
2449          my %od;
2450          for my $key (keys %{$old_data}) {
2451              if (not exists $Debbugs::Status::fields{$key}) {
2452                  warn "No such field $key";
2453                  next;
2454              }
2455              $od{$key} = $old_data->{$key};
2456              # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
2457          }
2458          $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
2459          $data_diff .= "-->\n";
2460      }
2461      my $msg = join('',"\6\n",
2462                     (exists $param{command} ?
2463                      "<!-- command:".html_escape($param{command})." -->\n":""
2464                     ),
2465                     (length $param{requester} ?
2466                      "<!-- requester: ".html_escape($param{requester})." -->\n":""
2467                     ),
2468                     (length $param{request_addr} ?
2469                      "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
2470                     ),
2471                     "<!-- time:".time()." -->\n",
2472                     $data_diff,
2473                     "<strong>".html_escape($param{action})."</strong>\n");
2474      if (length $param{requester}) {
2475           $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
2476      }
2477      if (length $param{request_addr}) {
2478           $msg .= "to <code>".html_escape($param{request_addr})."</code>";
2479      }
2480      if (length $param{desc}) {
2481           $msg .= ":<br>\n$param{desc}\n";
2482      }
2483      else {
2484           $msg .= ".\n";
2485      }
2486      $msg .= "\3\n";
2487      if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
2488           $msg .= "\7\n".join('',escape_log(make_list($param{message})))."\n\3\n"
2489                or die "Unable to append to $log_location: $!";
2490      }
2491      print {$log} $msg or die "Unable to append to $log_location: $!";
2492      close $log or die "Unable to close $log_location: $!";
2493      if ($param{get_lock}) {
2494           unfilelock();
2495      }
2496
2497
2498 }
2499
2500
2501 =head1 PRIVATE FUNCTIONS
2502
2503 =head2 __handle_affected_packages
2504
2505      __handle_affected_packages(affected_packages => {},
2506                                 data => [@data],
2507                                )
2508
2509
2510
2511 =cut
2512
2513 sub __handle_affected_packages{
2514      my %param = validate_with(params => \@_,
2515                                spec   => {%common_options,
2516                                           data => {type => ARRAYREF|HASHREF
2517                                                   },
2518                                          },
2519                                allow_extra => 1,
2520                               );
2521      for my $data (make_list($param{data})) {
2522           next unless exists $data->{package} and defined $data->{package};
2523           my @packages = split /\s*,\s*/,$data->{package};
2524           @{$param{affected_packages}}{@packages} = (1) x @packages;
2525       }
2526 }
2527
2528 =head2 __handle_debug_transcript
2529
2530      my ($debug,$transcript) = __handle_debug_transcript(%param);
2531
2532 Returns a debug and transcript filehandle
2533
2534
2535 =cut
2536
2537 sub __handle_debug_transcript{
2538      my %param = validate_with(params => \@_,
2539                                spec   => {%common_options},
2540                                allow_extra => 1,
2541                               );
2542      my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
2543      my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
2544      return ($debug,$transcript);
2545 }
2546
2547 =head2 __bug_info
2548
2549      __bug_info($data)
2550
2551 Produces a small bit of bug information to kick out to the transcript
2552
2553 =cut
2554
2555 sub __bug_info{
2556      my $return = '';
2557      for my $data (@_) {
2558          next unless defined $data and exists $data->{bug_num};
2559           $return .= "Bug #".($data->{bug_num}||'').
2560               ((defined $data->{done} and length $data->{done})?
2561                 " {Done: $data->{done}}":''
2562                ).
2563                " [".($data->{package}||'(no package)'). "] ".
2564                     ($data->{subject}||'(no subject)')."\n";
2565      }
2566      return $return;
2567 }
2568
2569
2570 =head2 __internal_request
2571
2572      __internal_request()
2573      __internal_request($level)
2574
2575 Returns true if the caller of the function calling __internal_request
2576 belongs to __PACKAGE__
2577
2578 This allows us to be magical, and don't bother to print bug info if
2579 the second caller is from this package, amongst other things.
2580
2581 An optional level is allowed, which increments the number of levels to
2582 check by the given value. [This is basically for use by internal
2583 functions like __begin_control which are always called by
2584 C<__PACKAGE__>.
2585
2586 =cut
2587
2588 sub __internal_request{
2589     my ($l) = @_;
2590     $l = 0 if not defined $l;
2591     if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
2592         return 1;
2593     }
2594     return 0;
2595 }
2596
2597 sub __return_append_to_log_options{
2598      my %param = @_;
2599      my $action = $param{action} if exists $param{action};
2600      if (not exists $param{requester}) {
2601           $param{requester} = $config{control_internal_requester};
2602      }
2603      if (not exists $param{request_addr}) {
2604           $param{request_addr} = $config{control_internal_request_addr};
2605      }
2606      if (not exists $param{message}) {
2607           my $date = rfc822_date();
2608           $param{message} = fill_in_template(template  => 'mail/fake_control_message',
2609                                              variables => {request_addr => $param{request_addr},
2610                                                            requester    => $param{requester},
2611                                                            date         => $date,
2612                                                            action       => $action
2613                                                           },
2614                                             );
2615      }
2616      if (not defined $action) {
2617           carp "Undefined action!";
2618           $action = "unknown action";
2619      }
2620      return (action => $action,
2621              (map {exists $append_action_options{$_}?($_,$param{$_}):()}
2622               keys %param),
2623             );
2624 }
2625
2626 =head2 __begin_control
2627
2628      my %info = __begin_control(%param,
2629                                 archived=>1,
2630                                 command=>'unarchive');
2631      my ($debug,$transcript) = @info{qw(debug transcript)};
2632      my @data = @{$info{data}};
2633      my @bugs = @{$info{bugs}};
2634
2635
2636 Starts the process of modifying a bug; handles all of the generic
2637 things that almost every control request needs
2638
2639 Returns a hash containing
2640
2641 =over
2642
2643 =item new_locks -- number of new locks taken out by this call
2644
2645 =item debug -- the debug file handle
2646
2647 =item transcript -- the transcript file handle
2648
2649 =item data -- an arrayref containing the data of the bugs
2650 corresponding to this request
2651
2652 =item bugs -- an arrayref containing the bug numbers of the bugs
2653 corresponding to this request
2654
2655 =back
2656
2657 =cut
2658
2659 our $locks = 0;
2660
2661 sub __begin_control {
2662     my %param = validate_with(params => \@_,
2663                               spec   => {bug => {type   => SCALAR,
2664                                                  regex  => qr/^\d+/,
2665                                                 },
2666                                          archived => {type => BOOLEAN,
2667                                                       default => 0,
2668                                                      },
2669                                          command  => {type => SCALAR,
2670                                                       optional => 1,
2671                                                      },
2672                                          %common_options,
2673                                         },
2674                               allow_extra => 1,
2675                              );
2676     my $new_locks;
2677     my ($debug,$transcript) = __handle_debug_transcript(@_);
2678     print {$debug} "$param{bug} considering\n";
2679     my @data = ();
2680     my $old_die = $SIG{__DIE__};
2681     $SIG{__DIE__} = *sig_die{CODE};
2682
2683     ($new_locks, @data) =
2684         lock_read_all_merged_bugs($param{bug},
2685                                   ($param{archived}?'archive':()));
2686     $locks += $new_locks;
2687     if (not @data) {
2688         die "Unable to read any bugs successfully.";
2689     }
2690     if (not $param{archived}) {
2691         for my $data (@data) {
2692             if ($data->{archived}) {
2693                 die "Not altering archived bugs; see unarchive.";
2694             }
2695         }
2696     }
2697     if (not __check_limit(data => \@data,
2698                           exists $param{limit}?(limit => $param{limit}):(),
2699                          )) {
2700         die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2701     }
2702
2703     __handle_affected_packages(%param,data => \@data);
2704     print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
2705     print {$debug} "$param{bug} read $locks locks\n";
2706     if (not @data or not defined $data[0]) {
2707         print {$transcript} "No bug found for $param{bug}\n";
2708         die "No bug found for $param{bug}";
2709     }
2710
2711     add_recipients(data => \@data,
2712                    recipients => $param{recipients},
2713                    (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2714                    debug      => $debug,
2715                    (__internal_request()?(transcript => $transcript):()),
2716                   );
2717
2718     print {$debug} "$param{bug} read done\n";
2719     my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
2720     print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2721     return (data       => \@data,
2722             bugs       => \@bugs,
2723             old_die    => $old_die,
2724             new_locks  => $new_locks,
2725             debug      => $debug,
2726             transcript => $transcript,
2727             param      => \%param,
2728            );
2729 }
2730
2731 =head2 __end_control
2732
2733      __end_control(%info);
2734
2735 Handles tearing down from a control request
2736
2737 =cut
2738
2739 sub __end_control {
2740     my %info = @_;
2741     if (exists $info{new_locks} and $info{new_locks} > 0) {
2742         print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
2743         for (1..$info{new_locks}) {
2744             unfilelock();
2745         }
2746     }
2747     $SIG{__DIE__} = $info{old_die};
2748     if (exists $info{param}{bugs_affected}) {
2749         @{$info{param}{bugs_affected}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
2750     }
2751     add_recipients(recipients => $info{param}{recipients},
2752                    (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
2753                    data       => $info{data},
2754                    debug      => $info{debug},
2755                    transcript => $info{transcript},
2756                   );
2757     __handle_affected_packages(%{$info{param}},data=>$info{data});
2758 }
2759
2760
2761 =head2 __check_limit
2762
2763      __check_limit(data => \@data, limit => $param{limit});
2764
2765
2766 Checks to make sure that bugs match any limits; each entry of @data
2767 much satisfy the limit.
2768
2769 Returns true if there are no entries in data, or there are no keys in
2770 limit; returns false (0) if there are any entries which do not match.
2771
2772 The limit hashref elements can contain an arrayref of scalars to
2773 match; regexes are also acccepted. At least one of the entries in each
2774 element needs to match the corresponding field in all data for the
2775 limit to succeed.
2776
2777 =cut
2778
2779
2780 sub __check_limit{
2781     my %param = validate_with(params => \@_,
2782                               spec   => {data  => {type => ARRAYREF|SCALAR,
2783                                                   },
2784                                          limit => {type => HASHREF|UNDEF,
2785                                                   },
2786                                         },
2787                              );
2788     my @data = make_list($param{data});
2789     if (not @data or
2790         not defined $param{limit} or
2791         not keys %{$param{limit}}) {
2792         return 1;
2793     }
2794     for my $data (@data) {
2795         for my $field (keys %{$param{limit}}) {
2796             next unless exists $param{limit}{$field};
2797             my $match = 0;
2798             for my $limit (make_list($param{limit}{$field})) {
2799                 if (not ref $limit) {
2800                     if ($data->{$field} eq $limit) {
2801                         $match = 1;
2802                         last;
2803                     }
2804                 }
2805                 elsif (ref($limit) eq 'Regexp') {
2806                     if ($data->{$field} =~ $limit) {
2807                         $match = 1;
2808                         last;
2809                     }
2810                 }
2811                 else {
2812                     warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
2813                 }
2814             }
2815             if (not $match) {
2816                 return 0;
2817             }
2818         }
2819     }
2820     return 1;
2821 }
2822
2823
2824 =head2 die
2825
2826      sig_die "foo"
2827
2828 We override die to specially handle unlocking files in the cases where
2829 we are called via eval. [If we're not called via eval, it doesn't
2830 matter.]
2831
2832 =cut
2833
2834 sub sig_die{
2835     #if ($^S) { # in eval
2836         if ($locks) {
2837             for (1..$locks) { unfilelock(); }
2838             $locks = 0;
2839         }
2840     #}
2841 }
2842
2843
2844 # =head2 __message_body_template
2845 #
2846 #      message_body_template('mail/ack',{ref=>'foo'});
2847 #
2848 # Creates a message body using a template
2849 #
2850 # =cut
2851
2852 sub __message_body_template{
2853      my ($template,$extra_var) = @_;
2854      $extra_var ||={};
2855      my $hole_var = {'&bugurl' =>
2856                      sub{"$_[0]: ".
2857                              'http://'.$config{cgi_domain}.'/'.
2858                                  Debbugs::CGI::bug_url($_[0]);
2859                      }
2860                     };
2861
2862      my $body = fill_in_template(template => $template,
2863                                  variables => {config => \%config,
2864                                                %{$extra_var},
2865                                               },
2866                                  hole_var => $hole_var,
2867                                 );
2868      return fill_in_template(template => 'mail/message_body',
2869                              variables => {config => \%config,
2870                                            %{$extra_var},
2871                                            body => $body,
2872                                           },
2873                              hole_var => $hole_var,
2874                             );
2875 }
2876
2877
2878 1;
2879
2880 __END__