Debbugs/Control.pm

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