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