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 = (done    => [qw(set_done)],
  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                      merge   => [qw(set_merged)],
  98                      tag     => [qw(set_tag)],
  99                      archive => [qw(bug_archive bug_unarchive),
 100                                 ],
 101                      log     => [qw(append_action_to_log),
 102                                 ],
 103                     );
 104      @EXPORT_OK = ();
 105      Exporter::export_ok_tags(keys %EXPORT_TAGS);
 106      $EXPORT_TAGS{all} = [@EXPORT_OK];
 107 }
 108
 109 use Debbugs::Config qw(:config);
 110 use Debbugs::Common qw(:lock buglog :misc get_hashname sort_versions);
 111 use Debbugs::Status qw(bug_archiveable :read :hook writebug splitpackages split_status_fields get_bug_status);
 112 use Debbugs::CGI qw(html_escape);
 113 use Debbugs::Log qw(:misc :write);
 114 use Debbugs::Recipients qw(:add);
 115 use Debbugs::Packages qw(:versions :mapping);
 116
 117 use Data::Dumper qw();
 118 use Params::Validate qw(validate_with :types);
 119 use File::Path qw(mkpath);
 120 use IO::File;
 121
 122 use Debbugs::Text qw(:templates);
 123
 124 use Debbugs::Mail qw(rfc822_date send_mail_message default_headers);
 125 use Debbugs::MIME qw(create_mime_message);
 126
 127 use Mail::RFC822::Address qw();
 128
 129 use POSIX qw(strftime);
 130
 131 use Storable qw(dclone nfreeze);
 132 use List::Util qw(first max);
 133
 134 use Carp;
 135
 136 # These are a set of options which are common to all of these functions
 137
 138 my %common_options = (debug       => {type => SCALARREF|HANDLE,
 139                                       optional => 1,
 140                                      },
 141                       transcript  => {type => SCALARREF|HANDLE,
 142                                       optional => 1,
 143                                      },
 144                       affected_bugs => {type => HASHREF,
 145                                         optional => 1,
 146                                        },
 147                       affected_packages => {type => HASHREF,
 148                                             optional => 1,
 149                                            },
 150                       recipients    => {type => HASHREF,
 151                                         default => {},
 152                                        },
 153                       limit         => {type => HASHREF,
 154                                         default => {},
 155                                        },
 156                       show_bug_info => {type => BOOLEAN,
 157                                         default => 1,
 158                                        },
 159                       request_subject => {type => SCALAR,
 160                                           default => 'Unknown Subject',
 161                                          },
 162                       request_msgid    => {type => SCALAR,
 163                                            default => '',
 164                                           },
 165                       request_nn       => {type => SCALAR,
 166                                            optional => 1,
 167                                           },
 168                       request_replyto   => {type => SCALAR,
 169                                             optional => 1,
 170                                            },
 171                       locks             => {type => HASHREF,
 172                                             optional => 1,
 173                                            },
 174                      );
 175
 176
 177 my %append_action_options =
 178      (action => {type => SCALAR,
 179                  optional => 1,
 180                 },
 181       requester => {type => SCALAR,
 182                     optional => 1,
 183                    },
 184       request_addr => {type => SCALAR,
 185                        optional => 1,
 186                       },
 187       location => {type => SCALAR,
 188                    optional => 1,
 189                   },
 190       message  => {type => SCALAR|ARRAYREF,
 191                    optional => 1,
 192                   },
 193       append_log => {type => BOOLEAN,
 194                      optional => 1,
 195                      depends => [qw(requester request_addr),
 196                                  qw(message),
 197                                 ],
 198                     },
 199       # locks is both an append_action option, and a common option;
 200       # it's ok for it to be in both places.
 201       locks     => {type => HASHREF,
 202                     optional => 1,
 203                    },
 204      );
 205
 206 our $locks = 0;
 207
 208
 209 # this is just a generic stub for Debbugs::Control functions.
 210 #
 211 # =head2 set_foo
 212 #
 213 #      eval {
 214 #           set_foo(bug          => $ref,
 215 #                   transcript   => $transcript,
 216 #                   ($dl > 0 ? (debug => $transcript):()),
 217 #                   requester    => $header{from},
 218 #                   request_addr => $controlrequestaddr,
 219 #                   message      => \@log,
 220 #                   affected_packages => \%affected_packages,
 221 #                   recipients   => \%recipients,
 222 #                   summary      => undef,
 223 #                  );
 224 #       };
 225 #       if ($@) {
 226 #           $errors++;
 227 #           print {$transcript} "Failed to set foo $ref bar: $@";
 228 #       }
 229 #
 230 # Foo frobinates
 231 #
 232 # =cut
 233 #
 234 # sub set_foo {
 235 #     my %param = validate_with(params => \@_,
 236 #                             spec   => {bug => {type   => SCALAR,
 237 #                                                regex  => qr/^\d+$/,
 238 #                                               },
 239 #                                        # specific options here
 240 #                                        %common_options,
 241 #                                        %append_action_options,
 242 #                                       },
 243 #                            );
 244 #     my %info =
 245 #       __begin_control(%param,
 246 #                       command  => 'foo'
 247 #                      );
 248 #     my ($debug,$transcript) =
 249 #       @info{qw(debug transcript)};
 250 #     my @data = @{$info{data}};
 251 #     my @bugs = @{$info{bugs}};
 252 #
 253 #     my $action = '';
 254 #     for my $data (@data) {
 255 #       append_action_to_log(bug => $data->{bug_num},
 256 #                            get_lock => 0,
 257 #                            __return_append_to_log_options(
 258 #                                                           %param,
 259 #                                                           action => $action,
 260 #                                                          ),
 261 #                           )
 262 #           if not exists $param{append_log} or $param{append_log};
 263 #       writebug($data->{bug_num},$data);
 264 #       print {$transcript} "$action\n";
 265 #     }
 266 #     __end_control(%info);
 267 # }
 268
 269
 270 =head2 set_blocks
 271
 272      eval {
 273             set_block(bug          => $ref,
 274                       transcript   => $transcript,
 275                       ($dl > 0 ? (debug => $transcript):()),
 276                       requester    => $header{from},
 277                       request_addr => $controlrequestaddr,
 278                       message      => \@log,
 279                       affected_packages => \%affected_packages,
 280                       recipients   => \%recipients,
 281                       block        => [],
 282                      );
 283         };
 284         if ($@) {
 285             $errors++;
 286             print {$transcript} "Failed to set blockers of $ref: $@";
 287         }
 288
 289 Alters the set of bugs that block this bug from being fixed
 290
 291 This requires altering both this bug (and those it's merged with) as
 292 well as the bugs that block this bug from being fixed (and those that
 293 it's merged with)
 294
 295 =over
 296
 297 =item block -- scalar or arrayref of blocking bugs to set, add or remove
 298
 299 =item add -- if true, add blocking bugs
 300
 301 =item remove -- if true, remove blocking bugs
 302
 303 =back
 304
 305 =cut
 306
 307 sub set_blocks {
 308     my %param = validate_with(params => \@_,
 309                               spec   => {bug => {type   => SCALAR,
 310                                                  regex  => qr/^\d+$/,
 311                                                 },
 312                                          # specific options here
 313                                          block => {type => SCALAR|ARRAYREF,
 314                                                    default => [],
 315                                                   },
 316                                          add    => {type => BOOLEAN,
 317                                                     default => 0,
 318                                                    },
 319                                          remove => {type => BOOLEAN,
 320                                                     default => 0,
 321                                                    },
 322                                          %common_options,
 323                                          %append_action_options,
 324                                         },
 325                              );
 326     if ($param{add} and $param{remove}) {
 327         croak "It's nonsensical to add and remove the same blocking bugs";
 328     }
 329     if (grep {$_ !~ /^\d+$/} make_list($param{block})) {
 330         croak "Invalid blocking bug(s):".
 331             join(', ',grep {$_ !~ /^\d+$/} make_list($param{block}));
 332     }
 333     my $mode = 'set';
 334     if ($param{add}) {
 335         $mode = 'add';
 336     }
 337     elsif ($param{remove}) {
 338         $mode = 'remove';
 339     }
 340
 341     my %info =
 342         __begin_control(%param,
 343                         command  => 'blocks'
 344                        );
 345     my ($debug,$transcript) =
 346         @info{qw(debug transcript)};
 347     my @data = @{$info{data}};
 348     my @bugs = @{$info{bugs}};
 349
 350
 351     # The first bit of this code is ugly, and should be cleaned up.
 352     # Its purpose is to populate %removed_blockers and %add_blockers
 353     # with all of the bugs that should be added or removed as blockers
 354     # of all of the bugs which are merged with $param{bug}
 355     my %ok_blockers;
 356     my %bad_blockers;
 357     for my $blocker (make_list($param{block})) {
 358         next if $ok_blockers{$blocker} or $bad_blockers{$blocker};
 359         my $data = read_bug(bug=>$blocker,
 360                            );
 361         if (defined $data and not $data->{archive}) {
 362             $data = split_status_fields($data);
 363             $ok_blockers{$blocker} = 1;
 364             my @merged_bugs;
 365             push @merged_bugs, make_list($data->{mergedwith});
 366             @ok_blockers{@merged_bugs} = (1) x @merged_bugs if @merged_bugs;
 367         }
 368         else {
 369             $bad_blockers{$blocker} = 1;
 370         }
 371     }
 372
 373     # throw an error if we are setting the blockers and there is a bad
 374     # blocker
 375     if (keys %bad_blockers and $mode eq 'set') {
 376         croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers).
 377             keys %ok_blockers?'':" and no known blocking bug(s)";
 378     }
 379     # if there are no ok blockers and we are not setting the blockers,
 380     # there's an error.
 381     if (not keys %ok_blockers and $mode ne 'set') {
 382         print {$transcript} "No valid blocking bug(s) given; not doing anything\n";
 383         if (keys %bad_blockers) {
 384             croak "Unknown blocking bug(s):".join(', ',keys %bad_blockers);
 385         }
 386         __end_control(%info);
 387         return;
 388     }
 389
 390     my @change_blockers = keys %ok_blockers;
 391
 392     my %removed_blockers;
 393     my %added_blockers;
 394     my $action = '';
 395     my @blockers = map {split ' ', $_->{blockedby}} @data;
 396     my %blockers;
 397     @blockers{@blockers} = (1) x @blockers;
 398
 399     # it is nonsensical for a bug to block itself (or a merged
 400     # partner); We currently don't allow removal because we'd possibly
 401     # deadlock
 402
 403     my %bugs;
 404     @bugs{@bugs} = (1) x @bugs;
 405     for my $blocker (@change_blockers) {
 406         if ($bugs{$blocker}) {
 407             croak "It is nonsensical for a bug to block itself (or a merged partner): $blocker";
 408         }
 409     }
 410     @blockers = keys %blockers;
 411     if ($param{add}) {
 412         %removed_blockers = ();
 413         for my $blocker (@change_blockers) {
 414             next if exists $blockers{$blocker};
 415             $blockers{$blocker} = 1;
 416             $added_blockers{$blocker} = 1;
 417         }
 418     }
 419     elsif ($param{remove}) {
 420         %added_blockers = ();
 421         for my $blocker (@change_blockers) {
 422             next if exists $removed_blockers{$blocker};
 423             delete $blockers{$blocker};
 424             $removed_blockers{$blocker} = 1;
 425         }
 426     }
 427     else {
 428         @removed_blockers{@blockers} = (1) x @blockers;
 429         %blockers = ();
 430         for my $blocker (@change_blockers) {
 431             next if exists $blockers{$blocker};
 432             $blockers{$blocker} = 1;
 433             if (exists $removed_blockers{$blocker}) {
 434                 delete $removed_blockers{$blocker};
 435             }
 436             else {
 437                 $added_blockers{$blocker} = 1;
 438             }
 439         }
 440     }
 441     my @new_blockers = keys %blockers;
 442     for my $data (@data) {
 443         my $old_data = dclone($data);
 444         # remove blockers and/or add new ones as appropriate
 445         if ($data->{blockedby} eq '') {
 446             print {$transcript} "$data->{bug_num} was not blocked by any bugs.\n";
 447         } else {
 448             print {$transcript} "$data->{bug_num} was blocked by: $data->{blockedby}\n";
 449         }
 450         if ($data->{blocks} eq '') {
 451             print {$transcript} "$data->{bug_num} was not blocking any bugs.\n";
 452         } else {
 453             print {$transcript} "$data->{bug_num} was blocking: $data->{blocks}\n";
 454         }
 455         my @changed;
 456         push @changed, 'added blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %added_blockers]) if keys %added_blockers;
 457         push @changed, 'removed blocking bug(s) of '.$data->{bug_num}.': '.english_join([keys %removed_blockers]) if keys %removed_blockers;
 458         $action = ucfirst(join ('; ',@changed)) if @changed;
 459         if (not @changed) {
 460             print {$transcript} "Ignoring request to alter blocking bugs of bug #$data->{bug_num} to the same blocks previously set\n"
 461                 unless __internal_request();
 462             next;
 463         }
 464         $data->{blockedby} = join(' ',keys %blockers);
 465         append_action_to_log(bug => $data->{bug_num},
 466                              command  => 'block',
 467                              old_data => $old_data,
 468                              new_data => $data,
 469                              get_lock => 0,
 470                              __return_append_to_log_options(
 471                                                             %param,
 472                                                             action => $action,
 473                                                            ),
 474                             )
 475             if not exists $param{append_log} or $param{append_log};
 476         writebug($data->{bug_num},$data);
 477         print {$transcript} "$action\n";
 478     }
 479     # we do this bit below to avoid code duplication
 480     my %mungable_blocks;
 481     $mungable_blocks{remove} = \%removed_blockers if keys %removed_blockers;
 482     $mungable_blocks{add} = \%added_blockers if keys %added_blockers;
 483     my $new_locks = 0;
 484     for my $add_remove (keys %mungable_blocks) {
 485         my @munge_blockers;
 486         my %munge_blockers;
 487         my $block_locks = 0;
 488         for my $blocker (keys %{$mungable_blocks{$add_remove}}) {
 489             next if $munge_blockers{$blocker};
 490             my ($temp_locks, @blocking_data) =
 491                 lock_read_all_merged_bugs(bug => $blocker,
 492                                           ($param{archived}?(location => 'archive'):()),
 493                                           exists $param{locks}?(locks => $param{locks}):(),
 494                                          );
 495             $locks+= $temp_locks;
 496             $new_locks+=$temp_locks;
 497             if (not @blocking_data) {
 498                 for (1..$new_locks) {
 499                     unfilelock(exists $param{locks}?$param{locks}:());
 500                     $locks--;
 501                 }
 502                 die "Unable to get file lock while trying to $add_remove blocker '$blocker'";
 503             }
 504             for (map {$_->{bug_num}} @blocking_data) {
 505                 $munge_blockers{$_} = 1;
 506             }
 507             for my $data (@blocking_data) {
 508                 my $old_data = dclone($data);
 509                 my %blocks;
 510                 my @blocks = split ' ', $data->{blocks};
 511                 @blocks{@blocks} = (1) x @blocks;
 512                 @blocks = ();
 513                 for my $bug (@bugs) {
 514                     if ($add_remove eq 'remove') {
 515                         next unless exists $blocks{$bug};
 516                         delete $blocks{$bug};
 517                     }
 518                     else {
 519                         next if exists $blocks{$bug};
 520                         $blocks{$bug} = 1;
 521                     }
 522                     push @blocks, $bug;
 523                 }
 524                 $data->{blocks} = join(' ',sort keys %blocks);
 525                 my $action = ($add_remove eq 'add'?'Added':'Removed').
 526                     " indication that bug $data->{bug_num} blocks ".
 527                     join(',',@blocks);
 528                 append_action_to_log(bug => $data->{bug_num},
 529                                      command => 'block',
 530                                      old_data => $old_data,
 531                                      new_data => $data,
 532                                      get_lock => 0,
 533                                      __return_append_to_log_options(%param,
 534                                                                    action => $action
 535                                                                    )
 536                                     );
 537                 writebug($data->{bug_num},$data);
 538             }
 539             __handle_affected_packages(%param,data=>\@blocking_data);
 540             add_recipients(recipients => $param{recipients},
 541                            actions_taken => {blocks => 1},
 542                            data       => \@blocking_data,
 543                            debug      => $debug,
 544                            transcript => $transcript,
 545                           );
 546
 547             for (1..$new_locks) {
 548                 unfilelock(exists $param{locks}?$param{locks}:());
 549                 $locks--;
 550             }
 551         }
 552     }
 553     __end_control(%info);
 554 }
 555
 556
 557
 558 =head2 set_tag
 559
 560      eval {
 561             set_tag(bug          => $ref,
 562                     transcript   => $transcript,
 563                     ($dl > 0 ? (debug => $transcript):()),
 564                     requester    => $header{from},
 565                     request_addr => $controlrequestaddr,
 566                     message      => \@log,
 567                     affected_packages => \%affected_packages,
 568                     recipients   => \%recipients,
 569                     tag          => [],
 570                     add          => 1,
 571                    );
 572         };
 573         if ($@) {
 574             $errors++;
 575             print {$transcript} "Failed to set tag on $ref: $@";
 576         }
 577
 578
 579 Sets, adds, or removes the specified tags on a bug
 580
 581 =over
 582
 583 =item tag -- scalar or arrayref of tags to set, add or remove
 584
 585 =item add -- if true, add tags
 586
 587 =item remove -- if true, remove tags
 588
 589 =item warn_on_bad_tags -- if true (the default) warn if bad tags are
 590 passed.
 591
 592 =back
 593
 594 =cut
 595
 596 sub set_tag {
 597     my %param = validate_with(params => \@_,
 598                               spec   => {bug => {type   => SCALAR,
 599                                                  regex  => qr/^\d+$/,
 600                                                 },
 601                                          # specific options here
 602                                          tag    => {type => SCALAR|ARRAYREF,
 603                                                     default => [],
 604                                                    },
 605                                          add      => {type => BOOLEAN,
 606                                                       default => 0,
 607                                                      },
 608                                          remove   => {type => BOOLEAN,
 609                                                       default => 0,
 610                                                      },
 611                                          warn_on_bad_tags => {type => BOOLEAN,
 612                                                               default => 1,
 613                                                              },
 614                                          %common_options,
 615                                          %append_action_options,
 616                                         },
 617                              );
 618     if ($param{add} and $param{remove}) {
 619         croak "It's nonsensical to add and remove the same tags";
 620     }
 621
 622     my %info =
 623         __begin_control(%param,
 624                         command  => 'tag'
 625                        );
 626     my ($debug,$transcript) =
 627         @info{qw(debug transcript)};
 628     my @data = @{$info{data}};
 629     my @bugs = @{$info{bugs}};
 630     my @tags = make_list($param{tag});
 631     if (not @tags and ($param{remove} or $param{add})) {
 632         if ($param{remove}) {
 633             print {$transcript} "Requested to remove no tags; doing nothing.\n";
 634         }
 635         else {
 636             print {$transcript} "Requested to add no tags; doing nothing.\n";
 637         }
 638         __end_control(%info);
 639         return;
 640     }
 641     # first things first, make the versions fully qualified source
 642     # versions
 643     for my $data (@data) {
 644         my $action = 'Did not alter tags';
 645         my %tag_added = ();
 646         my %tag_removed = ();
 647         my %fixed_removed = ();
 648         my @old_tags = split /\,?\s+/, $data->{keywords};
 649         my %tags;
 650         @tags{@old_tags} = (1) x @old_tags;
 651         my $reopened = 0;
 652         my $old_data = dclone($data);
 653         if (not $param{add} and not $param{remove}) {
 654             $tag_removed{$_} = 1 for @old_tags;
 655             %tags = ();
 656         }
 657         my @bad_tags = ();
 658         for my $tag (@tags) {
 659             if (not $param{remove} and
 660                 not defined first {$_ eq $tag} @{$config{tags}}) {
 661                 push @bad_tags, $tag;
 662                 next;
 663             }
 664             if ($param{add}) {
 665                 if (not exists $tags{$tag}) {
 666                     $tags{$tag} = 1;
 667                     $tag_added{$tag} = 1;
 668                 }
 669             }
 670             elsif ($param{remove}) {
 671                 if (exists $tags{$tag}) {
 672                     delete $tags{$tag};
 673                     $tag_removed{$tag} = 1;
 674                 }
 675             }
 676             else {
 677                 if (exists $tag_removed{$tag}) {
 678                     delete $tag_removed{$tag};
 679                 }
 680                 else {
 681                     $tag_added{$tag} = 1;
 682                 }
 683                 $tags{$tag} = 1;
 684             }
 685         }
 686         if (@bad_tags and $param{warn_on_bad_tags}) {
 687             print {$transcript} "Unknown tag(s): ".join(', ',@bad_tags).".\n";
 688             print {$transcript} "These tags are recognized: ".join(', ',@{$config{tags}}).".\n";
 689         }
 690         $data->{keywords} = join(' ',keys %tags);
 691
 692         my @changed;
 693         push @changed, 'added tag(s) '.english_join([keys %tag_added]) if keys %tag_added;
 694         push @changed, 'removed tag(s) '.english_join([keys %tag_removed]) if keys %tag_removed;
 695         $action = ucfirst(join ('; ',@changed)) if @changed;
 696         if (not @changed) {
 697             print {$transcript} "Ignoring request to alter tags of bug #$data->{bug_num} to the same tags previously set\n"
 698                 unless __internal_request();
 699             next;
 700         }
 701         $action .= '.';
 702         append_action_to_log(bug => $data->{bug_num},
 703                              get_lock => 0,
 704                              command  => 'tag',
 705                              old_data => $old_data,
 706                              new_data => $data,
 707                              __return_append_to_log_options(
 708                                                             %param,
 709                                                             action => $action,
 710                                                            ),
 711                             )
 712             if not exists $param{append_log} or $param{append_log};
 713         writebug($data->{bug_num},$data);
 714         print {$transcript} "$action\n";
 715     }
 716     __end_control(%info);
 717 }
 718
 719
 720
 721 =head2 set_severity
 722
 723      eval {
 724             set_severity(bug          => $ref,
 725                          transcript   => $transcript,
 726                          ($dl > 0 ? (debug => $transcript):()),
 727                          requester    => $header{from},
 728                          request_addr => $controlrequestaddr,
 729                          message      => \@log,
 730                          affected_packages => \%affected_packages,
 731                          recipients   => \%recipients,
 732                          severity     => 'normal',
 733                         );
 734         };
 735         if ($@) {
 736             $errors++;
 737             print {$transcript} "Failed to set the severity of bug $ref: $@";
 738         }
 739
 740 Sets the severity of a bug. If severity is not passed, is undefined,
 741 or has zero length, sets the severity to the default severity.
 742
 743 =cut
 744
 745 sub set_severity {
 746     my %param = validate_with(params => \@_,
 747                               spec   => {bug => {type   => SCALAR,
 748                                                  regex  => qr/^\d+$/,
 749                                                 },
 750                                          # specific options here
 751                                          severity => {type => SCALAR|UNDEF,
 752                                                       default => $config{default_severity},
 753                                                      },
 754                                          %common_options,
 755                                          %append_action_options,
 756                                         },
 757                              );
 758     if (not defined $param{severity} or
 759         not length $param{severity}
 760        ) {
 761         $param{severity} = $config{default_severity};
 762     }
 763
 764     # check validity of new severity
 765     if (not defined first {$_ eq $param{severity}} (@{$config{severity_list}},$config{default_severity})) {
 766         die "Severity '$param{severity}' is not a valid severity level";
 767     }
 768     my %info =
 769         __begin_control(%param,
 770                         command  => 'severity'
 771                        );
 772     my ($debug,$transcript) =
 773         @info{qw(debug transcript)};
 774     my @data = @{$info{data}};
 775     my @bugs = @{$info{bugs}};
 776
 777     my $action = '';
 778     for my $data (@data) {
 779         if (not defined $data->{severity}) {
 780             $data->{severity} = $param{severity};
 781             $action = "Severity set to '$param{severity}'";
 782         }
 783         else {
 784             if ($data->{severity} eq '') {
 785                 $data->{severity} = $config{default_severity};
 786             }
 787             if ($data->{severity} eq $param{severity}) {
 788                 print {$transcript} "Ignoring request to change severity of $config{bug} $data->{bug_num} to the same value.\n";
 789                 next;
 790             }
 791             $action = "Severity set to '$param{severity}' from '$data->{severity}'";
 792             $data->{severity} = $param{severity};
 793         }
 794         append_action_to_log(bug => $data->{bug_num},
 795                              get_lock => 0,
 796                              __return_append_to_log_options(
 797                                                             %param,
 798                                                             action => $action,
 799                                                            ),
 800                             )
 801             if not exists $param{append_log} or $param{append_log};
 802         writebug($data->{bug_num},$data);
 803         print {$transcript} "$action\n";
 804     }
 805     __end_control(%info);
 806 }
 807
 808
 809 =head2 set_done
 810
 811      eval {
 812             set_done(bug          => $ref,
 813                      transcript   => $transcript,
 814                      ($dl > 0 ? (debug => $transcript):()),
 815                      requester    => $header{from},
 816                      request_addr => $controlrequestaddr,
 817                      message      => \@log,
 818                      affected_packages => \%affected_packages,
 819                      recipients   => \%recipients,
 820                     );
 821         };
 822         if ($@) {
 823             $errors++;
 824             print {$transcript} "Failed to set foo $ref bar: $@";
 825         }
 826
 827 Foo frobinates
 828
 829 =cut
 830
 831 sub set_done {
 832     my %param = validate_with(params => \@_,
 833                               spec   => {bug => {type   => SCALAR,
 834                                                  regex  => qr/^\d+$/,
 835                                                 },
 836                                          reopen    => {type => BOOLEAN,
 837                                                        default => 0,
 838                                                       },
 839                                          submitter => {type => SCALAR,
 840                                                        optional => 1,
 841                                                       },
 842                                          clear_fixed => {type => BOOLEAN,
 843                                                          default => 1,
 844                                                         },
 845                                          notify_submitter => {type => BOOLEAN,
 846                                                               default => 1,
 847                                                              },
 848                                          original_report => {type => SCALARREF,
 849                                                              optional => 1,
 850                                                             },
 851                                          done => {type => SCALAR|UNDEF,
 852                                                   optional => 1,
 853                                                  },
 854                                          %common_options,
 855                                          %append_action_options,
 856                                         },
 857                              );
 858
 859     if (exists $param{submitter} and
 860         not Mail::RFC822::Address::valid($param{submitter})) {
 861         die "New submitter address '$param{submitter}' is not a valid e-mail address";
 862     }
 863     if (exists $param{done} and defined $param{done} and $param{done} eq 1) { #special case this as using the requester address
 864         $param{done} = $param{requester};
 865     }
 866     if (exists $param{done} and
 867         (not defined $param{done} or
 868          not length $param{done})) {
 869         delete $param{done};
 870         $param{reopen} = 1;
 871     }
 872
 873     my %info =
 874         __begin_control(%param,
 875                         command  => $param{reopen}?'reopen':'done',
 876                        );
 877     my ($debug,$transcript) =
 878         @info{qw(debug transcript)};
 879     my @data = @{$info{data}};
 880     my @bugs = @{$info{bugs}};
 881     my $action ='';
 882
 883     if ($param{reopen}) {
 884         # avoid warning multiple times if there are fixed versions
 885         my $warn_fixed = 1;
 886         for my $data (@data) {
 887             if (not exists $data->{done} or
 888                 not defined $data->{done} or
 889                 not length $data->{done}) {
 890                 print {$transcript} "Bug $data->{bug_num} is not marked as done; doing nothing.\n";
 891                 __end_control(%info);
 892                 return;
 893             }
 894             if (@{$data->{fixed_versions}} and $warn_fixed) {
 895                 print {$transcript} "'reopen' may be inappropriate when a bug has been closed with a version;\n";
 896                 print {$transcript} "all fixed versions will be cleared, and you may need to re-add them.\n";
 897                 $warn_fixed = 0;
 898             }
 899         }
 900         __end_control(%info);
 901         if (exists $param{submitter}) {
 902             set_submitter(bug => $param{bug},
 903                           submitter => $param{submitter},
 904                           hash_slice(%param,
 905                                      keys %common_options,
 906                                      keys %append_action_options)
 907                          );
 908         }
 909         # clear the fixed revisions
 910         if ($param{clear_fixed}) {
 911             set_fixed(fixed => [],
 912                       bug => $param{bug},
 913                       reopen => 0,
 914                       hash_slice(%param,
 915                                  keys %common_options,
 916                                  keys %append_action_options),
 917                      );
 918         }
 919     }
 920     else {
 921         my %submitter_notified;
 922         my $requester_notified = 0;
 923         my $orig_report_set = 0;
 924         for my $data (@data) {
 925             if (exists $data->{done} and
 926                 defined $data->{done} and
 927                 length $data->{done}) {
 928                 print {$transcript} "Bug $data->{bug_num} is already marked as done; not doing anything.\n";
 929                 __end_control(%info);
 930                 return;
 931             }
 932         }
 933         for my $data (@data) {
 934             my $old_data = dclone($data);
 935             my $hash = get_hashname($data->{bug_num});
 936             my $report_fh = IO::File->new("db-h/$hash/$data->{bug_num}.report",'r') or
 937                 die "Unable to open original report db-h/$hash/$data->{bug_num}.report for reading: $!";
 938             my $orig_report;
 939             {
 940                 local $/;
 941                 $orig_report= <$report_fh>;
 942             }
 943             close $report_fh;
 944             if (not $orig_report_set and defined $orig_report and
 945                 length $orig_report and
 946                 exists $param{original_report}){
 947                 ${$param{original_report}} = $orig_report;
 948                 $orig_report_set = 1;
 949             }
 950
 951             $action = "Marked $config{bug} as done";
 952
 953             # set done to the requester
 954             $data->{done} = exists $param{done}?$param{done}:$param{requester};
 955             append_action_to_log(bug => $data->{bug_num},
 956                                  command => 'done',
 957                                  new_data => $data,
 958                                  old_data => $old_data,
 959                                  get_lock => 0,
 960                                  __return_append_to_log_options(
 961                                                                 %param,
 962                                                                 action => $action,
 963                                                                ),
 964                                 )
 965                 if not exists $param{append_log} or $param{append_log};
 966             writebug($data->{bug_num},$data);
 967             print {$transcript} "$action\n";
 968             # get the original report
 969             if ($param{notify_submitter}) {
 970                 my $submitter_message;
 971                 if(not exists $submitter_notified{$data->{originator}}) {
 972                     $submitter_message =
 973                         create_mime_message([default_headers(queue_file => $param{request_nn},
 974                                                              data => $data,
 975                                                              msgid => $param{request_msgid},
 976                                                              msgtype => 'notifdone',
 977                                                              pr_msg  => 'they-closed',
 978                                                              headers =>
 979                                                              [To => $data->{submitter},
 980                                                               Subject => "$config{ubug}#$data->{bug_num} ".
 981                                                               "closed by $param{requester} ($param{request_subject})",
 982                                                              ],
 983                                                             )
 984                                             ],
 985                                             __message_body_template('mail/process_your_bug_done',
 986                                                                     {data     => $data,
 987                                                                      replyto  => (exists $param{request_replyto} ?
 988                                                                                   $param{request_replyto} :
 989                                                                                   $param{requester} || 'Unknown'),
 990                                                                      markedby => $param{requester},
 991                                                                      subject => $param{request_subject},
 992                                                                      messageid => $param{request_msgid},
 993                                                                      config   => \%config,
 994                                                                     }),
 995                                             [join('',make_list($param{message})),$orig_report]
 996                                            );
 997                     send_mail_message(message => $submitter_message,
 998                                       recipients => $old_data->{submitter},
 999                                      );
1000                     $submitter_notified{$data->{originator}} = $submitter_message;
1001                 }
1002                 else {
1003                     $submitter_message = $submitter_notified{$data->{originator}};
1004                 }
1005                 append_action_to_log(bug => $data->{bug_num},
1006                                      action => "Notification sent",
1007                                      requester => '',
1008                                      request_addr => $data->{originator},
1009                                      desc => "$config{bug} acknowledged by developer.",
1010                                      recips => [$data->{originator}],
1011                                      message => $submitter_message,
1012                                      get_lock => 0,
1013                                     );
1014             }
1015         }
1016         if (exists $param{fixed}) {
1017             set_fixed(fixed => $param{fixed},
1018                       bug => $param{bug},
1019                       reopen => 0,
1020                       hash_slice(%param,
1021                                  keys %common_options,
1022                                  keys %append_action_options
1023                                 ),
1024                      );
1025         }
1026     }
1027 }
1028
1029
1030 =head2 set_submitter
1031
1032      eval {
1033             set_submitter(bug          => $ref,
1034                           transcript   => $transcript,
1035                           ($dl > 0 ? (debug => $transcript):()),
1036                           requester    => $header{from},
1037                           request_addr => $controlrequestaddr,
1038                           message      => \@log,
1039                           affected_packages => \%affected_packages,
1040                           recipients   => \%recipients,
1041                           submitter    => $new_submitter,
1042                           notify_submitter => 1,
1043                           );
1044         };
1045         if ($@) {
1046             $errors++;
1047             print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1048         }
1049
1050 Sets the submitter of a bug. If notify_submitter is true (the
1051 default), notifies the old submitter of a bug on changes
1052
1053 =cut
1054
1055 sub set_submitter {
1056     my %param = validate_with(params => \@_,
1057                               spec   => {bug => {type   => SCALAR,
1058                                                  regex  => qr/^\d+$/,
1059                                                 },
1060                                          # specific options here
1061                                          submitter => {type => SCALAR,
1062                                                       },
1063                                          notify_submitter => {type => BOOLEAN,
1064                                                               default => 1,
1065                                                              },
1066                                          %common_options,
1067                                          %append_action_options,
1068                                         },
1069                              );
1070     if (not Mail::RFC822::Address::valid($param{submitter})) {
1071         die "New submitter address $param{submitter} is not a valid e-mail address";
1072     }
1073     my %info =
1074         __begin_control(%param,
1075                         command  => 'submitter'
1076                        );
1077     my ($debug,$transcript) =
1078         @info{qw(debug transcript)};
1079     my @data = @{$info{data}};
1080     my @bugs = @{$info{bugs}};
1081     my $action = '';
1082     # here we only concern ourselves with the first of the merged bugs
1083     for my $data ($data[0]) {
1084         my $notify_old_submitter = 0;
1085         my $old_data = dclone($data);
1086         print {$debug} "Going to change bug submitter\n";
1087         if (((not defined $param{submitter} or not length $param{submitter}) and
1088               (not defined $data->{originator} or not length $data->{originator})) or
1089              (defined $param{submitter} and defined $data->{originator} and
1090               $param{submitter} eq $data->{originator})) {
1091             print {$transcript} "Ignoring request to change the submitter of bug#$data->{bug_num} to the same value\n"
1092                 unless __internal_request();
1093             next;
1094         }
1095         else {
1096             if (defined $data->{originator} and length($data->{originator})) {
1097                 $action= "Changed $config{bug} submitter to '$param{submitter}' from '$data->{originator}'";
1098                 $notify_old_submitter = 1;
1099             }
1100             else {
1101                 $action= "Set $config{bug} submitter to '$param{submitter}'.";
1102             }
1103             $data->{originator} = $param{submitter};
1104         }
1105         append_action_to_log(bug => $data->{bug_num},
1106                              command => 'submitter',
1107                              new_data => $data,
1108                              old_data => $old_data,
1109                              get_lock => 0,
1110                              __return_append_to_log_options(
1111                                                             %param,
1112                                                             action => $action,
1113                                                            ),
1114                             )
1115             if not exists $param{append_log} or $param{append_log};
1116         writebug($data->{bug_num},$data);
1117         print {$transcript} "$action\n";
1118         # notify old submitter
1119         if ($notify_old_submitter and $param{notify_submitter}) {
1120             send_mail_message(message =>
1121                               create_mime_message([default_headers(queue_file => $param{request_nn},
1122                                                                    data => $data,
1123                                                                    msgid => $param{request_msgid},
1124                                                                    msgtype => 'ack',
1125                                                                    pr_msg  => 'submitter-changed',
1126                                                                    headers =>
1127                                                                    [To => $old_data->{submitter},
1128                                                                     Subject => "$config{ubug}#$data->{bug_num} submitter addressed changed ($param{request_subject})",
1129                                                                    ],
1130                                                                   )
1131                                                   ],
1132                                                   __message_body_template('mail/submitter_changed',
1133                                                                           {old_data => $old_data,
1134                                                                            data     => $data,
1135                                                                            replyto  => exists $param{header}{'reply-to'} ? $param{request_replyto} : $param{requester} || 'Unknown',
1136                                                                            config   => \%config,
1137                                                                           })
1138                                                  ),
1139                               recipients => $old_data->{submitter},
1140                              );
1141         }
1142     }
1143     __end_control(%info);
1144 }
1145
1146
1147
1148 =head2 set_forwarded
1149
1150      eval {
1151             set_forwarded(bug          => $ref,
1152                           transcript   => $transcript,
1153                           ($dl > 0 ? (debug => $transcript):()),
1154                           requester    => $header{from},
1155                           request_addr => $controlrequestaddr,
1156                           message      => \@log,
1157                           affected_packages => \%affected_packages,
1158                           recipients   => \%recipients,
1159                           forwarded    => $forward_to,
1160                           );
1161         };
1162         if ($@) {
1163             $errors++;
1164             print {$transcript} "Failed to set the forwarded-to-address of $ref: $@";
1165         }
1166
1167 Sets the location to which a bug is forwarded. Given an undef
1168 forwarded, unsets forwarded.
1169
1170
1171 =cut
1172
1173 sub set_forwarded {
1174     my %param = validate_with(params => \@_,
1175                               spec   => {bug => {type   => SCALAR,
1176                                                  regex  => qr/^\d+$/,
1177                                                 },
1178                                          # specific options here
1179                                          forwarded => {type => SCALAR|UNDEF,
1180                                                       },
1181                                          %common_options,
1182                                          %append_action_options,
1183                                         },
1184                              );
1185     if (defined $param{forwarded} and $param{forwarded} =~ /[^[:print:]]/) {
1186         die "Non-printable characters are not allowed in the forwarded field";
1187     }
1188     $param{forwarded} = undef if defined $param{forwarded} and not length $param{forwarded};
1189     my %info =
1190         __begin_control(%param,
1191                         command  => 'forwarded'
1192                        );
1193     my ($debug,$transcript) =
1194         @info{qw(debug transcript)};
1195     my @data = @{$info{data}};
1196     my @bugs = @{$info{bugs}};
1197     my $action = '';
1198     for my $data (@data) {
1199         my $old_data = dclone($data);
1200         print {$debug} "Going to change bug forwarded\n";
1201         if (__all_undef_or_equal($param{forwarded},$data->{forwarded}) or
1202             (not defined $param{forwarded} and
1203              defined $data->{forwarded} and not length $data->{forwarded})) {
1204             print {$transcript} "Ignoring request to change the forwarded-to-address of bug#$data->{bug_num} to the same value\n"
1205                 unless __internal_request();
1206             next;
1207         }
1208         else {
1209             if (not defined $param{forwarded}) {
1210                 $action= "Unset $config{bug} forwarded-to-address";
1211             }
1212             elsif (defined $data->{forwarded} and length($data->{forwarded})) {
1213                 $action= "Changed $config{bug} forwarded-to-address to '$param{forwarded}' from '$data->{forwarded}'";
1214             }
1215             else {
1216                 $action= "Set $config{bug} forwarded-to-address to '$param{forwarded}'.";
1217             }
1218             $data->{forwarded} = $param{forwarded};
1219         }
1220         append_action_to_log(bug => $data->{bug_num},
1221                              command => 'forwarded',
1222                              new_data => $data,
1223                              old_data => $old_data,
1224                              get_lock => 0,
1225                              __return_append_to_log_options(
1226                                                             %param,
1227                                                             action => $action,
1228                                                            ),
1229                             )
1230             if not exists $param{append_log} or $param{append_log};
1231         writebug($data->{bug_num},$data);
1232         print {$transcript} "$action\n";
1233     }
1234     __end_control(%info);
1235 }
1236
1237
1238
1239
1240 =head2 set_title
1241
1242      eval {
1243             set_title(bug          => $ref,
1244                       transcript   => $transcript,
1245                       ($dl > 0 ? (debug => $transcript):()),
1246                       requester    => $header{from},
1247                       request_addr => $controlrequestaddr,
1248                       message      => \@log,
1249                       affected_packages => \%affected_packages,
1250                       recipients   => \%recipients,
1251                       title        => $new_title,
1252                       );
1253         };
1254         if ($@) {
1255             $errors++;
1256             print {$transcript} "Failed to set the title of $ref: $@";
1257         }
1258
1259 Sets the title of a specific bug
1260
1261
1262 =cut
1263
1264 sub set_title {
1265     my %param = validate_with(params => \@_,
1266                               spec   => {bug => {type   => SCALAR,
1267                                                  regex  => qr/^\d+$/,
1268                                                 },
1269                                          # specific options here
1270                                          title => {type => SCALAR,
1271                                                   },
1272                                          %common_options,
1273                                          %append_action_options,
1274                                         },
1275                              );
1276     if ($param{title} =~ /[^[:print:]]/) {
1277         die "Non-printable characters are not allowed in bug titles";
1278     }
1279
1280     my %info = __begin_control(%param,
1281                                command  => 'title',
1282                               );
1283     my ($debug,$transcript) =
1284         @info{qw(debug transcript)};
1285     my @data = @{$info{data}};
1286     my @bugs = @{$info{bugs}};
1287     my $action = '';
1288     for my $data (@data) {
1289         my $old_data = dclone($data);
1290         print {$debug} "Going to change bug title\n";
1291         if (defined $data->{subject} and length($data->{subject}) and
1292             $data->{subject} eq $param{title}) {
1293             print {$transcript} "Ignoring request to change the title of bug#$data->{bug_num} to the same title\n"
1294                 unless __internal_request();
1295             next;
1296         }
1297         else {
1298             if (defined $data->{subject} and length($data->{subject})) {
1299                 $action= "Changed $config{bug} title to '$param{title}' from '$data->{subject}'";
1300             } else {
1301                 $action= "Set $config{bug} title to '$param{title}'.";
1302             }
1303             $data->{subject} = $param{title};
1304         }
1305         append_action_to_log(bug => $data->{bug_num},
1306                              command => 'title',
1307                              new_data => $data,
1308                              old_data => $old_data,
1309                              get_lock => 0,
1310                              __return_append_to_log_options(
1311                                                             %param,
1312                                                             action => $action,
1313                                                            ),
1314                             )
1315             if not exists $param{append_log} or $param{append_log};
1316         writebug($data->{bug_num},$data);
1317         print {$transcript} "$action\n";
1318     }
1319     __end_control(%info);
1320 }
1321
1322
1323 =head2 set_package
1324
1325      eval {
1326             set_package(bug          => $ref,
1327                         transcript   => $transcript,
1328                         ($dl > 0 ? (debug => $transcript):()),
1329                         requester    => $header{from},
1330                         request_addr => $controlrequestaddr,
1331                         message      => \@log,
1332                         affected_packages => \%affected_packages,
1333                         recipients   => \%recipients,
1334                         package      => $new_package,
1335                         is_source    => 0,
1336                        );
1337         };
1338         if ($@) {
1339             $errors++;
1340             print {$transcript} "Failed to assign or reassign $ref to a package: $@";
1341         }
1342
1343 Indicates that a bug is in a particular package. If is_source is true,
1344 indicates that the package is a source package. [Internally, this
1345 causes src: to be prepended to the package name.]
1346
1347 The default for is_source is 0. As a special case, if the package
1348 starts with 'src:', it is assumed to be a source package and is_source
1349 is overridden.
1350
1351 The package option must match the package_name_re regex.
1352
1353 =cut
1354
1355 sub set_package {
1356     my %param = validate_with(params => \@_,
1357                               spec   => {bug => {type   => SCALAR,
1358                                                  regex  => qr/^\d+$/,
1359                                                 },
1360                                          # specific options here
1361                                          package => {type => SCALAR|ARRAYREF,
1362                                                     },
1363                                          is_source => {type => BOOLEAN,
1364                                                        default => 0,
1365                                                       },
1366                                          %common_options,
1367                                          %append_action_options,
1368                                         },
1369                              );
1370     my @new_packages = map {splitpackages($_)} make_list($param{package});
1371     if (grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages) {
1372         croak "Invalid package name '".
1373             join(',',grep {$_ !~ /^(?:src:|)$config{package_name_re}$/} @new_packages).
1374                 "'";
1375     }
1376     my %info = __begin_control(%param,
1377                                command  => 'package',
1378                               );
1379     my ($debug,$transcript) =
1380         @info{qw(debug transcript)};
1381     my @data = @{$info{data}};
1382     my @bugs = @{$info{bugs}};
1383     # clean up the new package
1384     my $new_package =
1385         join(',',
1386              map {my $temp = $_;
1387                   ($temp =~ s/^src:// or
1388                    $param{is_source}) ? 'src:'.$temp:$temp;
1389               } @new_packages);
1390
1391     my $action = '';
1392     my $package_reassigned = 0;
1393     for my $data (@data) {
1394         my $old_data = dclone($data);
1395         print {$debug} "Going to change assigned package\n";
1396         if (defined $data->{package} and length($data->{package}) and
1397             $data->{package} eq $new_package) {
1398             print {$transcript} "Ignoring request to reassign bug #$data->{bug_num} to the same package\n"
1399                 unless __internal_request();
1400             next;
1401         }
1402         else {
1403             if (defined $data->{package} and length($data->{package})) {
1404                 $package_reassigned = 1;
1405                 $action= "$config{bug} reassigned from package '$data->{package}'".
1406                     " to '$new_package'.";
1407             } else {
1408                 $action= "$config{bug} assigned to package '$new_package'.";
1409             }
1410             $data->{package} = $new_package;
1411         }
1412         append_action_to_log(bug => $data->{bug_num},
1413                              command => 'package',
1414                              new_data => $data,
1415                              old_data => $old_data,
1416                              get_lock => 0,
1417                              __return_append_to_log_options(
1418                                                             %param,
1419                                                             action => $action,
1420                                                            ),
1421                             )
1422             if not exists $param{append_log} or $param{append_log};
1423         writebug($data->{bug_num},$data);
1424         print {$transcript} "$action\n";
1425     }
1426     __end_control(%info);
1427     # Only clear the fixed/found versions if the package has been
1428     # reassigned
1429     if ($package_reassigned) {
1430         my @params_for_found_fixed =
1431             map {exists $param{$_}?($_,$param{$_}):()}
1432                 ('bug',
1433                  keys %common_options,
1434                  keys %append_action_options,
1435                 );
1436         set_found(found => [],
1437                   @params_for_found_fixed,
1438                  );
1439         set_fixed(fixed => [],
1440                   @params_for_found_fixed,
1441                  );
1442     }
1443 }
1444
1445 =head2 set_found
1446
1447      eval {
1448             set_found(bug          => $ref,
1449                       transcript   => $transcript,
1450                       ($dl > 0 ? (debug => $transcript):()),
1451                       requester    => $header{from},
1452                       request_addr => $controlrequestaddr,
1453                       message      => \@log,
1454                       affected_packages => \%affected_packages,
1455                       recipients   => \%recipients,
1456                       found        => [],
1457                       add          => 1,
1458                      );
1459         };
1460         if ($@) {
1461             $errors++;
1462             print {$transcript} "Failed to set found on $ref: $@";
1463         }
1464
1465
1466 Sets, adds, or removes the specified found versions of a package
1467
1468 If the version list is empty, and the bug is currently not "done",
1469 causes the done field to be cleared.
1470
1471 If any of the versions added to found are greater than any version in
1472 which the bug is fixed (or when the bug is found and there are no
1473 fixed versions) the done field is cleared.
1474
1475 =cut
1476
1477 sub set_found {
1478     my %param = validate_with(params => \@_,
1479                               spec   => {bug => {type   => SCALAR,
1480                                                  regex  => qr/^\d+$/,
1481                                                 },
1482                                          # specific options here
1483                                          found    => {type => SCALAR|ARRAYREF,
1484                                                       default => [],
1485                                                      },
1486                                          add      => {type => BOOLEAN,
1487                                                       default => 0,
1488                                                      },
1489                                          remove   => {type => BOOLEAN,
1490                                                       default => 0,
1491                                                      },
1492                                          %common_options,
1493                                          %append_action_options,
1494                                         },
1495                              );
1496     if ($param{add} and $param{remove}) {
1497         croak "It's nonsensical to add and remove the same versions";
1498     }
1499
1500     my %info =
1501         __begin_control(%param,
1502                         command  => 'found'
1503                        );
1504     my ($debug,$transcript) =
1505         @info{qw(debug transcript)};
1506     my @data = @{$info{data}};
1507     my @bugs = @{$info{bugs}};
1508     my %versions;
1509     for my $version (make_list($param{found})) {
1510         next unless defined $version;
1511         $versions{$version} =
1512             [make_source_versions(package => [splitpackages($data[0]{package})],
1513                                   warnings => $transcript,
1514                                   debug    => $debug,
1515                                   guess_source => 0,
1516                                   versions     => $version,
1517                                  )
1518             ];
1519         # This is really ugly, but it's what we have to do
1520         if (not @{$versions{$version}}) {
1521             print {$transcript} "Unable to make a source version for version '$version'\n";
1522         }
1523     }
1524     if (not keys %versions and ($param{remove} or $param{add})) {
1525         if ($param{remove}) {
1526             print {$transcript} "Requested to remove no versions; doing nothing.\n";
1527         }
1528         else {
1529             print {$transcript} "Requested to add no versions; doing nothing.\n";
1530         }
1531         __end_control(%info);
1532         return;
1533     }
1534     # first things first, make the versions fully qualified source
1535     # versions
1536     for my $data (@data) {
1537         # The 'done' field gets a bit weird with version tracking,
1538         # because a bug may be closed by multiple people in different
1539         # branches. Until we have something more flexible, we set it
1540         # every time a bug is fixed, and clear it when a bug is found
1541         # in a version greater than any version in which the bug is
1542         # fixed or when a bug is found and there is no fixed version
1543         my $action = 'Did not alter found versions';
1544         my %found_added = ();
1545         my %found_removed = ();
1546         my %fixed_removed = ();
1547         my $reopened = 0;
1548         my $old_data = dclone($data);
1549         if (not $param{add} and not $param{remove}) {
1550             $found_removed{$_} = 1 for @{$data->{found_versions}};
1551             $data->{found_versions} = [];
1552         }
1553         my %found_versions;
1554         @found_versions{@{$data->{found_versions}}} = (1) x @{$data->{found_versions}};
1555         my %fixed_versions;
1556         @fixed_versions{@{$data->{fixed_versions}}} = (1) x @{$data->{fixed_versions}};
1557         for my $version (keys %versions) {
1558             if ($param{add}) {
1559                 my @svers = @{$versions{$version}};
1560                 if (not @svers) {
1561                     @svers = $version;
1562                 }
1563                 for my $sver (@svers) {
1564                     if (not exists $found_versions{$sver}) {
1565                         $found_versions{$sver} = 1;
1566                         $found_added{$sver} = 1;
1567                     }
1568                     # if the found we are adding matches any fixed
1569                     # versions, remove them
1570                     my @temp = grep m{(^|/)\Q$sver\E}, keys %fixed_versions;
1571                     delete $fixed_versions{$_} for @temp;
1572                     $fixed_removed{$_} = 1 for @temp;
1573                 }
1574
1575                 # We only care about reopening the bug if the bug is
1576                 # not done
1577                 if (defined $data->{done} and length $data->{done}) {
1578                     my @svers_order = sort_versions(map {m{([^/]+)$}; $1;}
1579                                                     @svers);
1580                     # determine if we need to reopen
1581                     my @fixed_order = sort_versions(map {m{([^/]+)$}; $1;}
1582                                                     keys %fixed_versions);
1583                     if (not @fixed_order or
1584                         (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1585                         $reopened = 1;
1586                         $data->{done} = '';
1587                     }
1588                 }
1589             }
1590             elsif ($param{remove}) {
1591                 # in the case of removal, we only concern ourself with
1592                 # the version passed, not the source version it maps
1593                 # to
1594                 my @temp = grep m{(^|/)\Q$version\E}, keys %found_versions;
1595                 delete $found_versions{$_} for @temp;
1596                 $found_removed{$_} = 1 for @temp;
1597             }
1598             else {
1599                 # set the keys to exactly these values
1600                 my @svers = @{$versions{$version}};
1601                 if (not @svers) {
1602                     @svers = $version;
1603                 }
1604                 for my $sver (@svers) {
1605                     if (not exists $found_versions{$sver}) {
1606                         $found_versions{$sver} = 1;
1607                         if (exists $found_removed{$sver}) {
1608                             delete $found_removed{$sver};
1609                         }
1610                         else {
1611                             $found_added{$sver} = 1;
1612                         }
1613                     }
1614                 }
1615             }
1616         }
1617
1618         $data->{found_versions} = [keys %found_versions];
1619         $data->{fixed_versions} = [keys %fixed_versions];
1620
1621         my @changed;
1622         push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1623         push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1624 #       push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1625         push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1626         $action = ucfirst(join ('; ',@changed)) if @changed;
1627         if ($reopened) {
1628             $action .= " and reopened"
1629         }
1630         if (not $reopened and not @changed) {
1631             print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n"
1632                 unless __internal_request();
1633             next;
1634         }
1635         $action .= '.';
1636         append_action_to_log(bug => $data->{bug_num},
1637                              get_lock => 0,
1638                              command  => 'found',
1639                              old_data => $old_data,
1640                              new_data => $data,
1641                              __return_append_to_log_options(
1642                                                             %param,
1643                                                             action => $action,
1644                                                            ),
1645                             )
1646             if not exists $param{append_log} or $param{append_log};
1647         writebug($data->{bug_num},$data);
1648         print {$transcript} "$action\n";
1649     }
1650     __end_control(%info);
1651 }
1652
1653 =head2 set_fixed
1654
1655      eval {
1656             set_fixed(bug          => $ref,
1657                       transcript   => $transcript,
1658                       ($dl > 0 ? (debug => $transcript):()),
1659                       requester    => $header{from},
1660                       request_addr => $controlrequestaddr,
1661                       message      => \@log,
1662                       affected_packages => \%affected_packages,
1663                       recipients   => \%recipients,
1664                       fixed        => [],
1665                       add          => 1,
1666                       reopen       => 0,
1667                      );
1668         };
1669         if ($@) {
1670             $errors++;
1671             print {$transcript} "Failed to set fixed on $ref: $@";
1672         }
1673
1674
1675 Sets, adds, or removes the specified fixed versions of a package
1676
1677 If the fixed versions are empty (or end up being empty after this
1678 call) or the greatest fixed version is less than the greatest found
1679 version and the reopen option is true, the bug is reopened.
1680
1681 This function is also called by the reopen function, which causes all
1682 of the fixed versions to be cleared.
1683
1684 =cut
1685
1686 sub set_fixed {
1687     my %param = validate_with(params => \@_,
1688                               spec   => {bug => {type   => SCALAR,
1689                                                  regex  => qr/^\d+$/,
1690                                                 },
1691                                          # specific options here
1692                                          fixed    => {type => SCALAR|ARRAYREF,
1693                                                       default => [],
1694                                                      },
1695                                          add      => {type => BOOLEAN,
1696                                                       default => 0,
1697                                                      },
1698                                          remove   => {type => BOOLEAN,
1699                                                       default => 0,
1700                                                      },
1701                                          reopen   => {type => BOOLEAN,
1702                                                       default => 0,
1703                                                      },
1704                                          %common_options,
1705                                          %append_action_options,
1706                                         },
1707                              );
1708     if ($param{add} and $param{remove}) {
1709         croak "It's nonsensical to add and remove the same versions";
1710     }
1711     my %info =
1712         __begin_control(%param,
1713                         command  => 'fixed'
1714                        );
1715     my ($debug,$transcript) =
1716         @info{qw(debug transcript)};
1717     my @data = @{$info{data}};
1718     my @bugs = @{$info{bugs}};
1719     my %versions;
1720     for my $version (make_list($param{fixed})) {
1721         next unless defined $version;
1722         $versions{$version} =
1723             [make_source_versions(package => [splitpackages($data[0]{package})],
1724                                   warnings => $transcript,
1725                                   debug    => $debug,
1726                                   guess_source => 0,
1727                                   versions     => $version,
1728                                  )
1729             ];
1730         # This is really ugly, but it's what we have to do
1731         if (not @{$versions{$version}}) {
1732             print {$transcript} "Unable to make a source version for version '$version'\n";
1733         }
1734     }
1735     if (not keys %versions and ($param{remove} or $param{add})) {
1736         if ($param{remove}) {
1737             print {$transcript} "Requested to remove no versions; doing nothing.\n";
1738         }
1739         else {
1740             print {$transcript} "Requested to add no versions; doing nothing.\n";
1741         }
1742         __end_control(%info);
1743         return;
1744     }
1745     # first things first, make the versions fully qualified source
1746     # versions
1747     for my $data (@data) {
1748         my $old_data = dclone($data);
1749         # The 'done' field gets a bit weird with version tracking,
1750         # because a bug may be closed by multiple people in different
1751         # branches. Until we have something more flexible, we set it
1752         # every time a bug is fixed, and clear it when a bug is found
1753         # in a version greater than any version in which the bug is
1754         # fixed or when a bug is found and there is no fixed version
1755         my $action = 'Did not alter fixed versions';
1756         my %found_added = ();
1757         my %found_removed = ();
1758         my %fixed_added = ();
1759         my %fixed_removed = ();
1760         my $reopened = 0;
1761         if (not $param{add} and not $param{remove}) {
1762             $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1763             $data->{fixed_versions} = [];
1764         }
1765         my %found_versions;
1766         @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1767         my %fixed_versions;
1768         @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1769         for my $version (keys %versions) {
1770             if ($param{add}) {
1771                 my @svers = @{$versions{$version}};
1772                 if (not @svers) {
1773                     @svers = $version;
1774                 }
1775                 for my $sver (@svers) {
1776                     if (not exists $fixed_versions{$sver}) {
1777                         $fixed_versions{$sver} = 1;
1778                         $fixed_added{$sver} = 1;
1779                     }
1780                 }
1781             }
1782             elsif ($param{remove}) {
1783                 # in the case of removal, we only concern ourself with
1784                 # the version passed, not the source version it maps
1785                 # to
1786                 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1787                 delete $fixed_versions{$_} for @temp;
1788                 $fixed_removed{$_} = 1 for @temp;
1789             }
1790             else {
1791                 # set the keys to exactly these values
1792                 my @svers = @{$versions{$version}};
1793                 if (not @svers) {
1794                     @svers = $version;
1795                 }
1796                 for my $sver (@svers) {
1797                     if (not exists $fixed_versions{$sver}) {
1798                         $fixed_versions{$sver} = 1;
1799                         if (exists $fixed_removed{$sver}) {
1800                             delete $fixed_removed{$sver};
1801                         }
1802                         else {
1803                             $fixed_added{$sver} = 1;
1804                         }
1805                     }
1806                 }
1807             }
1808         }
1809
1810         $data->{found_versions} = [keys %found_versions];
1811         $data->{fixed_versions} = [keys %fixed_versions];
1812
1813         # If we're supposed to consider reopening, reopen if the
1814         # fixed versions are empty or the greatest found version
1815         # is greater than the greatest fixed version
1816         if ($param{reopen} and defined $data->{done}
1817             and length $data->{done}) {
1818             my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1819                 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1820             # determine if we need to reopen
1821             my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1822                     map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1823             if (not @fixed_order or
1824                 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1825                 $reopened = 1;
1826                 $data->{done} = '';
1827             }
1828         }
1829
1830         my @changed;
1831         push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1832         push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1833         push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1834         push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1835         $action = ucfirst(join ('; ',@changed)) if @changed;
1836         if ($reopened) {
1837             $action .= " and reopened"
1838         }
1839         if (not $reopened and not @changed) {
1840             print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n"
1841                 unless __internal_request();
1842             next;
1843         }
1844         $action .= '.';
1845         append_action_to_log(bug => $data->{bug_num},
1846                              command  => 'fixed',
1847                              new_data => $data,
1848                              old_data => $old_data,
1849                              get_lock => 0,
1850                              __return_append_to_log_options(
1851                                                             %param,
1852                                                             action => $action,
1853                                                            ),
1854                             )
1855             if not exists $param{append_log} or $param{append_log};
1856         writebug($data->{bug_num},$data);
1857         print {$transcript} "$action\n";
1858     }
1859     __end_control(%info);
1860 }
1861
1862
1863 =head2 set_merged
1864
1865      eval {
1866             set_merged(bug          => $ref,
1867                        transcript   => $transcript,
1868                        ($dl > 0 ? (debug => $transcript):()),
1869                        requester    => $header{from},
1870                        request_addr => $controlrequestaddr,
1871                        message      => \@log,
1872                        affected_packages => \%affected_packages,
1873                        recipients   => \%recipients,
1874                        merge_with   => 12345,
1875                        add          => 1,
1876                        force        => 1,
1877                        allow_reassign => 1,
1878                        reassign_same_source_only => 1,
1879                       );
1880         };
1881         if ($@) {
1882             $errors++;
1883             print {$transcript} "Failed to set merged on $ref: $@";
1884         }
1885
1886
1887 Sets, adds, or removes the specified merged bugs of a bug
1888
1889 By default, requires
1890
1891 =cut
1892
1893 sub set_merged {
1894     my %param = validate_with(params => \@_,
1895                               spec   => {bug => {type   => SCALAR,
1896                                                  regex  => qr/^\d+$/,
1897                                                 },
1898                                          # specific options here
1899                                          merge_with => {type => ARRAYREF|SCALAR,
1900                                                         optional => 1,
1901                                                        },
1902                                          remove   => {type => BOOLEAN,
1903                                                       default => 0,
1904                                                      },
1905                                          force    => {type => BOOLEAN,
1906                                                       default => 0,
1907                                                      },
1908                                          masterbug => {type => BOOLEAN,
1909                                                        default => 0,
1910                                                       },
1911                                          allow_reassign => {type => BOOLEAN,
1912                                                             default => 0,
1913                                                            },
1914                                          reassign_different_sources => {type => BOOLEAN,
1915                                                                         default => 1,
1916                                                                        },
1917                                          %common_options,
1918                                          %append_action_options,
1919                                         },
1920                              );
1921     my @merging = exists $param{merge_with} ? make_list($param{merge_with}):();
1922     my %merging;
1923     @merging{@merging} = (1) x @merging;
1924     if (grep {$_ !~ /^\d+$/} @merging) {
1925         croak "Requested to merge with a non-numeric bug: ".join(',',map {qq('$_');} @merging);
1926     }
1927     $param{locks} = {} if not exists $param{locks};
1928     my %info =
1929         __begin_control(%param,
1930                         command  => 'merge'
1931                        );
1932     my ($debug,$transcript) =
1933         @info{qw(debug transcript)};
1934     if (not @merging and exists $param{merge_with}) {
1935         print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
1936         __end_control(%info);
1937         return;
1938     }
1939     my @data = @{$info{data}};
1940     my @bugs = @{$info{bugs}};
1941     my %data;
1942     my %merged_bugs;
1943     for my $data (@data) {
1944         $data{$data->{bug_num}} = $data;
1945         my @merged_bugs = split / /, $data->{mergedwith};
1946         @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
1947     }
1948     # handle unmerging
1949     my $new_locks = 0;
1950     if (not exists $param{merge_with}) {
1951         my $ok_to_unmerge = 1;
1952         delete $merged_bugs{$param{bug}};
1953         if (not keys %merged_bugs) {
1954             print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n";
1955             __end_control(%info);
1956             return;
1957         }
1958         my $action = "Disconnected #$param{bug} from all other report(s).";
1959         for my $data (@data) {
1960             my $old_data = dclone($data);
1961             if ($data->{bug_num} == $param{bug}) {
1962                 $data->{mergedwith} = '';
1963             }
1964             else {
1965                 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
1966                                             keys %merged_bugs);
1967             }
1968             append_action_to_log(bug => $data->{bug_num},
1969                                  command  => 'merge',
1970                                  new_data => $data,
1971                                  old_data => $old_data,
1972                                  get_lock => 0,
1973                                  __return_append_to_log_options(%param,
1974                                                                 action => $action,
1975                                                                ),
1976                                 )
1977                 if not exists $param{append_log} or $param{append_log};
1978             writebug($data->{bug_num},$data);
1979         }
1980         print {$transcript} "$action\n";
1981         __end_control(%info);
1982         return;
1983     }
1984     # lock and load all of the bugs we need
1985     my @bugs_to_load = keys %merging;
1986     my $bug_to_load;
1987     my %merge_added;
1988     my ($data,$n_locks) =
1989         __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
1990                                     data => \@data,
1991                                     locks => $param{locks},
1992                                     debug => $debug,
1993                                    );
1994     $new_locks += $n_locks;
1995     %data = %{$data};
1996     @data = values %data;
1997     if (not __check_limit(data => [@data],
1998                           exists $param{limit}?(limit => $param{limit}):(),
1999                           transcript => $transcript,
2000                          )) {
2001         die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2002     }
2003     for my $data (@data) {
2004         $data{$data->{bug_num}} = $data;
2005         $merged_bugs{$data->{bug_num}} = 1;
2006         my @merged_bugs = split / /, $data->{mergedwith};
2007         @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
2008         if (exists $param{affected_bugs}) {
2009             $param{affected_bugs}{$data->{bug_num}} = 1;
2010         }
2011     }
2012     __handle_affected_packages(%param,data => [@data]);
2013     my %bug_info_shown; # which bugs have had information shown
2014     $bug_info_shown{$param{bug}} = 1;
2015     add_recipients(data => [@data],
2016                    recipients => $param{recipients},
2017                    (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2018                    debug      => $debug,
2019                    (__internal_request()?(transcript => $transcript):()),
2020                   );
2021
2022     # Figure out what the ideal state is for the bug,
2023     my ($merge_status,$bugs_to_merge) =
2024         __calculate_merge_status(\@data,\%data,$param{bug});
2025     # find out if we actually have any bugs to merge
2026     if (not $bugs_to_merge) {
2027         print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
2028         for (1..$new_locks) {
2029             unfilelock($param{locks});
2030             $locks--;
2031         }
2032         __end_control(%info);
2033         return;
2034     }
2035     # see what changes need to be made to merge the bugs
2036     # check to make sure that the set of changes we need to make is allowed
2037     my ($disallowed_changes,$changes) =
2038         __calculate_merge_changes(\@data,$merge_status,\%param);
2039     # at this point, stop if there are disallowed changes, otherwise
2040     # make the allowed changes, and then reread the bugs in question
2041     # to get the new data, then recaculate the merges; repeat
2042     # reloading and recalculating until we try too many times or there
2043     # are no changes to make.
2044
2045     my $attempts = 0;
2046     # we will allow at most 4 times through this; more than 1
2047     # shouldn't really happen.
2048     my %bug_changed;
2049     while ($attempts < 4 and (@{$disallowed_changes} or keys %{$changes})) {
2050         if ($attempts > 1) {
2051             print {$transcript} "Unable to complete merge on previous attempt; trying again (retry: $attempts)\n";
2052         }
2053         if (@{$disallowed_changes}) {
2054             # figure out the problems
2055             print {$transcript} "Unable to merge bugs because:\n";
2056             for my $change (@{$disallowed_changes}) {
2057                 print {$transcript} "$change->{field} of #$change->{bug} is '$change->{orig_value}' not '$change->{value}'\n";
2058             }
2059             if ($attempts > 0) {
2060                 croak "Some bugs were altered while attempting to merge";
2061             }
2062             else {
2063                 croak "Did not alter merged bugs";
2064             }
2065         }
2066         my ($change_bug) = keys %{$changes};
2067         $bug_changed{$change_bug}++;
2068         print {$transcript} __bug_info($data{$change_bug}) if
2069             $param{show_bug_info} and not __internal_request(1);
2070         $bug_info_shown{$change_bug} = 1;
2071         __allow_relocking($param{locks},[keys %data]);
2072         for my $change (@{$changes->{$change_bug}}) {
2073             if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') {
2074                 my %target_blockedby;
2075                 @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}};
2076                 my %unhandled_targets = %target_blockedby;
2077                 my @blocks_to_remove;
2078                 for my $key (split / /,$change->{orig_value}) {
2079                     delete $unhandled_targets{$key};
2080                     next if exists $target_blockedby{$key};
2081                     set_blocks(bug    => $change->{field} eq 'blocks' ? $key : $change->{bug},
2082                                block  => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2083                                remove => 1,
2084                                hash_slice(%param,
2085                                           keys %common_options,
2086                                           keys %append_action_options),
2087                               );
2088                 }
2089                 for my $key (keys %unhandled_targets) {
2090                     set_blocks(bug    => $change->{field} eq 'blocks' ? $key : $change->{bug},
2091                                block  => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2092                                add   => 1,
2093                                hash_slice(%param,
2094                                           keys %common_options,
2095                                           keys %append_action_options),
2096                               );
2097                 }
2098             }
2099             else {
2100                 $change->{function}->(bug => $change->{bug},
2101                                       $change->{key}, $change->{func_value},
2102                                       exists $change->{options}?@{$change->{options}}:(),
2103                                       hash_slice(%param,
2104                                                  keys %common_options,
2105                                                  keys %append_action_options),
2106                                      );
2107             }
2108         }
2109         __disallow_relocking($param{locks});
2110         my ($data,$n_locks) =
2111             __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2112                                         data => \@data,
2113                                         locks => $param{locks},
2114                                         debug => $debug,
2115                                         reload_all => 1,
2116                                        );
2117         $new_locks += $n_locks;
2118         $locks += $n_locks;
2119         %data = %{$data};
2120         @data = values %data;
2121         ($merge_status,$bugs_to_merge) =
2122             __calculate_merge_status(\@data,\%data,$param{bug});
2123         ($disallowed_changes,$changes) =
2124             __calculate_merge_changes(\@data,$merge_status,\%param);
2125         $attempts = max(values %bug_changed);
2126     }
2127     if ($param{show_bug_info} and not __internal_request(1)) {
2128         for my $data (sort {$a->{bug_num} <=> $b->{bug_num}} @data) {
2129             next if $bug_info_shown{$data->{bug_num}};
2130             print {$transcript} __bug_info($data);
2131         }
2132     }
2133     if (keys %{$changes} or @{$disallowed_changes}) {
2134         print {$transcript} "Unable to modify bugs so that they could be merged\n";
2135         for (1..$new_locks) {
2136             unfilelock($param{locks});
2137             $locks--;
2138         }
2139         __end_control(%info);
2140         return;
2141     }
2142
2143     # finally, we can merge the bugs
2144     my $action = "Merged ".join(' ',sort keys %merged_bugs);
2145     for my $data (@data) {
2146         my $old_data = dclone($data);
2147         $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
2148                                     keys %merged_bugs);
2149         append_action_to_log(bug => $data->{bug_num},
2150                              command  => 'merge',
2151                              new_data => $data,
2152                              old_data => $old_data,
2153                              get_lock => 0,
2154                              __return_append_to_log_options(%param,
2155                                                             action => $action,
2156                                                            ),
2157                             )
2158             if not exists $param{append_log} or $param{append_log};
2159         writebug($data->{bug_num},$data);
2160     }
2161     print {$transcript} "$action\n";
2162     # unlock the extra locks that we got earlier
2163     for (1..$new_locks) {
2164         unfilelock($param{locks});
2165         $locks--;
2166     }
2167     __end_control(%info);
2168 }
2169
2170 sub __allow_relocking{
2171     my ($locks,$bugs) = @_;
2172
2173     for my $bug (@{$bugs}) {
2174         my @lockfiles = grep {m{/\Q$bug\E$}} keys %{$locks->{locks}};
2175         next unless @lockfiles;
2176         $locks->{relockable}{$lockfiles[0]} = 0;
2177     }
2178 }
2179
2180 sub __disallow_relocking{
2181     my ($locks) = @_;
2182     delete $locks->{relockable};
2183 }
2184
2185 sub __lock_and_load_merged_bugs{
2186     my %param =
2187         validate_with(params => \@_,
2188                       spec =>
2189                       {bugs_to_load => {type => ARRAYREF,
2190                                         default => sub {[]},
2191                                        },
2192                        data         => {type => HASHREF|ARRAYREF,
2193                                        },
2194                        locks        => {type => HASHREF,
2195                                         default => sub {{};},
2196                                        },
2197                        reload_all => {type => BOOLEAN,
2198                                       default => 0,
2199                                      },
2200                        debug           => {type => HANDLE,
2201                                           },
2202                       },
2203                      );
2204     my %data;
2205     my $new_locks = 0;
2206     if (ref($param{data}) eq 'ARRAY') {
2207         for my $data (@{$param{data}}) {
2208             $data{$data->{bug_num}} = dclone($data);
2209         }
2210     }
2211     else {
2212         %data = %{dclone($param{data})};
2213     }
2214     my @bugs_to_load = @{$param{bugs_to_load}};
2215     if ($param{reload_all}) {
2216         push @bugs_to_load, keys %data;
2217     }
2218     my %temp;
2219     @temp{@bugs_to_load} = (1) x @bugs_to_load;
2220     @bugs_to_load = keys %temp;
2221     my %loaded_this_time;
2222     my $bug_to_load;
2223     while ($bug_to_load = shift @bugs_to_load) {
2224         if (not $param{reload_all}) {
2225             next if exists $data{$bug_to_load};
2226         }
2227         else {
2228             next if $loaded_this_time{$bug_to_load};
2229         }
2230         my $lock_bug = 1;
2231         if ($param{reload_all}) {
2232             if (exists $data{$bug_to_load}) {
2233                 $lock_bug = 0;
2234             }
2235         }
2236         my $data =
2237             read_bug(bug => $bug_to_load,
2238                      lock => $lock_bug,
2239                      locks => $param{locks},
2240                     ) or
2241                         die "Unable to load bug $bug_to_load";
2242         print {$param{debug}} "read bug $bug_to_load\n";
2243         $data{$data->{bug_num}} = $data;
2244         $new_locks += $lock_bug;
2245         $loaded_this_time{$data->{bug_num}} = 1;
2246         push @bugs_to_load,
2247             grep {not exists $data{$_}}
2248                 split / /,$data->{mergedwith};
2249     }
2250     return (\%data,$new_locks);
2251 }
2252
2253
2254 sub __calculate_merge_status{
2255     my ($data_a,$data_h,$master_bug,$merge) = @_;
2256     my %merge_status;
2257     my %merged_bugs;
2258     my $bugs_to_merge = 0;
2259     for my $data (@{$data_a}) {
2260         # check to see if this bug is unmerged in the set
2261         if (not length $data->{mergedwith} or
2262             grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) {
2263             $merged_bugs{$data->{bug_num}} = 1;
2264             $bugs_to_merge = 1;
2265         }
2266         # the master_bug is the bug that every other bug is made to
2267         # look like. However, if merge is set, tags, fixed and found
2268         # are merged.
2269         if ($data->{bug_num} == $master_bug) {
2270             for (qw(package forwarded severity blocks blockedby done owner summary affects)) {
2271                 $merge_status{$_} = $data->{$_}
2272             }
2273         }
2274         if (not $merge) {
2275             next unless $data->{bug_num} == $master_bug;
2276         }
2277         $merge_status{tag} = {} if not exists $merge_status{tag};
2278         for my $tag (split /\s+/, $data->{keywords}) {
2279             $merge_status{tag}{$tag} = 1;
2280         }
2281         $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}});
2282         for (qw(fixed found)) {
2283             @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}};
2284         }
2285     }
2286     return (\%merge_status,$bugs_to_merge);
2287 }
2288
2289
2290
2291 sub __calculate_merge_changes{
2292     my ($datas,$merge_status,$param) = @_;
2293     my %changes;
2294     my @disallowed_changes;
2295     for my $data (@{$datas}) {
2296         # things that can be forced
2297         #
2298         # * func is the function to set the new value
2299         #
2300         # * key is the key of the function to set the value,
2301
2302         # * modify_value is a function which is called to modify the new
2303         # value so that the function will accept it
2304
2305         # * options is an ARRAYREF of options to pass to the function
2306
2307         # * allowed is a BOOLEAN which controls whether this setting
2308         # is allowed to be different by default.
2309         my %force_functions =
2310             (forwarded => {func => \&set_forwarded,
2311                            key  => 'forwarded',
2312                            options => [],
2313                           },
2314              severity  => {func => \&set_severity,
2315                            key  => 'severity',
2316                            options => [],
2317                           },
2318              blocks    => {func => \&set_blocks,
2319                            modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2320                            key  => 'block',
2321                            options => [],
2322                           },
2323              blockedby => {func => \&set_blocks,
2324                            modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2325                            key  => 'block',
2326                            options => [],
2327                           },
2328              done      => {func => \&set_done,
2329                            key  => 'done',
2330                            options => [],
2331                           },
2332              owner     => {func => \&owner,
2333                            key  => 'owner',
2334                            options => [],
2335                           },
2336              summary   => {func => \&summary,
2337                            key  => 'summary',
2338                            options => [],
2339                           },
2340              affects   => {func => \&affects,
2341                            key  => 'package',
2342                            options => [],
2343                           },
2344              package   => {func => \&set_package,
2345                            key  => 'package',
2346                            options => [],
2347                           },
2348              keywords   => {func => \&set_tag,
2349                             key  => 'tag',
2350                             modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]},
2351                             allowed => 1,
2352                            },
2353              fixed_versions => {func => \&set_fixed,
2354                                 key => 'fixed',
2355                                 allowed => 1,
2356                                },
2357              found_versions => {func => \&set_found,
2358                                 key   => 'found',
2359                                 allowed => 1,
2360                                },
2361             );
2362         for my $field (qw(forwarded severity blocks blockedby done owner summary affects package fixed_versions found_versions keywords)) {
2363             # if the ideal bug already has the field set properly, we
2364             # continue on.
2365             if ($field eq 'keywords'){
2366                 next if join(' ',sort split /\s+/,$data->{keywords}) eq
2367                     join(' ',sort keys %{$merge_status->{tag}});
2368             }
2369             elsif ($field =~ /^(?:fixed|found)_versions$/) {
2370                 next if join(' ', sort @{$data->{$field}}) eq
2371                     join(' ',sort keys %{$merge_status->{$field}});
2372             }
2373             elsif ($merge_status->{$field} eq $data->{$field}) {
2374                 next;
2375             }
2376             my $change =
2377                 {field => $field,
2378                  bug => $data->{bug_num},
2379                  orig_value => $data->{$field},
2380                  func_value   =>
2381                  (exists $force_functions{$field}{modify_value} ?
2382                   $force_functions{$field}{modify_value}->($merge_status->{$field}):
2383                   $merge_status->{$field}),
2384                  value    => $merge_status->{$field},
2385                  function => $force_functions{$field}{func},
2386                  key      => $force_functions{$field}{key},
2387                  options  => $force_functions{$field}{options},
2388                  allowed  => exists $force_functions{$field}{allowed} ? 0 : $force_functions{$field}{allowed},
2389                 };
2390             if ($param->{force}) {
2391                 if ($field ne 'package') {
2392                     push @{$changes{$data->{bug_num}}},$change;
2393                     next;
2394                 }
2395                 if ($param->{allow_reassign}) {
2396                     if ($param->{reassign_different_sources}) {
2397                         push @{$changes{$data->{bug_num}}},$change;
2398                         next;
2399                     }
2400                     # allow reassigning if binary_to_source returns at
2401                     # least one of the same source packages
2402                     my @merge_status_source =
2403                         binary_to_source(package => $merge_status->{package},
2404                                          source_only => 1,
2405                                         );
2406                     my @other_bug_source =
2407                         binary_to_source(package => $data->{package},
2408                                          source_only => 1,
2409                                         );
2410                     my %merge_status_sources;
2411                     @merge_status_sources{@merge_status_source} =
2412                         (1) x @merge_status_source;
2413                     if (grep {$merge_status_sources{$_}} @other_bug_source) {
2414                         push @{$changes{$data->{bug_num}}},$change;
2415                         next;
2416                     }
2417                 }
2418             }
2419             push @disallowed_changes,$change;
2420         }
2421         # blocks and blocked by are weird; we have to go through and
2422         # set blocks to the other half of the merged bugs
2423     }
2424     return (\@disallowed_changes,\%changes);
2425 }
2426
2427 =head2 affects
2428
2429      eval {
2430             affects(bug          => $ref,
2431                     transcript   => $transcript,
2432                     ($dl > 0 ? (debug => $transcript):()),
2433                     requester    => $header{from},
2434                     request_addr => $controlrequestaddr,
2435                     message      => \@log,
2436                     affected_packages => \%affected_packages,
2437                     recipients   => \%recipients,
2438                     packages     => undef,
2439                     add          => 1,
2440                     remove       => 0,
2441                    );
2442         };
2443         if ($@) {
2444             $errors++;
2445             print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2446         }
2447
2448 This marks a bug as affecting packages which the bug is not actually
2449 in. This should only be used in cases where fixing the bug instantly
2450 resolves the problem in the other packages.
2451
2452 By default, the packages are set to the list of packages passed.
2453 However, if you pass add => 1 or remove => 1, the list of packages
2454 passed are added or removed from the affects list, respectively.
2455
2456 =cut
2457
2458 sub affects {
2459     my %param = validate_with(params => \@_,
2460                               spec   => {bug => {type   => SCALAR,
2461                                                  regex  => qr/^\d+$/,
2462                                                 },
2463                                          # specific options here
2464                                          package => {type => SCALAR|ARRAYREF|UNDEF,
2465                                                      default => [],
2466                                                     },
2467                                          add      => {type => BOOLEAN,
2468                                                       default => 0,
2469                                                      },
2470                                          remove   => {type => BOOLEAN,
2471                                                       default => 0,
2472                                                      },
2473                                          %common_options,
2474                                          %append_action_options,
2475                                         },
2476                              );
2477     if ($param{add} and $param{remove}) {
2478          croak "Asking to both add and remove affects is nonsensical";
2479     }
2480     if (not defined $param{package}) {
2481         $param{package} = [];
2482     }
2483     my %info =
2484         __begin_control(%param,
2485                         command  => 'affects'
2486                        );
2487     my ($debug,$transcript) =
2488         @info{qw(debug transcript)};
2489     my @data = @{$info{data}};
2490     my @bugs = @{$info{bugs}};
2491     my $action = '';
2492     for my $data (@data) {
2493         $action = '';
2494          print {$debug} "Going to change affects\n";
2495          my @packages = splitpackages($data->{affects});
2496          my %packages;
2497          @packages{@packages} = (1) x @packages;
2498          if ($param{add}) {
2499               my @added = ();
2500               for my $package (make_list($param{package})) {
2501                   next unless defined $package and length $package;
2502                   if (not $packages{$package}) {
2503                       $packages{$package} = 1;
2504                       push @added,$package;
2505                   }
2506               }
2507               if (@added) {
2508                    $action = "Added indication that $data->{bug_num} affects ".
2509                         english_join(\@added);
2510               }
2511          }
2512          elsif ($param{remove}) {
2513               my @removed = ();
2514               for my $package (make_list($param{package})) {
2515                    if ($packages{$package}) {
2516                        next unless defined $package and length $package;
2517                         delete $packages{$package};
2518                         push @removed,$package;
2519                    }
2520               }
2521               $action = "Removed indication that $data->{bug_num} affects " .
2522                    english_join(\@removed);
2523          }
2524          else {
2525               my %added_packages = ();
2526               my %removed_packages = %packages;
2527               %packages = ();
2528               for my $package (make_list($param{package})) {
2529                    next unless defined $package and length $package;
2530                    $packages{$package} = 1;
2531                    delete $removed_packages{$package};
2532                    $added_packages{$package} = 1;
2533               }
2534               if (keys %removed_packages) {
2535                   $action = "Removed indication that $data->{bug_num} affects ".
2536                       english_join([keys %removed_packages]);
2537                   $action .= "\n" if keys %added_packages;
2538               }
2539               if (keys %added_packages) {
2540                   $action .= "Added indication that $data->{bug_num} affects " .
2541                    english_join([keys %added_packages]);
2542               }
2543          }
2544         if (not length $action) {
2545             print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n"
2546                 unless __internal_request();
2547             next;
2548         }
2549          my $old_data = dclone($data);
2550          $data->{affects} = join(',',keys %packages);
2551          append_action_to_log(bug => $data->{bug_num},
2552                               get_lock => 0,
2553                               command => 'affects',
2554                               new_data => $data,
2555                               old_data => $old_data,
2556                               __return_append_to_log_options(
2557                                                              %param,
2558                                                              action => $action,
2559                                                             ),
2560                              )
2561                if not exists $param{append_log} or $param{append_log};
2562           writebug($data->{bug_num},$data);
2563           print {$transcript} "$action\n";
2564      }
2565     __end_control(%info);
2566 }
2567
2568
2569 =head1 SUMMARY FUNCTIONS
2570
2571 =head2 summary
2572
2573      eval {
2574             summary(bug          => $ref,
2575                     transcript   => $transcript,
2576                     ($dl > 0 ? (debug => $transcript):()),
2577                     requester    => $header{from},
2578                     request_addr => $controlrequestaddr,
2579                     message      => \@log,
2580                     affected_packages => \%affected_packages,
2581                     recipients   => \%recipients,
2582                     summary      => undef,
2583                    );
2584         };
2585         if ($@) {
2586             $errors++;
2587             print {$transcript} "Failed to mark $ref with summary foo: $@";
2588         }
2589
2590 Handles all setting of summary fields
2591
2592 If summary is undef, unsets the summary
2593
2594 If summary is 0, sets the summary to the first paragraph contained in
2595 the message passed.
2596
2597 If summary is a positive integer, sets the summary to the message specified.
2598
2599 Otherwise, sets summary to the value passed.
2600
2601 =cut
2602
2603
2604 sub summary {
2605     my %param = validate_with(params => \@_,
2606                               spec   => {bug => {type   => SCALAR,
2607                                                  regex  => qr/^\d+$/,
2608                                                 },
2609                                          # specific options here
2610                                          summary => {type => SCALAR|UNDEF,
2611                                                      default => 0,
2612                                                     },
2613                                          %common_options,
2614                                          %append_action_options,
2615                                         },
2616                              );
2617 # croak "summary must be numeric or undef" if
2618 #       defined $param{summary} and not $param{summary} =~ /^\d+/;
2619     my %info =
2620         __begin_control(%param,
2621                         command  => 'summary'
2622                        );
2623     my ($debug,$transcript) =
2624         @info{qw(debug transcript)};
2625     my @data = @{$info{data}};
2626     my @bugs = @{$info{bugs}};
2627     # figure out the log that we're going to use
2628     my $summary = '';
2629     my $summary_msg = '';
2630     my $action = '';
2631     if (not defined $param{summary}) {
2632          # do nothing
2633          print {$debug} "Removing summary fields\n";
2634          $action = 'Removed summary';
2635     }
2636     elsif ($param{summary} =~ /^\d+$/) {
2637          my $log = [];
2638          my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2639          if ($param{summary} == 0) {
2640               $log = $param{message};
2641               $summary_msg = @records + 1;
2642          }
2643          else {
2644               if (($param{summary} - 1 ) > $#records) {
2645                    die "Message number '$param{summary}' exceeds the maximum message '$#records'";
2646               }
2647               my $record = $records[($param{summary} - 1 )];
2648               if ($record->{type} !~ /incoming-recv|recips/) {
2649                    die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
2650               }
2651               $summary_msg = $param{summary};
2652               $log = [$record->{text}];
2653          }
2654          my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2655          my $body = $p_o->{body};
2656          my $in_pseudoheaders = 0;
2657          my $paragraph = '';
2658          # walk through body until we get non-blank lines
2659          for my $line (@{$body}) {
2660               if ($line =~ /^\s*$/) {
2661                    if (length $paragraph) {
2662                         if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2663                              $paragraph = '';
2664                              next;
2665                         }
2666                         last;
2667                    }
2668                    $in_pseudoheaders = 0;
2669                    next;
2670               }
2671               # skip a paragraph if it looks like it's control or
2672               # pseudo-headers
2673               if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
2674                   $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2675                                  \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2676                                  debug|(?:not|)forwarded|priority|
2677                                  (?:un|)block|limit|(?:un|)archive|
2678                                  reassign|retitle|affects|wrongpackage
2679                                  (?:un|force|)merge|user(?:category|tags?|)
2680                              )\s+\S}xis) {
2681                    if (not length $paragraph) {
2682                         print {$debug} "Found control/pseudo-headers and skiping them\n";
2683                         $in_pseudoheaders = 1;
2684                         next;
2685                    }
2686               }
2687               next if $in_pseudoheaders;
2688               $paragraph .= $line ." \n";
2689          }
2690          print {$debug} "Summary is going to be '$paragraph'\n";
2691          $summary = $paragraph;
2692          $summary =~ s/[\n\r]/ /g;
2693          if (not length $summary) {
2694               die "Unable to find summary message to use";
2695          }
2696          # trim off a trailing spaces
2697          $summary =~ s/\ *$//;
2698     }
2699     else {
2700         $summary = $param{summary};
2701     }
2702     for my $data (@data) {
2703          print {$debug} "Going to change summary\n";
2704          if (((not defined $summary or not length $summary) and
2705               (not defined $data->{summary} or not length $data->{summary})) or
2706              $summary eq $data->{summary}) {
2707              print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n"
2708                  unless __internal_request();
2709              next;
2710          }
2711          if (length $summary) {
2712               if (length $data->{summary}) {
2713                    $action = "Summary replaced with message bug $param{bug} message $summary_msg";
2714               }
2715               else {
2716                    $action = "Summary recorded from message bug $param{bug} message $summary_msg";
2717               }
2718          }
2719          my $old_data = dclone($data);
2720          $data->{summary} = $summary;
2721          append_action_to_log(bug => $data->{bug_num},
2722                               command => 'summary',
2723                               old_data => $old_data,
2724                               new_data => $data,
2725                               get_lock => 0,
2726                               __return_append_to_log_options(
2727                                                              %param,
2728                                                              action => $action,
2729                                                             ),
2730                              )
2731                if not exists $param{append_log} or $param{append_log};
2732           writebug($data->{bug_num},$data);
2733           print {$transcript} "$action\n";
2734      }
2735     __end_control(%info);
2736 }
2737
2738
2739
2740
2741
2742
2743 =head1 OWNER FUNCTIONS
2744
2745 =head2 owner
2746
2747      eval {
2748             owner(bug          => $ref,
2749                   transcript   => $transcript,
2750                   ($dl > 0 ? (debug => $transcript):()),
2751                   requester    => $header{from},
2752                   request_addr => $controlrequestaddr,
2753                   message      => \@log,
2754                   recipients   => \%recipients,
2755                   owner        => undef,
2756                  );
2757         };
2758         if ($@) {
2759             $errors++;
2760             print {$transcript} "Failed to mark $ref as having an owner: $@";
2761         }
2762
2763 Handles all setting of the owner field; given an owner of undef or of
2764 no length, indicates that a bug is not owned by anyone.
2765
2766 =cut
2767
2768 sub owner {
2769      my %param = validate_with(params => \@_,
2770                                spec   => {bug => {type   => SCALAR,
2771                                                   regex  => qr/^\d+$/,
2772                                                  },
2773                                           owner => {type => SCALAR|UNDEF,
2774                                                    },
2775                                           %common_options,
2776                                           %append_action_options,
2777                                          },
2778                               );
2779      my %info =
2780          __begin_control(%param,
2781                          command  => 'owner',
2782                         );
2783      my ($debug,$transcript) =
2784         @info{qw(debug transcript)};
2785      my @data = @{$info{data}};
2786      my @bugs = @{$info{bugs}};
2787      my $action = '';
2788      for my $data (@data) {
2789           print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2790           print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2791           if (not defined $param{owner} or not length $param{owner}) {
2792               if (not defined $data->{owner} or not length $data->{owner}) {
2793                   print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n"
2794                       unless __internal_request();
2795                   next;
2796               }
2797               $param{owner} = '';
2798               $action = "Removed annotation that $config{bug} was owned by " .
2799                   "$data->{owner}.";
2800           }
2801           else {
2802               if ($data->{owner} eq $param{owner}) {
2803                   print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2804                   next;
2805               }
2806               if (length $data->{owner}) {
2807                   $action = "Owner changed from $data->{owner} to $param{owner}.";
2808               }
2809               else {
2810                   $action = "Owner recorded as $param{owner}."
2811               }
2812           }
2813           my $old_data = dclone($data);
2814           $data->{owner} = $param{owner};
2815           append_action_to_log(bug => $data->{bug_num},
2816                                command => 'owner',
2817                                new_data => $data,
2818                                old_data => $old_data,
2819                                get_lock => 0,
2820                __return_append_to_log_options(
2821                                               %param,
2822                                               action => $action,
2823                                              ),
2824                               )
2825                if not exists $param{append_log} or $param{append_log};
2826           writebug($data->{bug_num},$data);
2827           print {$transcript} "$action\n";
2828      }
2829      __end_control(%info);
2830 }
2831
2832
2833 =head1 ARCHIVE FUNCTIONS
2834
2835
2836 =head2 bug_archive
2837
2838      my $error = '';
2839      eval {
2840         bug_archive(bug => $bug_num,
2841                     debug => \$debug,
2842                     transcript => \$transcript,
2843                    );
2844      };
2845      if ($@) {
2846         $errors++;
2847         transcript("Unable to archive $bug_num\n");
2848         warn $@;
2849      }
2850      transcript($transcript);
2851
2852
2853 This routine archives a bug
2854
2855 =over
2856
2857 =item bug -- bug number
2858
2859 =item check_archiveable -- check wether a bug is archiveable before
2860 archiving; defaults to 1
2861
2862 =item archive_unarchived -- whether to archive bugs which have not
2863 previously been archived; defaults to 1. [Set to 0 when used from
2864 control@]
2865
2866 =item ignore_time -- whether to ignore time constraints when archiving
2867 a bug; defaults to 0.
2868
2869 =back
2870
2871 =cut
2872
2873 sub bug_archive {
2874      my %param = validate_with(params => \@_,
2875                                spec   => {bug => {type   => SCALAR,
2876                                                   regex  => qr/^\d+$/,
2877                                                  },
2878                                           check_archiveable => {type => BOOLEAN,
2879                                                                 default => 1,
2880                                                                },
2881                                           archive_unarchived => {type => BOOLEAN,
2882                                                                  default => 1,
2883                                                                 },
2884                                           ignore_time => {type => BOOLEAN,
2885                                                           default => 0,
2886                                                          },
2887                                           %common_options,
2888                                           %append_action_options,
2889                                          },
2890                               );
2891      my %info = __begin_control(%param,
2892                                 command => 'archive',
2893                                 );
2894      my ($debug,$transcript) = @info{qw(debug transcript)};
2895      my @data = @{$info{data}};
2896      my @bugs = @{$info{bugs}};
2897      my $action = "$config{bug} archived.";
2898      if ($param{check_archiveable} and
2899          not bug_archiveable(bug=>$param{bug},
2900                              ignore_time => $param{ignore_time},
2901                             )) {
2902           print {$transcript} "Bug $param{bug} cannot be archived\n";
2903           die "Bug $param{bug} cannot be archived";
2904      }
2905      print {$debug} "$param{bug} considering\n";
2906      if (not $param{archive_unarchived} and
2907          not exists $data[0]{unarchived}
2908         ) {
2909           print {$transcript} "$param{bug} has not been archived previously\n";
2910           die "$param{bug} has not been archived previously";
2911      }
2912      add_recipients(recipients => $param{recipients},
2913                     data => \@data,
2914                     debug      => $debug,
2915                     transcript => $transcript,
2916                    );
2917      print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
2918      for my $bug (@bugs) {
2919          if ($param{check_archiveable}) {
2920              die "Bug $bug cannot be archived (but $param{bug} can?)"
2921                  unless bug_archiveable(bug=>$bug,
2922                                         ignore_time => $param{ignore_time},
2923                                        );
2924          }
2925      }
2926      # If we get here, we can archive/remove this bug
2927      print {$debug} "$param{bug} removing\n";
2928      for my $bug (@bugs) {
2929           #print "$param{bug} removing $bug\n" if $debug;
2930           my $dir = get_hashname($bug);
2931           # First indicate that this bug is being archived
2932           append_action_to_log(bug => $bug,
2933                                get_lock => 0,
2934                                command => 'archive',
2935                                # we didn't actually change the data
2936                                # when we archived, so we don't pass
2937                                # a real new_data or old_data
2938                                new_data => {},
2939                                old_data => {},
2940                                __return_append_to_log_options(
2941                                  %param,
2942                                  action => $action,
2943                                 )
2944                               )
2945                if not exists $param{append_log} or $param{append_log};
2946           my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
2947           if ($config{save_old_bugs}) {
2948                mkpath("$config{spool_dir}/archive/$dir");
2949                foreach my $file (@files_to_remove) {
2950                    link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2951                        copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
2952                            # we need to bail out here if things have
2953                            # gone horribly wrong to avoid removing a
2954                            # bug altogether
2955                            die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
2956                }
2957
2958                print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
2959           }
2960           unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
2961           print {$transcript} "deleted $bug (from $param{bug})\n";
2962      }
2963      bughook_archive(@bugs);
2964      __end_control(%info);
2965 }
2966
2967 =head2 bug_unarchive
2968
2969      my $error = '';
2970      eval {
2971         bug_unarchive(bug => $bug_num,
2972                       debug => \$debug,
2973                       transcript => \$transcript,
2974                      );
2975      };
2976      if ($@) {
2977         $errors++;
2978         transcript("Unable to archive bug: $bug_num");
2979      }
2980      transcript($transcript);
2981
2982 This routine unarchives a bug
2983
2984 =cut
2985
2986 sub bug_unarchive {
2987      my %param = validate_with(params => \@_,
2988                                spec   => {bug => {type   => SCALAR,
2989                                                   regex  => qr/^\d+/,
2990                                                  },
2991                                           %common_options,
2992                                           %append_action_options,
2993                                          },
2994                               );
2995
2996      my %info = __begin_control(%param,
2997                                 archived=>1,
2998                                 command=>'unarchive');
2999      my ($debug,$transcript) =
3000          @info{qw(debug transcript)};
3001      my @data = @{$info{data}};
3002      my @bugs = @{$info{bugs}};
3003      my $action = "$config{bug} unarchived.";
3004      my @files_to_remove;
3005      for my $bug (@bugs) {
3006           print {$debug} "$param{bug} removing $bug\n";
3007           my $dir = get_hashname($bug);
3008           my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3009           mkpath("archive/$dir");
3010           foreach my $file (@files_to_copy) {
3011                # die'ing here sucks
3012                link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3013                     copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3014                          die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3015           }
3016           push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3017           print {$transcript} "Unarchived $config{bug} $bug\n";
3018      }
3019      unlink(@files_to_remove) or die "Unable to unlink bugs";
3020      # Indicate that this bug has been archived previously
3021      for my $bug (@bugs) {
3022           my $newdata = readbug($bug);
3023           my $old_data = dclone($newdata);
3024           if (not defined $newdata) {
3025                print {$transcript} "$config{bug} $bug disappeared!\n";
3026                die "Bug $bug disappeared!";
3027           }
3028           $newdata->{unarchived} = time;
3029           append_action_to_log(bug => $bug,
3030                                get_lock => 0,
3031                                command => 'unarchive',
3032                                new_data => $newdata,
3033                                old_data => $old_data,
3034                                __return_append_to_log_options(
3035                                  %param,
3036                                  action => $action,
3037                                 )
3038                               )
3039                if not exists $param{append_log} or $param{append_log};
3040           writebug($bug,$newdata);
3041      }
3042      __end_control(%info);
3043 }
3044
3045 =head2 append_action_to_log
3046
3047      append_action_to_log
3048
3049 This should probably be moved to Debbugs::Log; have to think that out
3050 some more.
3051
3052 =cut
3053
3054 sub append_action_to_log{
3055      my %param = validate_with(params => \@_,
3056                                spec   => {bug => {type   => SCALAR,
3057                                                   regex  => qr/^\d+/,
3058                                                  },
3059                                           new_data => {type => HASHREF,
3060                                                        optional => 1,
3061                                                       },
3062                                           old_data => {type => HASHREF,
3063                                                        optional => 1,
3064                                                       },
3065                                           command  => {type => SCALAR,
3066                                                        optional => 1,
3067                                                       },
3068                                           action => {type => SCALAR,
3069                                                     },
3070                                           requester => {type => SCALAR,
3071                                                         default => '',
3072                                                        },
3073                                           request_addr => {type => SCALAR,
3074                                                            default => '',
3075                                                           },
3076                                           location => {type => SCALAR,
3077                                                        optional => 1,
3078                                                       },
3079                                           message  => {type => SCALAR|ARRAYREF,
3080                                                        default => '',
3081                                                       },
3082                                           recips   => {type => SCALAR|ARRAYREF,
3083                                                        optional => 1
3084                                                       },
3085                                           desc       => {type => SCALAR,
3086                                                          default => '',
3087                                                         },
3088                                           get_lock   => {type => BOOLEAN,
3089                                                          default => 1,
3090                                                         },
3091                                           locks      => {type => HASHREF,
3092                                                          optional => 1,
3093                                                         },
3094                                           # we don't use
3095                                           # append_action_options here
3096                                           # because some of these
3097                                           # options aren't actually
3098                                           # optional, even though the
3099                                           # original function doesn't
3100                                           # require them
3101                                          },
3102                               );
3103      # Fix this to use $param{location}
3104      my $log_location = buglog($param{bug});
3105      die "Unable to find .log for $param{bug}"
3106           if not defined $log_location;
3107      if ($param{get_lock}) {
3108           filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3109           $locks++;
3110      }
3111      my @records;
3112      my $logfh = IO::File->new(">>$log_location") or
3113          die "Unable to open $log_location for appending: $!";
3114      # determine difference between old and new
3115      my $data_diff = '';
3116      if (exists $param{old_data} and exists $param{new_data}) {
3117          my $old_data = dclone($param{old_data});
3118          my $new_data = dclone($param{new_data});
3119          for my $key (keys %{$old_data}) {
3120              if (not exists $Debbugs::Status::fields{$key}) {
3121                  delete $old_data->{$key};
3122                  next;
3123              }
3124              next unless exists $new_data->{$key};
3125              next unless defined $new_data->{$key};
3126              if (not defined $old_data->{$key}) {
3127                  delete $old_data->{$key};
3128                  next;
3129              }
3130              if (ref($new_data->{$key}) and
3131                  ref($old_data->{$key}) and
3132                  ref($new_data->{$key}) eq ref($old_data->{$key})) {
3133                 local $Storable::canonical = 1;
3134                 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3135                     delete $new_data->{$key};
3136                     delete $old_data->{$key};
3137                 }
3138              }
3139              elsif ($new_data->{$key} eq $old_data->{$key}) {
3140                  delete $new_data->{$key};
3141                  delete $old_data->{$key};
3142              }
3143          }
3144          for my $key (keys %{$new_data}) {
3145              if (not exists $Debbugs::Status::fields{$key}) {
3146                  delete $new_data->{$key};
3147                  next;
3148              }
3149              next unless exists $old_data->{$key};
3150              next unless defined $old_data->{$key};
3151              if (not defined $new_data->{$key} or
3152                  not exists $Debbugs::Status::fields{$key}) {
3153                  delete $new_data->{$key};
3154                  next;
3155              }
3156              if (ref($new_data->{$key}) and
3157                  ref($old_data->{$key}) and
3158                  ref($new_data->{$key}) eq ref($old_data->{$key})) {
3159                 local $Storable::canonical = 1;
3160                 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3161                     delete $new_data->{$key};
3162                     delete $old_data->{$key};
3163                 }
3164              }
3165              elsif ($new_data->{$key} eq $old_data->{$key}) {
3166                  delete $new_data->{$key};
3167                  delete $old_data->{$key};
3168              }
3169          }
3170          $data_diff .= "<!-- new_data:\n";
3171          my %nd;
3172          for my $key (keys %{$new_data}) {
3173              if (not exists $Debbugs::Status::fields{$key}) {
3174                  warn "No such field $key";
3175                  next;
3176              }
3177              $nd{$key} = $new_data->{$key};
3178              # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3179          }
3180          $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
3181          $data_diff .= "-->\n";
3182          $data_diff .= "<!-- old_data:\n";
3183          my %od;
3184          for my $key (keys %{$old_data}) {
3185              if (not exists $Debbugs::Status::fields{$key}) {
3186                  warn "No such field $key";
3187                  next;
3188              }
3189              $od{$key} = $old_data->{$key};
3190              # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3191          }
3192          $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
3193          $data_diff .= "-->\n";
3194      }
3195      my $msg = join('',
3196                     (exists $param{command} ?
3197                      "<!-- command:".html_escape($param{command})." -->\n":""
3198                     ),
3199                     (length $param{requester} ?
3200                      "<!-- requester: ".html_escape($param{requester})." -->\n":""
3201                     ),
3202                     (length $param{request_addr} ?
3203                      "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
3204                     ),
3205                     "<!-- time:".time()." -->\n",
3206                     $data_diff,
3207                     "<strong>".html_escape($param{action})."</strong>\n");
3208      if (length $param{requester}) {
3209           $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
3210      }
3211      if (length $param{request_addr}) {
3212           $msg .= "to <code>".html_escape($param{request_addr})."</code>";
3213      }
3214      if (length $param{desc}) {
3215           $msg .= ":<br>\n$param{desc}\n";
3216      }
3217      else {
3218           $msg .= ".\n";
3219      }
3220      push @records, {type => 'html',
3221                      text => $msg,
3222                     };
3223      $msg = '';
3224      if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3225          push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3226                          exists $param{recips}?(recips => [make_list($param{recips})]):(),
3227                          text => join('',make_list($param{message})),
3228                         };
3229      }
3230      write_log_records(logfh=>$logfh,
3231                        records => \@records,
3232                       );
3233      close $logfh or die "Unable to close $log_location: $!";
3234      if ($param{get_lock}) {
3235           unfilelock(exists $param{locks}?$param{locks}:());
3236           $locks--;
3237      }
3238
3239
3240 }
3241
3242
3243 =head1 PRIVATE FUNCTIONS
3244
3245 =head2 __handle_affected_packages
3246
3247      __handle_affected_packages(affected_packages => {},
3248                                 data => [@data],
3249                                )
3250
3251
3252
3253 =cut
3254
3255 sub __handle_affected_packages{
3256      my %param = validate_with(params => \@_,
3257                                spec   => {%common_options,
3258                                           data => {type => ARRAYREF|HASHREF
3259                                                   },
3260                                          },
3261                                allow_extra => 1,
3262                               );
3263      for my $data (make_list($param{data})) {
3264           next unless exists $data->{package} and defined $data->{package};
3265           my @packages = split /\s*,\s*/,$data->{package};
3266           @{$param{affected_packages}}{@packages} = (1) x @packages;
3267       }
3268 }
3269
3270 =head2 __handle_debug_transcript
3271
3272      my ($debug,$transcript) = __handle_debug_transcript(%param);
3273
3274 Returns a debug and transcript filehandle
3275
3276
3277 =cut
3278
3279 sub __handle_debug_transcript{
3280      my %param = validate_with(params => \@_,
3281                                spec   => {%common_options},
3282                                allow_extra => 1,
3283                               );
3284      my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3285      my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3286      return ($debug,$transcript);
3287 }
3288
3289 =head2 __bug_info
3290
3291      __bug_info($data)
3292
3293 Produces a small bit of bug information to kick out to the transcript
3294
3295 =cut
3296
3297 sub __bug_info{
3298      my $return = '';
3299      for my $data (@_) {
3300          next unless defined $data and exists $data->{bug_num};
3301           $return .= "Bug #".($data->{bug_num}||'').
3302               ((defined $data->{done} and length $data->{done})?
3303                 " {Done: $data->{done}}":''
3304                ).
3305                " [".($data->{package}||'(no package)'). "] ".
3306                     ($data->{subject}||'(no subject)')."\n";
3307      }
3308      return $return;
3309 }
3310
3311
3312 =head2 __internal_request
3313
3314      __internal_request()
3315      __internal_request($level)
3316
3317 Returns true if the caller of the function calling __internal_request
3318 belongs to __PACKAGE__
3319
3320 This allows us to be magical, and don't bother to print bug info if
3321 the second caller is from this package, amongst other things.
3322
3323 An optional level is allowed, which increments the number of levels to
3324 check by the given value. [This is basically for use by internal
3325 functions like __begin_control which are always called by
3326 C<__PACKAGE__>.
3327
3328 =cut
3329
3330 sub __internal_request{
3331     my ($l) = @_;
3332     $l = 0 if not defined $l;
3333     if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3334         return 1;
3335     }
3336     return 0;
3337 }
3338
3339 sub __return_append_to_log_options{
3340      my %param = @_;
3341      my $action = $param{action} if exists $param{action};
3342      if (not exists $param{requester}) {
3343           $param{requester} = $config{control_internal_requester};
3344      }
3345      if (not exists $param{request_addr}) {
3346           $param{request_addr} = $config{control_internal_request_addr};
3347      }
3348      if (not exists $param{message}) {
3349           my $date = rfc822_date();
3350           $param{message} = fill_in_template(template  => 'mail/fake_control_message',
3351                                              variables => {request_addr => $param{request_addr},
3352                                                            requester    => $param{requester},
3353                                                            date         => $date,
3354                                                            action       => $action
3355                                                           },
3356                                             );
3357      }
3358      if (not defined $action) {
3359           carp "Undefined action!";
3360           $action = "unknown action";
3361      }
3362      return (action => $action,
3363              hash_slice(%param,keys %append_action_options),
3364             );
3365 }
3366
3367 =head2 __begin_control
3368
3369      my %info = __begin_control(%param,
3370                                 archived=>1,
3371                                 command=>'unarchive');
3372      my ($debug,$transcript) = @info{qw(debug transcript)};
3373      my @data = @{$info{data}};
3374      my @bugs = @{$info{bugs}};
3375
3376
3377 Starts the process of modifying a bug; handles all of the generic
3378 things that almost every control request needs
3379
3380 Returns a hash containing
3381
3382 =over
3383
3384 =item new_locks -- number of new locks taken out by this call
3385
3386 =item debug -- the debug file handle
3387
3388 =item transcript -- the transcript file handle
3389
3390 =item data -- an arrayref containing the data of the bugs
3391 corresponding to this request
3392
3393 =item bugs -- an arrayref containing the bug numbers of the bugs
3394 corresponding to this request
3395
3396 =back
3397
3398 =cut
3399
3400 our $lockhash;
3401
3402 sub __begin_control {
3403     my %param = validate_with(params => \@_,
3404                               spec   => {bug => {type   => SCALAR,
3405                                                  regex  => qr/^\d+/,
3406                                                 },
3407                                          archived => {type => BOOLEAN,
3408                                                       default => 0,
3409                                                      },
3410                                          command  => {type => SCALAR,
3411                                                       optional => 1,
3412                                                      },
3413                                          %common_options,
3414                                         },
3415                               allow_extra => 1,
3416                              );
3417     my $new_locks;
3418     my ($debug,$transcript) = __handle_debug_transcript(@_);
3419     print {$debug} "$param{bug} considering\n";
3420     $lockhash = $param{locks} if exists $param{locks};
3421     my @data = ();
3422     my $old_die = $SIG{__DIE__};
3423     $SIG{__DIE__} = *sig_die{CODE};
3424
3425     ($new_locks, @data) =
3426         lock_read_all_merged_bugs(bug => $param{bug},
3427                                   $param{archived}?(location => 'archive'):(),
3428                                   exists $param{locks} ? (locks => $param{locks}):(),
3429                                  );
3430     $locks += $new_locks;
3431     if (not @data) {
3432         die "Unable to read any bugs successfully.";
3433     }
3434     if (not $param{archived}) {
3435         for my $data (@data) {
3436             if ($data->{archived}) {
3437                 die "Not altering archived bugs; see unarchive.";
3438             }
3439         }
3440     }
3441     if (not __check_limit(data => \@data,
3442                           exists $param{limit}?(limit => $param{limit}):(),
3443                           transcript => $transcript,
3444                          )) {
3445         die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3446     }
3447
3448     __handle_affected_packages(%param,data => \@data);
3449     print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3450     print {$debug} "$param{bug} read $locks locks\n";
3451     if (not @data or not defined $data[0]) {
3452         print {$transcript} "No bug found for $param{bug}\n";
3453         die "No bug found for $param{bug}";
3454     }
3455
3456     add_recipients(data => \@data,
3457                    recipients => $param{recipients},
3458                    (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3459                    debug      => $debug,
3460                    (__internal_request()?(transcript => $transcript):()),
3461                   );
3462
3463     print {$debug} "$param{bug} read done\n";
3464     my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3465     print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3466     return (data       => \@data,
3467             bugs       => \@bugs,
3468             old_die    => $old_die,
3469             new_locks  => $new_locks,
3470             debug      => $debug,
3471             transcript => $transcript,
3472             param      => \%param,
3473             exists $param{locks}?(locks => $param{locks}):(),
3474            );
3475 }
3476
3477 =head2 __end_control
3478
3479      __end_control(%info);
3480
3481 Handles tearing down from a control request
3482
3483 =cut
3484
3485 sub __end_control {
3486     my %info = @_;
3487     if (exists $info{new_locks} and $info{new_locks} > 0) {
3488         print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3489         for (1..$info{new_locks}) {
3490             unfilelock(exists $info{locks}?$info{locks}:());
3491             $locks--;
3492         }
3493     }
3494     $SIG{__DIE__} = $info{old_die};
3495     if (exists $info{param}{affected_bugs}) {
3496         @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3497     }
3498     add_recipients(recipients => $info{param}{recipients},
3499                    (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3500                    data       => $info{data},
3501                    debug      => $info{debug},
3502                    transcript => $info{transcript},
3503                   );
3504     __handle_affected_packages(%{$info{param}},data=>$info{data});
3505 }
3506
3507
3508 =head2 __check_limit
3509
3510      __check_limit(data => \@data, limit => $param{limit});
3511
3512
3513 Checks to make sure that bugs match any limits; each entry of @data
3514 much satisfy the limit.
3515
3516 Returns true if there are no entries in data, or there are no keys in
3517 limit; returns false (0) if there are any entries which do not match.
3518
3519 The limit hashref elements can contain an arrayref of scalars to
3520 match; regexes are also acccepted. At least one of the entries in each
3521 element needs to match the corresponding field in all data for the
3522 limit to succeed.
3523
3524 =cut
3525
3526
3527 sub __check_limit{
3528     my %param = validate_with(params => \@_,
3529                               spec   => {data  => {type => ARRAYREF|SCALAR,
3530                                                   },
3531                                          limit => {type => HASHREF|UNDEF,
3532                                                   },
3533                                          transcript  => {type => SCALARREF|HANDLE,
3534                                                          optional => 1,
3535                                                         },
3536                                         },
3537                              );
3538     my @data = make_list($param{data});
3539     if (not @data or
3540         not defined $param{limit} or
3541         not keys %{$param{limit}}) {
3542         return 1;
3543     }
3544     my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3545     my $going_to_fail = 0;
3546     for my $data (@data) {
3547         $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3548                                                    status => dclone($data),
3549                                                   ));
3550         for my $field (keys %{$param{limit}}) {
3551             next unless exists $param{limit}{$field};
3552             my $match = 0;
3553             my @data_fields = make_list($data->{$field});
3554 LIMIT:      for my $limit (make_list($param{limit}{$field})) {
3555                 if (not ref $limit) {
3556                     for my $data_field (@data_fields) {
3557                         if ($data_field eq $limit) {
3558                             $match = 1;
3559                             last LIMIT;
3560                         }
3561                     }
3562                 }
3563                 elsif (ref($limit) eq 'Regexp') {
3564                     for my $data_field (@data_fields) {
3565                         if ($data_field =~ $limit) {
3566                             $match = 1;
3567                             last LIMIT;
3568                         }
3569                     }
3570                 }
3571                 else {
3572                     warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3573                 }
3574             }
3575             if (not $match) {
3576                 $going_to_fail = 1;
3577                 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3578                     "' does not match at least one of ".
3579                     join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3580             }
3581         }
3582     }
3583     return $going_to_fail?0:1;
3584 }
3585
3586
3587 =head2 die
3588
3589      sig_die "foo"
3590
3591 We override die to specially handle unlocking files in the cases where
3592 we are called via eval. [If we're not called via eval, it doesn't
3593 matter.]
3594
3595 =cut
3596
3597 sub sig_die{
3598     if ($^S) { # in eval
3599         if ($locks) {
3600             for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3601             $locks = 0;
3602         }
3603     }
3604 }
3605
3606
3607 # =head2 __message_body_template
3608 #
3609 #      message_body_template('mail/ack',{ref=>'foo'});
3610 #
3611 # Creates a message body using a template
3612 #
3613 # =cut
3614
3615 sub __message_body_template{
3616      my ($template,$extra_var) = @_;
3617      $extra_var ||={};
3618      my $hole_var = {'&bugurl' =>
3619                      sub{"$_[0]: ".
3620                              'http://'.$config{cgi_domain}.'/'.
3621                                  Debbugs::CGI::bug_url($_[0]);
3622                      }
3623                     };
3624
3625      my $body = fill_in_template(template => $template,
3626                                  variables => {config => \%config,
3627                                                %{$extra_var},
3628                                               },
3629                                  hole_var => $hole_var,
3630                                 );
3631      return fill_in_template(template => 'mail/message_body',
3632                              variables => {config => \%config,
3633                                            %{$extra_var},
3634                                            body => $body,
3635                                           },
3636                              hole_var => $hole_var,
3637                             );
3638 }
3639
3640 sub __all_undef_or_equal {
3641     my @values = @_;
3642     return 1 if @values == 1 or @values == 0;
3643     my $not_def = grep {not defined $_} @values;
3644     if ($not_def == @values) {
3645         return 1;
3646     }
3647     if ($not_def > 0 and $not_def != @values) {
3648         return 0;
3649     }
3650     my $first_val = shift @values;
3651     for my $val (@values) {
3652         if ($first_val ne $val) {
3653             return 0;
3654         }
3655     }
3656     return 1;
3657 }
3658
3659
3660 1;
3661
3662 __END__