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