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