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