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