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