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 ($change_bug) = keys %{$changes};
2092         $bug_changed{$change_bug}++;
2093         print {$transcript} __bug_info($data{$change_bug}) if
2094             $param{show_bug_info} and not __internal_request(1);
2095         $bug_info_shown{$change_bug} = 1;
2096         __allow_relocking($param{locks},[keys %data]);
2097         for my $change (@{$changes->{$change_bug}}) {
2098             if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') {
2099                 my %target_blockedby;
2100                 @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}};
2101                 my %unhandled_targets = %target_blockedby;
2102                 my @blocks_to_remove;
2103                 for my $key (split / /,$change->{orig_value}) {
2104                     delete $unhandled_targets{$key};
2105                     next if exists $target_blockedby{$key};
2106                     set_blocks(bug    => $change->{field} eq 'blocks' ? $key : $change->{bug},
2107                                block  => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2108                                remove => 1,
2109                                hash_slice(%param,
2110                                           keys %common_options,
2111                                           keys %append_action_options),
2112                               );
2113                 }
2114                 for my $key (keys %unhandled_targets) {
2115                     set_blocks(bug    => $change->{field} eq 'blocks' ? $key : $change->{bug},
2116                                block  => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2117                                add   => 1,
2118                                hash_slice(%param,
2119                                           keys %common_options,
2120                                           keys %append_action_options),
2121                               );
2122                 }
2123             }
2124             else {
2125                 $change->{function}->(bug => $change->{bug},
2126                                       $change->{key}, $change->{func_value},
2127                                       exists $change->{options}?@{$change->{options}}:(),
2128                                       hash_slice(%param,
2129                                                  keys %common_options,
2130                                                  keys %append_action_options),
2131                                      );
2132             }
2133         }
2134         __disallow_relocking($param{locks});
2135         my ($data,$n_locks) =
2136             __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2137                                         data => \@data,
2138                                         locks => $param{locks},
2139                                         debug => $debug,
2140                                         reload_all => 1,
2141                                        );
2142         $new_locks += $n_locks;
2143         $locks += $n_locks;
2144         %data = %{$data};
2145         @data = values %data;
2146         ($merge_status,$bugs_to_merge) =
2147             __calculate_merge_status(\@data,\%data,$param{bug},$merge_status);
2148         ($disallowed_changes,$changes) =
2149             __calculate_merge_changes(\@data,$merge_status,\%param);
2150         $attempts = max(values %bug_changed);
2151     }
2152     if ($param{show_bug_info} and not __internal_request(1)) {
2153         for my $data (sort {$a->{bug_num} <=> $b->{bug_num}} @data) {
2154             next if $bug_info_shown{$data->{bug_num}};
2155             print {$transcript} __bug_info($data);
2156         }
2157     }
2158     if (keys %{$changes} or @{$disallowed_changes}) {
2159         print {$transcript} "After four attempts, the following changes were unable to be made:\n";
2160         for (1..$new_locks) {
2161             unfilelock($param{locks});
2162             $locks--;
2163         }
2164         __end_control(%info);
2165         for my $change (values %{$changes}, @{$disallowed_changes}) {
2166             print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n";
2167         }
2168         die "Unable to modify bugs so they could be merged";
2169         return;
2170     }
2171
2172     # finally, we can merge the bugs
2173     my $action = "Merged ".join(' ',sort keys %merged_bugs);
2174     for my $data (@data) {
2175         my $old_data = dclone($data);
2176         $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
2177                                     keys %merged_bugs);
2178         append_action_to_log(bug => $data->{bug_num},
2179                              command  => 'merge',
2180                              new_data => $data,
2181                              old_data => $old_data,
2182                              get_lock => 0,
2183                              __return_append_to_log_options(%param,
2184                                                             action => $action,
2185                                                            ),
2186                             )
2187             if not exists $param{append_log} or $param{append_log};
2188         writebug($data->{bug_num},$data);
2189     }
2190     print {$transcript} "$action\n";
2191     # unlock the extra locks that we got earlier
2192     for (1..$new_locks) {
2193         unfilelock($param{locks});
2194         $locks--;
2195     }
2196     __end_control(%info);
2197 }
2198
2199 sub __allow_relocking{
2200     my ($locks,$bugs) = @_;
2201
2202     my @locks = (@{$bugs},'merge');
2203     for my $lock (@locks) {
2204         my @lockfiles = grep {m{/\Q$lock\E$}} keys %{$locks->{locks}};
2205         next unless @lockfiles;
2206         $locks->{relockable}{$lockfiles[0]} = 0;
2207     }
2208 }
2209
2210 sub __disallow_relocking{
2211     my ($locks) = @_;
2212     delete $locks->{relockable};
2213 }
2214
2215 sub __lock_and_load_merged_bugs{
2216     my %param =
2217         validate_with(params => \@_,
2218                       spec =>
2219                       {bugs_to_load => {type => ARRAYREF,
2220                                         default => sub {[]},
2221                                        },
2222                        data         => {type => HASHREF|ARRAYREF,
2223                                        },
2224                        locks        => {type => HASHREF,
2225                                         default => sub {{};},
2226                                        },
2227                        reload_all => {type => BOOLEAN,
2228                                       default => 0,
2229                                      },
2230                        debug           => {type => HANDLE,
2231                                           },
2232                       },
2233                      );
2234     my %data;
2235     my $new_locks = 0;
2236     if (ref($param{data}) eq 'ARRAY') {
2237         for my $data (@{$param{data}}) {
2238             $data{$data->{bug_num}} = dclone($data);
2239         }
2240     }
2241     else {
2242         %data = %{dclone($param{data})};
2243     }
2244     my @bugs_to_load = @{$param{bugs_to_load}};
2245     if ($param{reload_all}) {
2246         push @bugs_to_load, keys %data;
2247     }
2248     my %temp;
2249     @temp{@bugs_to_load} = (1) x @bugs_to_load;
2250     @bugs_to_load = keys %temp;
2251     my %loaded_this_time;
2252     my $bug_to_load;
2253     while ($bug_to_load = shift @bugs_to_load) {
2254         if (not $param{reload_all}) {
2255             next if exists $data{$bug_to_load};
2256         }
2257         else {
2258             next if $loaded_this_time{$bug_to_load};
2259         }
2260         my $lock_bug = 1;
2261         if ($param{reload_all}) {
2262             if (exists $data{$bug_to_load}) {
2263                 $lock_bug = 0;
2264             }
2265         }
2266         my $data =
2267             read_bug(bug => $bug_to_load,
2268                      lock => $lock_bug,
2269                      locks => $param{locks},
2270                     ) or
2271                         die "Unable to load bug $bug_to_load";
2272         print {$param{debug}} "read bug $bug_to_load\n";
2273         $data{$data->{bug_num}} = $data;
2274         $new_locks += $lock_bug;
2275         $loaded_this_time{$data->{bug_num}} = 1;
2276         push @bugs_to_load,
2277             grep {not exists $data{$_}}
2278                 split / /,$data->{mergedwith};
2279     }
2280     return (\%data,$new_locks);
2281 }
2282
2283
2284 sub __calculate_merge_status{
2285     my ($data_a,$data_h,$master_bug,$merge_status) = @_;
2286     my %merge_status = %{$merge_status // {}};
2287     my %merged_bugs;
2288     my $bugs_to_merge = 0;
2289     for my $data (@{$data_a}) {
2290         # check to see if this bug is unmerged in the set
2291         if (not length $data->{mergedwith} or
2292             grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) {
2293             $merged_bugs{$data->{bug_num}} = 1;
2294             $bugs_to_merge = 1;
2295         }
2296         # the master_bug is the bug that every other bug is made to
2297         # look like. However, if merge is set, tags, fixed and found
2298         # are merged.
2299         if ($data->{bug_num} == $master_bug) {
2300             for (qw(package forwarded severity blocks blockedby done owner summary affects)) {
2301                 $merge_status{$_} = $data->{$_}
2302             }
2303         }
2304         if (defined $merge_status) {
2305             next unless $data->{bug_num} == $master_bug;
2306         }
2307         $merge_status{tag} = {} if not exists $merge_status{tag};
2308         for my $tag (split /\s+/, $data->{keywords}) {
2309             $merge_status{tag}{$tag} = 1;
2310         }
2311         $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}});
2312         for (qw(fixed found)) {
2313             @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}};
2314         }
2315     }
2316     return (\%merge_status,$bugs_to_merge);
2317 }
2318
2319
2320
2321 sub __calculate_merge_changes{
2322     my ($datas,$merge_status,$param) = @_;
2323     my %changes;
2324     my @disallowed_changes;
2325     for my $data (@{$datas}) {
2326         # things that can be forced
2327         #
2328         # * func is the function to set the new value
2329         #
2330         # * key is the key of the function to set the value,
2331
2332         # * modify_value is a function which is called to modify the new
2333         # value so that the function will accept it
2334
2335         # * options is an ARRAYREF of options to pass to the function
2336
2337         # * allowed is a BOOLEAN which controls whether this setting
2338         # is allowed to be different by default.
2339         my %force_functions =
2340             (forwarded => {func => \&set_forwarded,
2341                            key  => 'forwarded',
2342                            options => [],
2343                           },
2344              severity  => {func => \&set_severity,
2345                            key  => 'severity',
2346                            options => [],
2347                           },
2348              blocks    => {func => \&set_blocks,
2349                            modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2350                            key  => 'block',
2351                            options => [],
2352                           },
2353              blockedby => {func => \&set_blocks,
2354                            modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2355                            key  => 'block',
2356                            options => [],
2357                           },
2358              done      => {func => \&set_done,
2359                            key  => 'done',
2360                            options => [],
2361                           },
2362              owner     => {func => \&owner,
2363                            key  => 'owner',
2364                            options => [],
2365                           },
2366              summary   => {func => \&summary,
2367                            key  => 'summary',
2368                            options => [],
2369                           },
2370              affects   => {func => \&affects,
2371                            key  => 'package',
2372                            options => [],
2373                           },
2374              package   => {func => \&set_package,
2375                            key  => 'package',
2376                            options => [],
2377                           },
2378              keywords   => {func => \&set_tag,
2379                             key  => 'tag',
2380                             modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]},
2381                             allowed => 1,
2382                            },
2383              fixed_versions => {func => \&set_fixed,
2384                                 key => 'fixed',
2385                                 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2386                                 allowed => 1,
2387                                },
2388              found_versions => {func => \&set_found,
2389                                 key   => 'found',
2390                                 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2391                                 allowed => 1,
2392                                },
2393             );
2394         for my $field (qw(forwarded severity blocks blockedby done owner summary affects package fixed_versions found_versions keywords)) {
2395             # if the ideal bug already has the field set properly, we
2396             # continue on.
2397             if ($field eq 'keywords'){
2398                 next if join(' ',sort split /\s+/,$data->{keywords}) eq
2399                     join(' ',sort keys %{$merge_status->{tag}});
2400             }
2401             elsif ($field =~ /^(?:fixed|found)_versions$/) {
2402                 next if join(' ', sort @{$data->{$field}}) eq
2403                     join(' ',sort keys %{$merge_status->{$field}});
2404             }
2405             elsif ($field eq 'done') {
2406                 # for done, we only care if the bug is done or not
2407                 # done, not the value it's set to.
2408                 if (defined $merge_status->{$field} and length $merge_status->{$field} and
2409                     defined $data->{$field}         and length $data->{$field}) {
2410                     next;
2411                 }
2412                 elsif ((not defined $merge_status->{$field} or not length $merge_status->{$field}) and
2413                        (not defined $data->{$field}         or not length $data->{$field})
2414                       ) {
2415                     next;
2416                 }
2417             }
2418             elsif ($merge_status->{$field} eq $data->{$field}) {
2419                 next;
2420             }
2421             my $change =
2422                 {field => $field,
2423                  bug => $data->{bug_num},
2424                  orig_value => $data->{$field},
2425                  func_value   =>
2426                  (exists $force_functions{$field}{modify_value} ?
2427                   $force_functions{$field}{modify_value}->($merge_status->{$field}):
2428                   $merge_status->{$field}),
2429                  value    => $merge_status->{$field},
2430                  function => $force_functions{$field}{func},
2431                  key      => $force_functions{$field}{key},
2432                  options  => $force_functions{$field}{options},
2433                  allowed  => exists $force_functions{$field}{allowed} ? $force_functions{$field}{allowed} : 0,
2434                 };
2435             $change->{text_value} = ref($change->{func_value}) eq 'ARRAY'?join(' ',@{$change->{func_value}}):$change->{func_value};
2436             $change->{text_orig_value} = ref($change->{orig_value}) eq 'ARRAY'?join(' ',@{$change->{orig_value}}):$change->{orig_value};
2437             if ($param->{force} or $change->{allowed}) {
2438                 if ($field ne 'package' or $change->{allowed}) {
2439                     push @{$changes{$data->{bug_num}}},$change;
2440                     next;
2441                 }
2442                 if ($param->{allow_reassign}) {
2443                     if ($param->{reassign_different_sources}) {
2444                         push @{$changes{$data->{bug_num}}},$change;
2445                         next;
2446                     }
2447                     # allow reassigning if binary_to_source returns at
2448                     # least one of the same source packages
2449                     my @merge_status_source =
2450                         binary_to_source(package => $merge_status->{package},
2451                                          source_only => 1,
2452                                         );
2453                     my @other_bug_source =
2454                         binary_to_source(package => $data->{package},
2455                                          source_only => 1,
2456                                         );
2457                     my %merge_status_sources;
2458                     @merge_status_sources{@merge_status_source} =
2459                         (1) x @merge_status_source;
2460                     if (grep {$merge_status_sources{$_}} @other_bug_source) {
2461                         push @{$changes{$data->{bug_num}}},$change;
2462                         next;
2463                     }
2464                 }
2465             }
2466             push @disallowed_changes,$change;
2467         }
2468         # blocks and blocked by are weird; we have to go through and
2469         # set blocks to the other half of the merged bugs
2470     }
2471     return (\@disallowed_changes,\%changes);
2472 }
2473
2474 =head2 affects
2475
2476      eval {
2477             affects(bug          => $ref,
2478                     transcript   => $transcript,
2479                     ($dl > 0 ? (debug => $transcript):()),
2480                     requester    => $header{from},
2481                     request_addr => $controlrequestaddr,
2482                     message      => \@log,
2483                     affected_packages => \%affected_packages,
2484                     recipients   => \%recipients,
2485                     packages     => undef,
2486                     add          => 1,
2487                     remove       => 0,
2488                    );
2489         };
2490         if ($@) {
2491             $errors++;
2492             print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2493         }
2494
2495 This marks a bug as affecting packages which the bug is not actually
2496 in. This should only be used in cases where fixing the bug instantly
2497 resolves the problem in the other packages.
2498
2499 By default, the packages are set to the list of packages passed.
2500 However, if you pass add => 1 or remove => 1, the list of packages
2501 passed are added or removed from the affects list, respectively.
2502
2503 =cut
2504
2505 sub affects {
2506     my %param = validate_with(params => \@_,
2507                               spec   => {bug => {type   => SCALAR,
2508                                                  regex  => qr/^\d+$/,
2509                                                 },
2510                                          # specific options here
2511                                          package => {type => SCALAR|ARRAYREF|UNDEF,
2512                                                      default => [],
2513                                                     },
2514                                          add      => {type => BOOLEAN,
2515                                                       default => 0,
2516                                                      },
2517                                          remove   => {type => BOOLEAN,
2518                                                       default => 0,
2519                                                      },
2520                                          %common_options,
2521                                          %append_action_options,
2522                                         },
2523                              );
2524     if ($param{add} and $param{remove}) {
2525          croak "Asking to both add and remove affects is nonsensical";
2526     }
2527     if (not defined $param{package}) {
2528         $param{package} = [];
2529     }
2530     my %info =
2531         __begin_control(%param,
2532                         command  => 'affects'
2533                        );
2534     my ($debug,$transcript) =
2535         @info{qw(debug transcript)};
2536     my @data = @{$info{data}};
2537     my @bugs = @{$info{bugs}};
2538     my $action = '';
2539     for my $data (@data) {
2540         $action = '';
2541          print {$debug} "Going to change affects\n";
2542          my @packages = splitpackages($data->{affects});
2543          my %packages;
2544          @packages{@packages} = (1) x @packages;
2545          if ($param{add}) {
2546               my @added = ();
2547               for my $package (make_list($param{package})) {
2548                   next unless defined $package and length $package;
2549                   if (not $packages{$package}) {
2550                       $packages{$package} = 1;
2551                       push @added,$package;
2552                   }
2553               }
2554               if (@added) {
2555                    $action = "Added indication that $data->{bug_num} affects ".
2556                         english_join(\@added);
2557               }
2558          }
2559          elsif ($param{remove}) {
2560               my @removed = ();
2561               for my $package (make_list($param{package})) {
2562                    if ($packages{$package}) {
2563                        next unless defined $package and length $package;
2564                         delete $packages{$package};
2565                         push @removed,$package;
2566                    }
2567               }
2568               $action = "Removed indication that $data->{bug_num} affects " .
2569                    english_join(\@removed);
2570          }
2571          else {
2572               my %added_packages = ();
2573               my %removed_packages = %packages;
2574               %packages = ();
2575               for my $package (make_list($param{package})) {
2576                    next unless defined $package and length $package;
2577                    $packages{$package} = 1;
2578                    delete $removed_packages{$package};
2579                    $added_packages{$package} = 1;
2580               }
2581               if (keys %removed_packages) {
2582                   $action = "Removed indication that $data->{bug_num} affects ".
2583                       english_join([keys %removed_packages]);
2584                   $action .= "\n" if keys %added_packages;
2585               }
2586               if (keys %added_packages) {
2587                   $action .= "Added indication that $data->{bug_num} affects " .
2588                    english_join([keys %added_packages]);
2589               }
2590          }
2591         if (not length $action) {
2592             print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n";
2593             next;
2594         }
2595          my $old_data = dclone($data);
2596          $data->{affects} = join(',',keys %packages);
2597          append_action_to_log(bug => $data->{bug_num},
2598                               get_lock => 0,
2599                               command => 'affects',
2600                               new_data => $data,
2601                               old_data => $old_data,
2602                               __return_append_to_log_options(
2603                                                              %param,
2604                                                              action => $action,
2605                                                             ),
2606                              )
2607                if not exists $param{append_log} or $param{append_log};
2608           writebug($data->{bug_num},$data);
2609           print {$transcript} "$action\n";
2610      }
2611     __end_control(%info);
2612 }
2613
2614
2615 =head1 SUMMARY FUNCTIONS
2616
2617 =head2 summary
2618
2619      eval {
2620             summary(bug          => $ref,
2621                     transcript   => $transcript,
2622                     ($dl > 0 ? (debug => $transcript):()),
2623                     requester    => $header{from},
2624                     request_addr => $controlrequestaddr,
2625                     message      => \@log,
2626                     affected_packages => \%affected_packages,
2627                     recipients   => \%recipients,
2628                     summary      => undef,
2629                    );
2630         };
2631         if ($@) {
2632             $errors++;
2633             print {$transcript} "Failed to mark $ref with summary foo: $@";
2634         }
2635
2636 Handles all setting of summary fields
2637
2638 If summary is undef, unsets the summary
2639
2640 If summary is 0, sets the summary to the first paragraph contained in
2641 the message passed.
2642
2643 If summary is a positive integer, sets the summary to the message specified.
2644
2645 Otherwise, sets summary to the value passed.
2646
2647 =cut
2648
2649
2650 sub summary {
2651     my %param = validate_with(params => \@_,
2652                               spec   => {bug => {type   => SCALAR,
2653                                                  regex  => qr/^\d+$/,
2654                                                 },
2655                                          # specific options here
2656                                          summary => {type => SCALAR|UNDEF,
2657                                                      default => 0,
2658                                                     },
2659                                          %common_options,
2660                                          %append_action_options,
2661                                         },
2662                              );
2663 # croak "summary must be numeric or undef" if
2664 #       defined $param{summary} and not $param{summary} =~ /^\d+/;
2665     my %info =
2666         __begin_control(%param,
2667                         command  => 'summary'
2668                        );
2669     my ($debug,$transcript) =
2670         @info{qw(debug transcript)};
2671     my @data = @{$info{data}};
2672     my @bugs = @{$info{bugs}};
2673     # figure out the log that we're going to use
2674     my $summary = '';
2675     my $summary_msg = '';
2676     my $action = '';
2677     if (not defined $param{summary}) {
2678          # do nothing
2679          print {$debug} "Removing summary fields\n";
2680          $action = 'Removed summary';
2681     }
2682     elsif ($param{summary} =~ /^\d+$/) {
2683          my $log = [];
2684          my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2685          if ($param{summary} == 0) {
2686               $log = $param{message};
2687               $summary_msg = @records + 1;
2688          }
2689          else {
2690               if (($param{summary} - 1 ) > $#records) {
2691                    die "Message number '$param{summary}' exceeds the maximum message '$#records'";
2692               }
2693               my $record = $records[($param{summary} - 1 )];
2694               if ($record->{type} !~ /incoming-recv|recips/) {
2695                    die "Message number '$param{summary}' is a invalid message type '$record->{type}'";
2696               }
2697               $summary_msg = $param{summary};
2698               $log = [$record->{text}];
2699          }
2700          my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2701          my $body = $p_o->{body};
2702          my $in_pseudoheaders = 0;
2703          my $paragraph = '';
2704          # walk through body until we get non-blank lines
2705          for my $line (@{$body}) {
2706               if ($line =~ /^\s*$/) {
2707                    if (length $paragraph) {
2708                         if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2709                              $paragraph = '';
2710                              next;
2711                         }
2712                         last;
2713                    }
2714                    $in_pseudoheaders = 0;
2715                    next;
2716               }
2717               # skip a paragraph if it looks like it's control or
2718               # pseudo-headers
2719               if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
2720                   $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2721                                  \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2722                                  debug|(?:not|)forwarded|priority|
2723                                  (?:un|)block|limit|(?:un|)archive|
2724                                  reassign|retitle|affects|wrongpackage
2725                                  (?:un|force|)merge|user(?:category|tags?|)
2726                              )\s+\S}xis) {
2727                    if (not length $paragraph) {
2728                         print {$debug} "Found control/pseudo-headers and skiping them\n";
2729                         $in_pseudoheaders = 1;
2730                         next;
2731                    }
2732               }
2733               next if $in_pseudoheaders;
2734               $paragraph .= $line ." \n";
2735          }
2736          print {$debug} "Summary is going to be '$paragraph'\n";
2737          $summary = $paragraph;
2738          $summary =~ s/[\n\r]/ /g;
2739          if (not length $summary) {
2740               die "Unable to find summary message to use";
2741          }
2742          # trim off a trailing spaces
2743          $summary =~ s/\ *$//;
2744     }
2745     else {
2746         $summary = $param{summary};
2747     }
2748     for my $data (@data) {
2749          print {$debug} "Going to change summary\n";
2750          if (((not defined $summary or not length $summary) and
2751               (not defined $data->{summary} or not length $data->{summary})) or
2752              $summary eq $data->{summary}) {
2753              print {$transcript} "Ignoring request to change the summary of bug $param{bug} to the same value\n";
2754              next;
2755          }
2756          if (length $summary) {
2757               if (length $data->{summary}) {
2758                    $action = "Summary replaced with message bug $param{bug} message $summary_msg";
2759               }
2760               else {
2761                    $action = "Summary recorded from message bug $param{bug} message $summary_msg";
2762               }
2763          }
2764          my $old_data = dclone($data);
2765          $data->{summary} = $summary;
2766          append_action_to_log(bug => $data->{bug_num},
2767                               command => 'summary',
2768                               old_data => $old_data,
2769                               new_data => $data,
2770                               get_lock => 0,
2771                               __return_append_to_log_options(
2772                                                              %param,
2773                                                              action => $action,
2774                                                             ),
2775                              )
2776                if not exists $param{append_log} or $param{append_log};
2777           writebug($data->{bug_num},$data);
2778           print {$transcript} "$action\n";
2779      }
2780     __end_control(%info);
2781 }
2782
2783
2784
2785 =head2 clone_bug
2786
2787      eval {
2788             clone_bug(bug          => $ref,
2789                       transcript   => $transcript,
2790                       ($dl > 0 ? (debug => $transcript):()),
2791                       requester    => $header{from},
2792                       request_addr => $controlrequestaddr,
2793                       message      => \@log,
2794                       affected_packages => \%affected_packages,
2795                       recipients   => \%recipients,
2796                      );
2797         };
2798         if ($@) {
2799             $errors++;
2800             print {$transcript} "Failed to clone bug $ref bar: $@";
2801         }
2802
2803 Clones the given bug.
2804
2805 We currently don't support cloning merged bugs, but this could be
2806 handled by internally unmerging, cloning, then remerging the bugs.
2807
2808 =cut
2809
2810 sub clone_bug {
2811     my %param = validate_with(params => \@_,
2812                               spec   => {bug => {type   => SCALAR,
2813                                                  regex  => qr/^\d+$/,
2814                                                 },
2815                                          new_bugs => {type => ARRAYREF,
2816                                                      },
2817                                          new_clones => {type => HASHREF,
2818                                                         default => {},
2819                                                        },
2820                                          %common_options,
2821                                          %append_action_options,
2822                                         },
2823                              );
2824     my %info =
2825         __begin_control(%param,
2826                         command  => 'clone'
2827                        );
2828     my ($debug,$transcript) =
2829         @info{qw(debug transcript)};
2830     my @data = @{$info{data}};
2831     my @bugs = @{$info{bugs}};
2832
2833     my $action = '';
2834     for my $data (@data) {
2835         if (length($data->{mergedwith})) {
2836             die "Bug is marked as being merged with others. Use an existing clone.\n";
2837         }
2838     }
2839     if (@data != 1) {
2840         die "Not exactly one bug‽ This shouldn't happen.";
2841     }
2842     my $data = $data[0];
2843     my %clones;
2844     for my $newclone_id (@{$param{new_bugs}}) {
2845         my $new_bug_num = new_bug(copy => $data->{bug_num});
2846         $param{new_clones}{$newclone_id} = $new_bug_num;
2847         $clones{$newclone_id} = $new_bug_num;
2848     }
2849     my @new_bugs = sort values %clones;
2850     my @collapsed_ids;
2851     for my $new_bug (@new_bugs) {
2852         # no collapsed ids or the higher collapsed id is not one less
2853         # than the next highest new bug
2854         if (not @collapsed_ids or
2855             $collapsed_ids[-1][1]+1 != $new_bug) {
2856             push @collapsed_ids,[$new_bug,$new_bug];
2857         }
2858         else {
2859             $collapsed_ids[-1][1] = $new_bug;
2860         }
2861     }
2862     my @collapsed;
2863     for my $ci (@collapsed_ids) {
2864         if ($ci->[0] == $ci->[1]) {
2865             push @collapsed,$ci->[0];
2866         }
2867         else {
2868             push @collapsed,$ci->[0].'-'.$ci->[1]
2869         }
2870     }
2871     my $collapsed_str = english_join(\@collapsed);
2872     $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str;
2873     for my $new_bug (@new_bugs) {
2874         append_action_to_log(bug => $new_bug,
2875                              get_lock => 1,
2876                              __return_append_to_log_options(
2877                                                             %param,
2878                                                             action => $action,
2879                                                            ),
2880                             )
2881             if not exists $param{append_log} or $param{append_log};
2882     }
2883     append_action_to_log(bug => $data->{bug_num},
2884                          get_lock => 0,
2885                          __return_append_to_log_options(
2886                                                         %param,
2887                                                         action => $action,
2888                                                        ),
2889                         )
2890         if not exists $param{append_log} or $param{append_log};
2891     writebug($data->{bug_num},$data);
2892     print {$transcript} "$action\n";
2893     __end_control(%info);
2894     # bugs that this bug is blocking are also blocked by the new clone(s)
2895     for my $bug (split ' ', $data->{blocks}) {
2896         for my $new_bug (@new_bugs) {
2897             set_blocks(bug => $new_bug,
2898                        blocks => $bug,
2899                        hash_slice(%param,
2900                                   keys %common_options,
2901                                   keys %append_action_options),
2902                       );
2903         }
2904     }
2905     # bugs that this bug is blocked by are also blocking the new clone(s)
2906     for my $bug (split ' ', $data->{blockedby}) {
2907         for my $new_bug (@new_bugs) {
2908             set_blocks(bug => $bug,
2909                        blocks => $new_bug,
2910                        hash_slice(%param,
2911                                   keys %common_options,
2912                                   keys %append_action_options),
2913                       );
2914         }
2915     }
2916 }
2917
2918
2919
2920 =head1 OWNER FUNCTIONS
2921
2922 =head2 owner
2923
2924      eval {
2925             owner(bug          => $ref,
2926                   transcript   => $transcript,
2927                   ($dl > 0 ? (debug => $transcript):()),
2928                   requester    => $header{from},
2929                   request_addr => $controlrequestaddr,
2930                   message      => \@log,
2931                   recipients   => \%recipients,
2932                   owner        => undef,
2933                  );
2934         };
2935         if ($@) {
2936             $errors++;
2937             print {$transcript} "Failed to mark $ref as having an owner: $@";
2938         }
2939
2940 Handles all setting of the owner field; given an owner of undef or of
2941 no length, indicates that a bug is not owned by anyone.
2942
2943 =cut
2944
2945 sub owner {
2946      my %param = validate_with(params => \@_,
2947                                spec   => {bug => {type   => SCALAR,
2948                                                   regex  => qr/^\d+$/,
2949                                                  },
2950                                           owner => {type => SCALAR|UNDEF,
2951                                                    },
2952                                           %common_options,
2953                                           %append_action_options,
2954                                          },
2955                               );
2956      my %info =
2957          __begin_control(%param,
2958                          command  => 'owner',
2959                         );
2960      my ($debug,$transcript) =
2961         @info{qw(debug transcript)};
2962      my @data = @{$info{data}};
2963      my @bugs = @{$info{bugs}};
2964      my $action = '';
2965      for my $data (@data) {
2966           print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
2967           print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
2968           if (not defined $param{owner} or not length $param{owner}) {
2969               if (not defined $data->{owner} or not length $data->{owner}) {
2970                   print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n";
2971                   next;
2972               }
2973               $param{owner} = '';
2974               $action = "Removed annotation that $config{bug} was owned by " .
2975                   "$data->{owner}.";
2976           }
2977           else {
2978               if ($data->{owner} eq $param{owner}) {
2979                   print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
2980                   next;
2981               }
2982               if (length $data->{owner}) {
2983                   $action = "Owner changed from $data->{owner} to $param{owner}.";
2984               }
2985               else {
2986                   $action = "Owner recorded as $param{owner}."
2987               }
2988           }
2989           my $old_data = dclone($data);
2990           $data->{owner} = $param{owner};
2991           append_action_to_log(bug => $data->{bug_num},
2992                                command => 'owner',
2993                                new_data => $data,
2994                                old_data => $old_data,
2995                                get_lock => 0,
2996                __return_append_to_log_options(
2997                                               %param,
2998                                               action => $action,
2999                                              ),
3000                               )
3001                if not exists $param{append_log} or $param{append_log};
3002           writebug($data->{bug_num},$data);
3003           print {$transcript} "$action\n";
3004      }
3005      __end_control(%info);
3006 }
3007
3008
3009 =head1 ARCHIVE FUNCTIONS
3010
3011
3012 =head2 bug_archive
3013
3014      my $error = '';
3015      eval {
3016         bug_archive(bug => $bug_num,
3017                     debug => \$debug,
3018                     transcript => \$transcript,
3019                    );
3020      };
3021      if ($@) {
3022         $errors++;
3023         transcript("Unable to archive $bug_num\n");
3024         warn $@;
3025      }
3026      transcript($transcript);
3027
3028
3029 This routine archives a bug
3030
3031 =over
3032
3033 =item bug -- bug number
3034
3035 =item check_archiveable -- check wether a bug is archiveable before
3036 archiving; defaults to 1
3037
3038 =item archive_unarchived -- whether to archive bugs which have not
3039 previously been archived; defaults to 1. [Set to 0 when used from
3040 control@]
3041
3042 =item ignore_time -- whether to ignore time constraints when archiving
3043 a bug; defaults to 0.
3044
3045 =back
3046
3047 =cut
3048
3049 sub bug_archive {
3050      my %param = validate_with(params => \@_,
3051                                spec   => {bug => {type   => SCALAR,
3052                                                   regex  => qr/^\d+$/,
3053                                                  },
3054                                           check_archiveable => {type => BOOLEAN,
3055                                                                 default => 1,
3056                                                                },
3057                                           archive_unarchived => {type => BOOLEAN,
3058                                                                  default => 1,
3059                                                                 },
3060                                           ignore_time => {type => BOOLEAN,
3061                                                           default => 0,
3062                                                          },
3063                                           %common_options,
3064                                           %append_action_options,
3065                                          },
3066                               );
3067      my %info = __begin_control(%param,
3068                                 command => 'archive',
3069                                 );
3070      my ($debug,$transcript) = @info{qw(debug transcript)};
3071      my @data = @{$info{data}};
3072      my @bugs = @{$info{bugs}};
3073      my $action = "$config{bug} archived.";
3074      if ($param{check_archiveable} and
3075          not bug_archiveable(bug=>$param{bug},
3076                              ignore_time => $param{ignore_time},
3077                             )) {
3078           print {$transcript} "Bug $param{bug} cannot be archived\n";
3079           die "Bug $param{bug} cannot be archived";
3080      }
3081      if (not $param{archive_unarchived} and
3082          not exists $data[0]{unarchived}
3083         ) {
3084           print {$transcript} "$param{bug} has not been archived previously\n";
3085           die "$param{bug} has not been archived previously";
3086      }
3087      add_recipients(recipients => $param{recipients},
3088                     data => \@data,
3089                     debug      => $debug,
3090                     transcript => $transcript,
3091                    );
3092      print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3093      for my $bug (@bugs) {
3094          if ($param{check_archiveable}) {
3095              die "Bug $bug cannot be archived (but $param{bug} can?)"
3096                  unless bug_archiveable(bug=>$bug,
3097                                         ignore_time => $param{ignore_time},
3098                                        );
3099          }
3100      }
3101      # If we get here, we can archive/remove this bug
3102      print {$debug} "$param{bug} removing\n";
3103      for my $bug (@bugs) {
3104           #print "$param{bug} removing $bug\n" if $debug;
3105           my $dir = get_hashname($bug);
3106           # First indicate that this bug is being archived
3107           append_action_to_log(bug => $bug,
3108                                get_lock => 0,
3109                                command => 'archive',
3110                                # we didn't actually change the data
3111                                # when we archived, so we don't pass
3112                                # a real new_data or old_data
3113                                new_data => {},
3114                                old_data => {},
3115                                __return_append_to_log_options(
3116                                  %param,
3117                                  action => $action,
3118                                 )
3119                               )
3120                if not exists $param{append_log} or $param{append_log};
3121           my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
3122           if ($config{save_old_bugs}) {
3123                mkpath("$config{spool_dir}/archive/$dir");
3124                foreach my $file (@files_to_remove) {
3125                    link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3126                        copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3127                            # we need to bail out here if things have
3128                            # gone horribly wrong to avoid removing a
3129                            # bug altogether
3130                            die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
3131                }
3132
3133                print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
3134           }
3135           unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
3136           print {$debug} "deleted $bug (from $param{bug})\n";
3137      }
3138      bughook_archive(@bugs);
3139      __end_control(%info);
3140 }
3141
3142 =head2 bug_unarchive
3143
3144      my $error = '';
3145      eval {
3146         bug_unarchive(bug => $bug_num,
3147                       debug => \$debug,
3148                       transcript => \$transcript,
3149                      );
3150      };
3151      if ($@) {
3152         $errors++;
3153         transcript("Unable to archive bug: $bug_num");
3154      }
3155      transcript($transcript);
3156
3157 This routine unarchives a bug
3158
3159 =cut
3160
3161 sub bug_unarchive {
3162      my %param = validate_with(params => \@_,
3163                                spec   => {bug => {type   => SCALAR,
3164                                                   regex  => qr/^\d+/,
3165                                                  },
3166                                           %common_options,
3167                                           %append_action_options,
3168                                          },
3169                               );
3170
3171      my %info = __begin_control(%param,
3172                                 archived=>1,
3173                                 command=>'unarchive');
3174      my ($debug,$transcript) =
3175          @info{qw(debug transcript)};
3176      my @data = @{$info{data}};
3177      my @bugs = @{$info{bugs}};
3178      my $action = "$config{bug} unarchived.";
3179      my @files_to_remove;
3180      for my $bug (@bugs) {
3181           print {$debug} "$param{bug} removing $bug\n";
3182           my $dir = get_hashname($bug);
3183           my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3184           mkpath("archive/$dir");
3185           foreach my $file (@files_to_copy) {
3186                # die'ing here sucks
3187                link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3188                     copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3189                          die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3190           }
3191           push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3192           print {$transcript} "Unarchived $config{bug} $bug\n";
3193      }
3194      unlink(@files_to_remove) or die "Unable to unlink bugs";
3195      # Indicate that this bug has been archived previously
3196      for my $bug (@bugs) {
3197           my $newdata = readbug($bug);
3198           my $old_data = dclone($newdata);
3199           if (not defined $newdata) {
3200                print {$transcript} "$config{bug} $bug disappeared!\n";
3201                die "Bug $bug disappeared!";
3202           }
3203           $newdata->{unarchived} = time;
3204           append_action_to_log(bug => $bug,
3205                                get_lock => 0,
3206                                command => 'unarchive',
3207                                new_data => $newdata,
3208                                old_data => $old_data,
3209                                __return_append_to_log_options(
3210                                  %param,
3211                                  action => $action,
3212                                 )
3213                               )
3214                if not exists $param{append_log} or $param{append_log};
3215           writebug($bug,$newdata);
3216      }
3217      __end_control(%info);
3218 }
3219
3220 =head2 append_action_to_log
3221
3222      append_action_to_log
3223
3224 This should probably be moved to Debbugs::Log; have to think that out
3225 some more.
3226
3227 =cut
3228
3229 sub append_action_to_log{
3230      my %param = validate_with(params => \@_,
3231                                spec   => {bug => {type   => SCALAR,
3232                                                   regex  => qr/^\d+/,
3233                                                  },
3234                                           new_data => {type => HASHREF,
3235                                                        optional => 1,
3236                                                       },
3237                                           old_data => {type => HASHREF,
3238                                                        optional => 1,
3239                                                       },
3240                                           command  => {type => SCALAR,
3241                                                        optional => 1,
3242                                                       },
3243                                           action => {type => SCALAR,
3244                                                     },
3245                                           requester => {type => SCALAR,
3246                                                         default => '',
3247                                                        },
3248                                           request_addr => {type => SCALAR,
3249                                                            default => '',
3250                                                           },
3251                                           location => {type => SCALAR,
3252                                                        optional => 1,
3253                                                       },
3254                                           message  => {type => SCALAR|ARRAYREF,
3255                                                        default => '',
3256                                                       },
3257                                           recips   => {type => SCALAR|ARRAYREF,
3258                                                        optional => 1
3259                                                       },
3260                                           desc       => {type => SCALAR,
3261                                                          default => '',
3262                                                         },
3263                                           get_lock   => {type => BOOLEAN,
3264                                                          default => 1,
3265                                                         },
3266                                           locks      => {type => HASHREF,
3267                                                          optional => 1,
3268                                                         },
3269                                           # we don't use
3270                                           # append_action_options here
3271                                           # because some of these
3272                                           # options aren't actually
3273                                           # optional, even though the
3274                                           # original function doesn't
3275                                           # require them
3276                                          },
3277                               );
3278      # Fix this to use $param{location}
3279      my $log_location = buglog($param{bug});
3280      die "Unable to find .log for $param{bug}"
3281           if not defined $log_location;
3282      if ($param{get_lock}) {
3283           filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3284           $locks++;
3285      }
3286      my @records;
3287      my $logfh = IO::File->new(">>$log_location") or
3288          die "Unable to open $log_location for appending: $!";
3289      # determine difference between old and new
3290      my $data_diff = '';
3291      if (exists $param{old_data} and exists $param{new_data}) {
3292          my $old_data = dclone($param{old_data});
3293          my $new_data = dclone($param{new_data});
3294          for my $key (keys %{$old_data}) {
3295              if (not exists $Debbugs::Status::fields{$key}) {
3296                  delete $old_data->{$key};
3297                  next;
3298              }
3299              next unless exists $new_data->{$key};
3300              next unless defined $new_data->{$key};
3301              if (not defined $old_data->{$key}) {
3302                  delete $old_data->{$key};
3303                  next;
3304              }
3305              if (ref($new_data->{$key}) and
3306                  ref($old_data->{$key}) and
3307                  ref($new_data->{$key}) eq ref($old_data->{$key})) {
3308                 local $Storable::canonical = 1;
3309                 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3310                     delete $new_data->{$key};
3311                     delete $old_data->{$key};
3312                 }
3313              }
3314              elsif ($new_data->{$key} eq $old_data->{$key}) {
3315                  delete $new_data->{$key};
3316                  delete $old_data->{$key};
3317              }
3318          }
3319          for my $key (keys %{$new_data}) {
3320              if (not exists $Debbugs::Status::fields{$key}) {
3321                  delete $new_data->{$key};
3322                  next;
3323              }
3324              next unless exists $old_data->{$key};
3325              next unless defined $old_data->{$key};
3326              if (not defined $new_data->{$key} or
3327                  not exists $Debbugs::Status::fields{$key}) {
3328                  delete $new_data->{$key};
3329                  next;
3330              }
3331              if (ref($new_data->{$key}) and
3332                  ref($old_data->{$key}) and
3333                  ref($new_data->{$key}) eq ref($old_data->{$key})) {
3334                 local $Storable::canonical = 1;
3335                 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3336                     delete $new_data->{$key};
3337                     delete $old_data->{$key};
3338                 }
3339              }
3340              elsif ($new_data->{$key} eq $old_data->{$key}) {
3341                  delete $new_data->{$key};
3342                  delete $old_data->{$key};
3343              }
3344          }
3345          $data_diff .= "<!-- new_data:\n";
3346          my %nd;
3347          for my $key (keys %{$new_data}) {
3348              if (not exists $Debbugs::Status::fields{$key}) {
3349                  warn "No such field $key";
3350                  next;
3351              }
3352              $nd{$key} = $new_data->{$key};
3353              # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3354          }
3355          $data_diff .= html_escape(Data::Dumper->Dump([\%nd],[qw(new_data)]));
3356          $data_diff .= "-->\n";
3357          $data_diff .= "<!-- old_data:\n";
3358          my %od;
3359          for my $key (keys %{$old_data}) {
3360              if (not exists $Debbugs::Status::fields{$key}) {
3361                  warn "No such field $key";
3362                  next;
3363              }
3364              $od{$key} = $old_data->{$key};
3365              # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3366          }
3367          $data_diff .= html_escape(Data::Dumper->Dump([\%od],[qw(old_data)]));
3368          $data_diff .= "-->\n";
3369      }
3370      my $msg = join('',
3371                     (exists $param{command} ?
3372                      "<!-- command:".html_escape($param{command})." -->\n":""
3373                     ),
3374                     (length $param{requester} ?
3375                      "<!-- requester: ".html_escape($param{requester})." -->\n":""
3376                     ),
3377                     (length $param{request_addr} ?
3378                      "<!-- request_addr: ".html_escape($param{request_addr})." -->\n":""
3379                     ),
3380                     "<!-- time:".time()." -->\n",
3381                     $data_diff,
3382                     "<strong>".html_escape($param{action})."</strong>\n");
3383      if (length $param{requester}) {
3384           $msg .= "Request was from <code>".html_escape($param{requester})."</code>\n";
3385      }
3386      if (length $param{request_addr}) {
3387           $msg .= "to <code>".html_escape($param{request_addr})."</code>";
3388      }
3389      if (length $param{desc}) {
3390           $msg .= ":<br>\n$param{desc}\n";
3391      }
3392      else {
3393           $msg .= ".\n";
3394      }
3395      push @records, {type => 'html',
3396                      text => $msg,
3397                     };
3398      $msg = '';
3399      if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3400          push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3401                          exists $param{recips}?(recips => [make_list($param{recips})]):(),
3402                          text => join('',make_list($param{message})),
3403                         };
3404      }
3405      write_log_records(logfh=>$logfh,
3406                        records => \@records,
3407                       );
3408      close $logfh or die "Unable to close $log_location: $!";
3409      if ($param{get_lock}) {
3410           unfilelock(exists $param{locks}?$param{locks}:());
3411           $locks--;
3412      }
3413
3414
3415 }
3416
3417
3418 =head1 PRIVATE FUNCTIONS
3419
3420 =head2 __handle_affected_packages
3421
3422      __handle_affected_packages(affected_packages => {},
3423                                 data => [@data],
3424                                )
3425
3426
3427
3428 =cut
3429
3430 sub __handle_affected_packages{
3431      my %param = validate_with(params => \@_,
3432                                spec   => {%common_options,
3433                                           data => {type => ARRAYREF|HASHREF
3434                                                   },
3435                                          },
3436                                allow_extra => 1,
3437                               );
3438      for my $data (make_list($param{data})) {
3439           next unless exists $data->{package} and defined $data->{package};
3440           my @packages = split /\s*,\s*/,$data->{package};
3441           @{$param{affected_packages}}{@packages} = (1) x @packages;
3442       }
3443 }
3444
3445 =head2 __handle_debug_transcript
3446
3447      my ($debug,$transcript) = __handle_debug_transcript(%param);
3448
3449 Returns a debug and transcript filehandle
3450
3451
3452 =cut
3453
3454 sub __handle_debug_transcript{
3455      my %param = validate_with(params => \@_,
3456                                spec   => {%common_options},
3457                                allow_extra => 1,
3458                               );
3459      my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3460      my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3461      return ($debug,$transcript);
3462 }
3463
3464 =head2 __bug_info
3465
3466      __bug_info($data)
3467
3468 Produces a small bit of bug information to kick out to the transcript
3469
3470 =cut
3471
3472 sub __bug_info{
3473      my $return = '';
3474      for my $data (@_) {
3475          next unless defined $data and exists $data->{bug_num};
3476           $return .= "Bug #".($data->{bug_num}||'').
3477               ((defined $data->{done} and length $data->{done})?
3478                 " {Done: $data->{done}}":''
3479                ).
3480                " [".($data->{package}||'(no package)'). "] ".
3481                     ($data->{subject}||'(no subject)')."\n";
3482      }
3483      return $return;
3484 }
3485
3486
3487 =head2 __internal_request
3488
3489      __internal_request()
3490      __internal_request($level)
3491
3492 Returns true if the caller of the function calling __internal_request
3493 belongs to __PACKAGE__
3494
3495 This allows us to be magical, and don't bother to print bug info if
3496 the second caller is from this package, amongst other things.
3497
3498 An optional level is allowed, which increments the number of levels to
3499 check by the given value. [This is basically for use by internal
3500 functions like __begin_control which are always called by
3501 C<__PACKAGE__>.
3502
3503 =cut
3504
3505 sub __internal_request{
3506     my ($l) = @_;
3507     $l = 0 if not defined $l;
3508     if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3509         return 1;
3510     }
3511     return 0;
3512 }
3513
3514 sub __return_append_to_log_options{
3515      my %param = @_;
3516      my $action = $param{action} if exists $param{action};
3517      if (not exists $param{requester}) {
3518           $param{requester} = $config{control_internal_requester};
3519      }
3520      if (not exists $param{request_addr}) {
3521           $param{request_addr} = $config{control_internal_request_addr};
3522      }
3523      if (not exists $param{message}) {
3524           my $date = rfc822_date();
3525           $param{message} = fill_in_template(template  => 'mail/fake_control_message',
3526                                              variables => {request_addr => $param{request_addr},
3527                                                            requester    => $param{requester},
3528                                                            date         => $date,
3529                                                            action       => $action
3530                                                           },
3531                                             );
3532      }
3533      if (not defined $action) {
3534           carp "Undefined action!";
3535           $action = "unknown action";
3536      }
3537      return (action => $action,
3538              hash_slice(%param,keys %append_action_options),
3539             );
3540 }
3541
3542 =head2 __begin_control
3543
3544      my %info = __begin_control(%param,
3545                                 archived=>1,
3546                                 command=>'unarchive');
3547      my ($debug,$transcript) = @info{qw(debug transcript)};
3548      my @data = @{$info{data}};
3549      my @bugs = @{$info{bugs}};
3550
3551
3552 Starts the process of modifying a bug; handles all of the generic
3553 things that almost every control request needs
3554
3555 Returns a hash containing
3556
3557 =over
3558
3559 =item new_locks -- number of new locks taken out by this call
3560
3561 =item debug -- the debug file handle
3562
3563 =item transcript -- the transcript file handle
3564
3565 =item data -- an arrayref containing the data of the bugs
3566 corresponding to this request
3567
3568 =item bugs -- an arrayref containing the bug numbers of the bugs
3569 corresponding to this request
3570
3571 =back
3572
3573 =cut
3574
3575 our $lockhash;
3576
3577 sub __begin_control {
3578     my %param = validate_with(params => \@_,
3579                               spec   => {bug => {type   => SCALAR,
3580                                                  regex  => qr/^\d+/,
3581                                                 },
3582                                          archived => {type => BOOLEAN,
3583                                                       default => 0,
3584                                                      },
3585                                          command  => {type => SCALAR,
3586                                                       optional => 1,
3587                                                      },
3588                                          %common_options,
3589                                         },
3590                               allow_extra => 1,
3591                              );
3592     my $new_locks;
3593     my ($debug,$transcript) = __handle_debug_transcript(@_);
3594     print {$debug} "considering bug $param{bug} for ".(exists $param{command}?$param{command}:scalar caller())."\n";
3595 #    print {$debug} Data::Dumper->Dump([[caller(1)],\%param],[qw(caller param)])."\n";
3596     $lockhash = $param{locks} if exists $param{locks};
3597     my @data = ();
3598     my $old_die = $SIG{__DIE__};
3599     $SIG{__DIE__} = *sig_die{CODE};
3600
3601     ($new_locks, @data) =
3602         lock_read_all_merged_bugs(bug => $param{bug},
3603                                   $param{archived}?(location => 'archive'):(),
3604                                   exists $param{locks} ? (locks => $param{locks}):(),
3605                                  );
3606     $locks += $new_locks;
3607     if (not @data) {
3608         die "Unable to read any bugs successfully.";
3609     }
3610     if (not $param{archived}) {
3611         for my $data (@data) {
3612             if ($data->{archived}) {
3613                 die "Not altering archived bugs; see unarchive.";
3614             }
3615         }
3616     }
3617     if (not __check_limit(data => \@data,
3618                           exists $param{limit}?(limit => $param{limit}):(),
3619                           transcript => $transcript,
3620                          )) {
3621         die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3622     }
3623
3624     __handle_affected_packages(%param,data => \@data);
3625     print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3626     print {$debug} "$param{bug} read $locks locks\n";
3627     if (not @data or not defined $data[0]) {
3628         print {$transcript} "No bug found for $param{bug}\n";
3629         die "No bug found for $param{bug}";
3630     }
3631
3632     add_recipients(data => \@data,
3633                    recipients => $param{recipients},
3634                    (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3635                    debug      => $debug,
3636                    (__internal_request()?(transcript => $transcript):()),
3637                   );
3638
3639     print {$debug} "$param{bug} read done\n";
3640     my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3641     print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3642     return (data       => \@data,
3643             bugs       => \@bugs,
3644             old_die    => $old_die,
3645             new_locks  => $new_locks,
3646             debug      => $debug,
3647             transcript => $transcript,
3648             param      => \%param,
3649             exists $param{locks}?(locks => $param{locks}):(),
3650            );
3651 }
3652
3653 =head2 __end_control
3654
3655      __end_control(%info);
3656
3657 Handles tearing down from a control request
3658
3659 =cut
3660
3661 sub __end_control {
3662     my %info = @_;
3663     if (exists $info{new_locks} and $info{new_locks} > 0) {
3664         print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3665         for (1..$info{new_locks}) {
3666             unfilelock(exists $info{locks}?$info{locks}:());
3667             $locks--;
3668         }
3669     }
3670     $SIG{__DIE__} = $info{old_die};
3671     if (exists $info{param}{affected_bugs}) {
3672         @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3673     }
3674     add_recipients(recipients => $info{param}{recipients},
3675                    (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3676                    data       => $info{data},
3677                    debug      => $info{debug},
3678                    transcript => $info{transcript},
3679                   );
3680     __handle_affected_packages(%{$info{param}},data=>$info{data});
3681 }
3682
3683
3684 =head2 __check_limit
3685
3686      __check_limit(data => \@data, limit => $param{limit});
3687
3688
3689 Checks to make sure that bugs match any limits; each entry of @data
3690 much satisfy the limit.
3691
3692 Returns true if there are no entries in data, or there are no keys in
3693 limit; returns false (0) if there are any entries which do not match.
3694
3695 The limit hashref elements can contain an arrayref of scalars to
3696 match; regexes are also acccepted. At least one of the entries in each
3697 element needs to match the corresponding field in all data for the
3698 limit to succeed.
3699
3700 =cut
3701
3702
3703 sub __check_limit{
3704     my %param = validate_with(params => \@_,
3705                               spec   => {data  => {type => ARRAYREF|SCALAR,
3706                                                   },
3707                                          limit => {type => HASHREF|UNDEF,
3708                                                   },
3709                                          transcript  => {type => SCALARREF|HANDLE,
3710                                                          optional => 1,
3711                                                         },
3712                                         },
3713                              );
3714     my @data = make_list($param{data});
3715     if (not @data or
3716         not defined $param{limit} or
3717         not keys %{$param{limit}}) {
3718         return 1;
3719     }
3720     my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3721     my $going_to_fail = 0;
3722     for my $data (@data) {
3723         $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3724                                                    status => dclone($data),
3725                                                   ));
3726         for my $field (keys %{$param{limit}}) {
3727             next unless exists $param{limit}{$field};
3728             my $match = 0;
3729             my @data_fields = make_list($data->{$field});
3730 LIMIT:      for my $limit (make_list($param{limit}{$field})) {
3731                 if (not ref $limit) {
3732                     for my $data_field (@data_fields) {
3733                         if ($data_field eq $limit) {
3734                             $match = 1;
3735                             last LIMIT;
3736                         }
3737                     }
3738                 }
3739                 elsif (ref($limit) eq 'Regexp') {
3740                     for my $data_field (@data_fields) {
3741                         if ($data_field =~ $limit) {
3742                             $match = 1;
3743                             last LIMIT;
3744                         }
3745                     }
3746                 }
3747                 else {
3748                     warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3749                 }
3750             }
3751             if (not $match) {
3752                 $going_to_fail = 1;
3753                 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3754                     "' does not match at least one of ".
3755                     join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3756             }
3757         }
3758     }
3759     return $going_to_fail?0:1;
3760 }
3761
3762
3763 =head2 die
3764
3765      sig_die "foo"
3766
3767 We override die to specially handle unlocking files in the cases where
3768 we are called via eval. [If we're not called via eval, it doesn't
3769 matter.]
3770
3771 =cut
3772
3773 sub sig_die{
3774     if ($^S) { # in eval
3775         if ($locks) {
3776             for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3777             $locks = 0;
3778         }
3779     }
3780 }
3781
3782
3783 # =head2 __message_body_template
3784 #
3785 #      message_body_template('mail/ack',{ref=>'foo'});
3786 #
3787 # Creates a message body using a template
3788 #
3789 # =cut
3790
3791 sub __message_body_template{
3792      my ($template,$extra_var) = @_;
3793      $extra_var ||={};
3794      my $hole_var = {'&bugurl' =>
3795                      sub{"$_[0]: ".
3796                              'http://'.$config{cgi_domain}.'/'.
3797                                  Debbugs::CGI::bug_url($_[0]);
3798                      }
3799                     };
3800
3801      my $body = fill_in_template(template => $template,
3802                                  variables => {config => \%config,
3803                                                %{$extra_var},
3804                                               },
3805                                  hole_var => $hole_var,
3806                                 );
3807      return fill_in_template(template => 'mail/message_body',
3808                              variables => {config => \%config,
3809                                            %{$extra_var},
3810                                            body => $body,
3811                                           },
3812                              hole_var => $hole_var,
3813                             );
3814 }
3815
3816 sub __all_undef_or_equal {
3817     my @values = @_;
3818     return 1 if @values == 1 or @values == 0;
3819     my $not_def = grep {not defined $_} @values;
3820     if ($not_def == @values) {
3821         return 1;
3822     }
3823     if ($not_def > 0 and $not_def != @values) {
3824         return 0;
3825     }
3826     my $first_val = shift @values;
3827     for my $val (@values) {
3828         if ($first_val ne $val) {
3829             return 0;
3830         }
3831     }
3832     return 1;
3833 }
3834
3835
3836 1;
3837
3838 __END__