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