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