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