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