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                 elsif (not grep {$version eq $_} @svers) {
1582                     # The $version was not equal to one of the source
1583                     # versions, so it's probably unqualified (or just
1584                     # wrong). Delete it, and use the source versions
1585                     # instead.
1586                     if (exists $found_versions{$version}) {
1587                         delete $found_versions{$version};
1588                         $found_removed{$version} = 1;
1589                     }
1590                 }
1591                 for my $sver (@svers) {
1592                     if (not exists $found_versions{$sver}) {
1593                         $found_versions{$sver} = 1;
1594                         $found_added{$sver} = 1;
1595                     }
1596                     # if the found we are adding matches any fixed
1597                     # versions, remove them
1598                     my @temp = grep m{(^|/)\Q$sver\E$}, keys %fixed_versions;
1599                     delete $fixed_versions{$_} for @temp;
1600                     $fixed_removed{$_} = 1 for @temp;
1601                 }
1602
1603                 # We only care about reopening the bug if the bug is
1604                 # not done
1605                 if (defined $data->{done} and length $data->{done}) {
1606                     my @svers_order = sort_versions(map {m{([^/]+)$}; $1;}
1607                                                     @svers);
1608                     # determine if we need to reopen
1609                     my @fixed_order = sort_versions(map {m{([^/]+)$}; $1;}
1610                                                     keys %fixed_versions);
1611                     if (not @fixed_order or
1612                         (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1613                         $reopened = 1;
1614                         $data->{done} = '';
1615                     }
1616                 }
1617             }
1618             elsif ($param{remove}) {
1619                 # in the case of removal, we only concern ourself with
1620                 # the version passed, not the source version it maps
1621                 # to
1622                 my @temp = grep m{(?:^|/)\Q$version\E$}, keys %found_versions;
1623                 delete $found_versions{$_} for @temp;
1624                 $found_removed{$_} = 1 for @temp;
1625             }
1626             else {
1627                 # set the keys to exactly these values
1628                 my @svers = @{$versions{$version}};
1629                 if (not @svers) {
1630                     @svers = $version;
1631                 }
1632                 for my $sver (@svers) {
1633                     if (not exists $found_versions{$sver}) {
1634                         $found_versions{$sver} = 1;
1635                         if (exists $found_removed{$sver}) {
1636                             delete $found_removed{$sver};
1637                         }
1638                         else {
1639                             $found_added{$sver} = 1;
1640                         }
1641                     }
1642                 }
1643             }
1644         }
1645
1646         $data->{found_versions} = [keys %found_versions];
1647         $data->{fixed_versions} = [keys %fixed_versions];
1648
1649         my @changed;
1650         push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1651         push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1652 #       push @changed, 'marked as fixed in versions '.english_join([keys %fixed_addded]) if keys %fixed_added;
1653         push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1654         $action = ucfirst(join ('; ',@changed)) if @changed;
1655         if ($reopened) {
1656             $action .= " and reopened"
1657         }
1658         if (not $reopened and not @changed) {
1659             print {$transcript} "Ignoring request to alter found versions of bug #$data->{bug_num} to the same values previously set\n";
1660             next;
1661         }
1662         $action .= '.';
1663         append_action_to_log(bug => $data->{bug_num},
1664                              get_lock => 0,
1665                              command  => 'found',
1666                              old_data => $old_data,
1667                              new_data => $data,
1668                              __return_append_to_log_options(
1669                                                             %param,
1670                                                             action => $action,
1671                                                            ),
1672                             )
1673             if not exists $param{append_log} or $param{append_log};
1674         writebug($data->{bug_num},$data);
1675         print {$transcript} "$action\n";
1676     }
1677     __end_control(%info);
1678 }
1679
1680 =head2 set_fixed
1681
1682      eval {
1683             set_fixed(bug          => $ref,
1684                       transcript   => $transcript,
1685                       ($dl > 0 ? (debug => $transcript):()),
1686                       requester    => $header{from},
1687                       request_addr => $controlrequestaddr,
1688                       message      => \@log,
1689                       affected_packages => \%affected_packages,
1690                       recipients   => \%recipients,
1691                       fixed        => [],
1692                       add          => 1,
1693                       reopen       => 0,
1694                      );
1695         };
1696         if ($@) {
1697             $errors++;
1698             print {$transcript} "Failed to set fixed on $ref: $@";
1699         }
1700
1701
1702 Sets, adds, or removes the specified fixed versions of a package
1703
1704 If the fixed versions are empty (or end up being empty after this
1705 call) or the greatest fixed version is less than the greatest found
1706 version and the reopen option is true, the bug is reopened.
1707
1708 This function is also called by the reopen function, which causes all
1709 of the fixed versions to be cleared.
1710
1711 =cut
1712
1713 sub set_fixed {
1714     my %param = validate_with(params => \@_,
1715                               spec   => {bug => {type   => SCALAR,
1716                                                  regex  => qr/^\d+$/,
1717                                                 },
1718                                          # specific options here
1719                                          fixed    => {type => SCALAR|ARRAYREF,
1720                                                       default => [],
1721                                                      },
1722                                          add      => {type => BOOLEAN,
1723                                                       default => 0,
1724                                                      },
1725                                          remove   => {type => BOOLEAN,
1726                                                       default => 0,
1727                                                      },
1728                                          reopen   => {type => BOOLEAN,
1729                                                       default => 0,
1730                                                      },
1731                                          %common_options,
1732                                          %append_action_options,
1733                                         },
1734                              );
1735     if ($param{add} and $param{remove}) {
1736         croak "It's nonsensical to add and remove the same versions";
1737     }
1738     my %info =
1739         __begin_control(%param,
1740                         command  => 'fixed'
1741                        );
1742     my ($debug,$transcript) =
1743         @info{qw(debug transcript)};
1744     my @data = @{$info{data}};
1745     my @bugs = @{$info{bugs}};
1746     my %versions;
1747     for my $version (make_list($param{fixed})) {
1748         next unless defined $version;
1749         $versions{$version} =
1750             [make_source_versions(package => [splitpackages($data[0]{package})],
1751                                   warnings => $transcript,
1752                                   debug    => $debug,
1753                                   guess_source => 0,
1754                                   versions     => $version,
1755                                  )
1756             ];
1757         # This is really ugly, but it's what we have to do
1758         if (not @{$versions{$version}}) {
1759             print {$transcript} "Unable to make a source version for version '$version'\n";
1760         }
1761     }
1762     if (not keys %versions and ($param{remove} or $param{add})) {
1763         if ($param{remove}) {
1764             print {$transcript} "Requested to remove no versions; doing nothing.\n";
1765         }
1766         else {
1767             print {$transcript} "Requested to add no versions; doing nothing.\n";
1768         }
1769         __end_control(%info);
1770         return;
1771     }
1772     # first things first, make the versions fully qualified source
1773     # versions
1774     for my $data (@data) {
1775         my $old_data = dclone($data);
1776         # The 'done' field gets a bit weird with version tracking,
1777         # because a bug may be closed by multiple people in different
1778         # branches. Until we have something more flexible, we set it
1779         # every time a bug is fixed, and clear it when a bug is found
1780         # in a version greater than any version in which the bug is
1781         # fixed or when a bug is found and there is no fixed version
1782         my $action = 'Did not alter fixed versions';
1783         my %found_added = ();
1784         my %found_removed = ();
1785         my %fixed_added = ();
1786         my %fixed_removed = ();
1787         my $reopened = 0;
1788         if (not $param{add} and not $param{remove}) {
1789             $fixed_removed{$_} = 1 for @{$data->{fixed_versions}};
1790             $data->{fixed_versions} = [];
1791         }
1792         my %found_versions;
1793         @found_versions{@{$data->{found_versions}||[]}} = (1) x @{$data->{found_versions}||[]};
1794         my %fixed_versions;
1795         @fixed_versions{@{$data->{fixed_versions}||[]}} = (1) x @{$data->{fixed_versions}||[]};
1796         for my $version (keys %versions) {
1797             if ($param{add}) {
1798                 my @svers = @{$versions{$version}};
1799                 if (not @svers) {
1800                     @svers = $version;
1801                 }
1802                 else {
1803                     if (exists $fixed_versions{$version}) {
1804                         $fixed_removed{$version} = 1;
1805                         delete $fixed_versions{$version};
1806                     }
1807                 }
1808                 for my $sver (@svers) {
1809                     if (not exists $fixed_versions{$sver}) {
1810                         $fixed_versions{$sver} = 1;
1811                         $fixed_added{$sver} = 1;
1812                     }
1813                 }
1814             }
1815             elsif ($param{remove}) {
1816                 # in the case of removal, we only concern ourself with
1817                 # the version passed, not the source version it maps
1818                 # to
1819                 my @temp = grep m{(?:^|\/)\Q$version\E$}, keys %fixed_versions;
1820                 delete $fixed_versions{$_} for @temp;
1821                 $fixed_removed{$_} = 1 for @temp;
1822             }
1823             else {
1824                 # set the keys to exactly these values
1825                 my @svers = @{$versions{$version}};
1826                 if (not @svers) {
1827                     @svers = $version;
1828                 }
1829                 for my $sver (@svers) {
1830                     if (not exists $fixed_versions{$sver}) {
1831                         $fixed_versions{$sver} = 1;
1832                         if (exists $fixed_removed{$sver}) {
1833                             delete $fixed_removed{$sver};
1834                         }
1835                         else {
1836                             $fixed_added{$sver} = 1;
1837                         }
1838                     }
1839                 }
1840             }
1841         }
1842
1843         $data->{found_versions} = [keys %found_versions];
1844         $data->{fixed_versions} = [keys %fixed_versions];
1845
1846         # If we're supposed to consider reopening, reopen if the
1847         # fixed versions are empty or the greatest found version
1848         # is greater than the greatest fixed version
1849         if ($param{reopen} and defined $data->{done}
1850             and length $data->{done}) {
1851             my @svers_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1852                 map {m{([^/]+)$}; $1;} @{$data->{found_versions}};
1853             # determine if we need to reopen
1854             my @fixed_order = sort {Debbugs::Versions::Dpkg::vercmp($a,$b);}
1855                     map {m{([^/]+)$}; $1;} @{$data->{fixed_versions}};
1856             if (not @fixed_order or
1857                 (Debbugs::Versions::Dpkg::vercmp($svers_order[-1],$fixed_order[-1]) >= 0)) {
1858                 $reopened = 1;
1859                 $data->{done} = '';
1860             }
1861         }
1862
1863         my @changed;
1864         push @changed, 'marked as found in versions '.english_join([keys %found_added]) if keys %found_added;
1865         push @changed, 'no longer marked as found in versions '.english_join([keys %found_removed]) if keys %found_removed;
1866         push @changed, 'marked as fixed in versions '.english_join([keys %fixed_added]) if keys %fixed_added;
1867         push @changed, 'no longer marked as fixed in versions '.english_join([keys %fixed_removed]) if keys %fixed_removed;
1868         $action = ucfirst(join ('; ',@changed)) if @changed;
1869         if ($reopened) {
1870             $action .= " and reopened"
1871         }
1872         if (not $reopened and not @changed) {
1873             print {$transcript} "Ignoring request to alter fixed versions of bug #$data->{bug_num} to the same values previously set\n";
1874             next;
1875         }
1876         $action .= '.';
1877         append_action_to_log(bug => $data->{bug_num},
1878                              command  => 'fixed',
1879                              new_data => $data,
1880                              old_data => $old_data,
1881                              get_lock => 0,
1882                              __return_append_to_log_options(
1883                                                             %param,
1884                                                             action => $action,
1885                                                            ),
1886                             )
1887             if not exists $param{append_log} or $param{append_log};
1888         writebug($data->{bug_num},$data);
1889         print {$transcript} "$action\n";
1890     }
1891     __end_control(%info);
1892 }
1893
1894
1895 =head2 set_merged
1896
1897      eval {
1898             set_merged(bug          => $ref,
1899                        transcript   => $transcript,
1900                        ($dl > 0 ? (debug => $transcript):()),
1901                        requester    => $header{from},
1902                        request_addr => $controlrequestaddr,
1903                        message      => \@log,
1904                        affected_packages => \%affected_packages,
1905                        recipients   => \%recipients,
1906                        merge_with   => 12345,
1907                        add          => 1,
1908                        force        => 1,
1909                        allow_reassign => 1,
1910                        reassign_same_source_only => 1,
1911                       );
1912         };
1913         if ($@) {
1914             $errors++;
1915             print {$transcript} "Failed to set merged on $ref: $@";
1916         }
1917
1918
1919 Sets, adds, or removes the specified merged bugs of a bug
1920
1921 By default, requires
1922
1923 =cut
1924
1925 sub set_merged {
1926     my %param = validate_with(params => \@_,
1927                               spec   => {bug => {type   => SCALAR,
1928                                                  regex  => qr/^\d+$/,
1929                                                 },
1930                                          # specific options here
1931                                          merge_with => {type => ARRAYREF|SCALAR,
1932                                                         optional => 1,
1933                                                        },
1934                                          remove   => {type => BOOLEAN,
1935                                                       default => 0,
1936                                                      },
1937                                          force    => {type => BOOLEAN,
1938                                                       default => 0,
1939                                                      },
1940                                          masterbug => {type => BOOLEAN,
1941                                                        default => 0,
1942                                                       },
1943                                          allow_reassign => {type => BOOLEAN,
1944                                                             default => 0,
1945                                                            },
1946                                          reassign_different_sources => {type => BOOLEAN,
1947                                                                         default => 1,
1948                                                                        },
1949                                          %common_options,
1950                                          %append_action_options,
1951                                         },
1952                              );
1953     my @merging = exists $param{merge_with} ? make_list($param{merge_with}):();
1954     my %merging;
1955     @merging{@merging} = (1) x @merging;
1956     if (grep {$_ !~ /^\d+$/} @merging) {
1957         croak "Requested to merge with a non-numeric bug: ".join(',',map {qq('$_');} @merging);
1958     }
1959     $param{locks} = {} if not exists $param{locks};
1960     my %info =
1961         __begin_control(%param,
1962                         command  => 'merge'
1963                        );
1964     my ($debug,$transcript) =
1965         @info{qw(debug transcript)};
1966     if (not @merging and exists $param{merge_with}) {
1967         print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
1968         __end_control(%info);
1969         return;
1970     }
1971     my @data = @{$info{data}};
1972     my @bugs = @{$info{bugs}};
1973     my %data;
1974     my %merged_bugs;
1975     for my $data (@data) {
1976         $data{$data->{bug_num}} = $data;
1977         my @merged_bugs = split / /, $data->{mergedwith};
1978         @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
1979     }
1980     # handle unmerging
1981     my $new_locks = 0;
1982     if (not exists $param{merge_with}) {
1983         my $ok_to_unmerge = 1;
1984         delete $merged_bugs{$param{bug}};
1985         if (not keys %merged_bugs) {
1986             print {$transcript} "Ignoring request to unmerge a bug which is not merged with any others.\n";
1987             __end_control(%info);
1988             return;
1989         }
1990         my $action = "Disconnected #$param{bug} from all other report(s).";
1991         for my $data (@data) {
1992             my $old_data = dclone($data);
1993             if ($data->{bug_num} == $param{bug}) {
1994                 $data->{mergedwith} = '';
1995             }
1996             else {
1997                 $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
1998                                             keys %merged_bugs);
1999             }
2000             append_action_to_log(bug => $data->{bug_num},
2001                                  command  => 'merge',
2002                                  new_data => $data,
2003                                  old_data => $old_data,
2004                                  get_lock => 0,
2005                                  __return_append_to_log_options(%param,
2006                                                                 action => $action,
2007                                                                ),
2008                                 )
2009                 if not exists $param{append_log} or $param{append_log};
2010             writebug($data->{bug_num},$data);
2011         }
2012         print {$transcript} "$action\n";
2013         __end_control(%info);
2014         return;
2015     }
2016     # lock and load all of the bugs we need
2017     my @bugs_to_load = keys %merging;
2018     my $bug_to_load;
2019     my %merge_added;
2020     my ($data,$n_locks) =
2021         __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2022                                     data => \@data,
2023                                     locks => $param{locks},
2024                                     debug => $debug,
2025                                    );
2026     $new_locks += $n_locks;
2027     %data = %{$data};
2028     @data = values %data;
2029     if (not check_limit(data => [@data],
2030                           exists $param{limit}?(limit => $param{limit}):(),
2031                           transcript => $transcript,
2032                          )) {
2033         die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
2034     }
2035     for my $data (@data) {
2036         $data{$data->{bug_num}} = $data;
2037         $merged_bugs{$data->{bug_num}} = 1;
2038         my @merged_bugs = split / /, $data->{mergedwith};
2039         @merged_bugs{@merged_bugs} = (1) x @merged_bugs;
2040         if (exists $param{affected_bugs}) {
2041             $param{affected_bugs}{$data->{bug_num}} = 1;
2042         }
2043     }
2044     __handle_affected_packages(%param,data => [@data]);
2045     my %bug_info_shown; # which bugs have had information shown
2046     $bug_info_shown{$param{bug}} = 1;
2047     add_recipients(data => [@data],
2048                    recipients => $param{recipients},
2049                    (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
2050                    debug      => $debug,
2051                    (__internal_request()?(transcript => $transcript):()),
2052                   );
2053
2054     # Figure out what the ideal state is for the bug,
2055     my ($merge_status,$bugs_to_merge) =
2056         __calculate_merge_status(\@data,\%data,$param{bug});
2057     # find out if we actually have any bugs to merge
2058     if (not $bugs_to_merge) {
2059         print {$transcript} "Requested to merge with no additional bugs; not doing anything\n";
2060         for (1..$new_locks) {
2061             unfilelock($param{locks});
2062             $locks--;
2063         }
2064         __end_control(%info);
2065         return;
2066     }
2067     # see what changes need to be made to merge the bugs
2068     # check to make sure that the set of changes we need to make is allowed
2069     my ($disallowed_changes,$changes) =
2070         __calculate_merge_changes(\@data,$merge_status,\%param);
2071     # at this point, stop if there are disallowed changes, otherwise
2072     # make the allowed changes, and then reread the bugs in question
2073     # to get the new data, then recaculate the merges; repeat
2074     # reloading and recalculating until we try too many times or there
2075     # are no changes to make.
2076
2077     my $attempts = 0;
2078     # we will allow at most 4 times through this; more than 1
2079     # shouldn't really happen.
2080     my %bug_changed;
2081     while ($attempts < 4 and (@{$disallowed_changes} or keys %{$changes})) {
2082         if ($attempts > 1) {
2083             print {$transcript} "Unable to complete merge on previous attempt; trying again (retry: $attempts)\n";
2084         }
2085         if (@{$disallowed_changes}) {
2086             # figure out the problems
2087             print {$transcript} "Unable to merge bugs because:\n";
2088             for my $change (@{$disallowed_changes}) {
2089                 print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n";
2090             }
2091             if ($attempts > 0) {
2092                 croak "Some bugs were altered while attempting to merge";
2093             }
2094             else {
2095                 croak "Did not alter merged bugs";
2096             }
2097         }
2098         my @bugs_to_change = keys %{$changes};
2099         for my $change_bug (@bugs_to_change) {
2100             next unless exists $changes->{$change_bug};
2101             $bug_changed{$change_bug}++;
2102             print {$transcript} __bug_info($data{$change_bug}) if
2103                 $param{show_bug_info} and not __internal_request(1);
2104             $bug_info_shown{$change_bug} = 1;
2105             __allow_relocking($param{locks},[keys %data]);
2106             for my $change (@{$changes->{$change_bug}}) {
2107                 if ($change->{field} eq 'blockedby' or $change->{field} eq 'blocks') {
2108                     my %target_blockedby;
2109                     @target_blockedby{@{$change->{func_value}}} = (1) x @{$change->{func_value}};
2110                     my %unhandled_targets = %target_blockedby;
2111                     my @blocks_to_remove;
2112                     for my $key (split / /,$change->{orig_value}) {
2113                         delete $unhandled_targets{$key};
2114                         next if exists $target_blockedby{$key};
2115                         set_blocks(bug    => $change->{field} eq 'blocks' ? $key : $change->{bug},
2116                                    block  => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2117                                    remove => 1,
2118                                    hash_slice(%param,
2119                                               keys %common_options,
2120                                               keys %append_action_options),
2121                                   );
2122                     }
2123                     for my $key (keys %unhandled_targets) {
2124                         set_blocks(bug    => $change->{field} eq 'blocks' ? $key : $change->{bug},
2125                                    block  => $change->{field} eq 'blocks' ? $change->{bug} : $key,
2126                                    add   => 1,
2127                                    hash_slice(%param,
2128                                               keys %common_options,
2129                                               keys %append_action_options),
2130                                   );
2131                     }
2132                 }
2133                 else {
2134                     $change->{function}->(bug => $change->{bug},
2135                                           $change->{key}, $change->{func_value},
2136                                           exists $change->{options}?@{$change->{options}}:(),
2137                                           hash_slice(%param,
2138                                                      keys %common_options,
2139                                                      keys %append_action_options),
2140                                          );
2141                 }
2142             }
2143             __disallow_relocking($param{locks});
2144             my ($data,$n_locks) =
2145                 __lock_and_load_merged_bugs(bugs_to_load => [keys %merging],
2146                                             data => \@data,
2147                                             locks => $param{locks},
2148                                             debug => $debug,
2149                                             reload_all => 1,
2150                                            );
2151             $new_locks += $n_locks;
2152             $locks += $n_locks;
2153             %data = %{$data};
2154             @data = values %data;
2155             ($merge_status,$bugs_to_merge) =
2156                 __calculate_merge_status(\@data,\%data,$param{bug},$merge_status);
2157             ($disallowed_changes,$changes) =
2158                 __calculate_merge_changes(\@data,$merge_status,\%param);
2159             $attempts = max(values %bug_changed);
2160         }
2161     }
2162     if ($param{show_bug_info} and not __internal_request(1)) {
2163         for my $data (sort {$a->{bug_num} <=> $b->{bug_num}} @data) {
2164             next if $bug_info_shown{$data->{bug_num}};
2165             print {$transcript} __bug_info($data);
2166         }
2167     }
2168     if (keys %{$changes} or @{$disallowed_changes}) {
2169         print {$transcript} "After four attempts, the following changes were unable to be made:\n";
2170         for (1..$new_locks) {
2171             unfilelock($param{locks});
2172             $locks--;
2173         }
2174         __end_control(%info);
2175         for my $change ((map {@{$_}} values %{$changes}), @{$disallowed_changes}) {
2176             print {$transcript} "$change->{field} of #$change->{bug} is '$change->{text_orig_value}' not '$change->{text_value}'\n";
2177         }
2178         die "Unable to modify bugs so they could be merged";
2179         return;
2180     }
2181
2182     # finally, we can merge the bugs
2183     my $action = "Merged ".join(' ',sort keys %merged_bugs);
2184     for my $data (@data) {
2185         my $old_data = dclone($data);
2186         $data->{mergedwith} = join(' ',sort grep {$_ != $data->{bug_num}}
2187                                     keys %merged_bugs);
2188         append_action_to_log(bug => $data->{bug_num},
2189                              command  => 'merge',
2190                              new_data => $data,
2191                              old_data => $old_data,
2192                              get_lock => 0,
2193                              __return_append_to_log_options(%param,
2194                                                             action => $action,
2195                                                            ),
2196                             )
2197             if not exists $param{append_log} or $param{append_log};
2198         writebug($data->{bug_num},$data);
2199     }
2200     print {$transcript} "$action\n";
2201     # unlock the extra locks that we got earlier
2202     for (1..$new_locks) {
2203         unfilelock($param{locks});
2204         $locks--;
2205     }
2206     __end_control(%info);
2207 }
2208
2209 sub __allow_relocking{
2210     my ($locks,$bugs) = @_;
2211
2212     my @locks = (@{$bugs},'merge');
2213     for my $lock (@locks) {
2214         my @lockfiles = grep {m{/\Q$lock\E$}} keys %{$locks->{locks}};
2215         next unless @lockfiles;
2216         $locks->{relockable}{$lockfiles[0]} = 0;
2217     }
2218 }
2219
2220 sub __disallow_relocking{
2221     my ($locks) = @_;
2222     delete $locks->{relockable};
2223 }
2224
2225 sub __lock_and_load_merged_bugs{
2226     my %param =
2227         validate_with(params => \@_,
2228                       spec =>
2229                       {bugs_to_load => {type => ARRAYREF,
2230                                         default => sub {[]},
2231                                        },
2232                        data         => {type => HASHREF|ARRAYREF,
2233                                        },
2234                        locks        => {type => HASHREF,
2235                                         default => sub {{};},
2236                                        },
2237                        reload_all => {type => BOOLEAN,
2238                                       default => 0,
2239                                      },
2240                        debug           => {type => HANDLE,
2241                                           },
2242                       },
2243                      );
2244     my %data;
2245     my $new_locks = 0;
2246     if (ref($param{data}) eq 'ARRAY') {
2247         for my $data (@{$param{data}}) {
2248             $data{$data->{bug_num}} = dclone($data);
2249         }
2250     }
2251     else {
2252         %data = %{dclone($param{data})};
2253     }
2254     my @bugs_to_load = @{$param{bugs_to_load}};
2255     if ($param{reload_all}) {
2256         push @bugs_to_load, keys %data;
2257     }
2258     my %temp;
2259     @temp{@bugs_to_load} = (1) x @bugs_to_load;
2260     @bugs_to_load = keys %temp;
2261     my %loaded_this_time;
2262     my $bug_to_load;
2263     while ($bug_to_load = shift @bugs_to_load) {
2264         if (not $param{reload_all}) {
2265             next if exists $data{$bug_to_load};
2266         }
2267         else {
2268             next if $loaded_this_time{$bug_to_load};
2269         }
2270         my $lock_bug = 1;
2271         if ($param{reload_all}) {
2272             if (exists $data{$bug_to_load}) {
2273                 $lock_bug = 0;
2274             }
2275         }
2276         my $data =
2277             read_bug(bug => $bug_to_load,
2278                      lock => $lock_bug,
2279                      locks => $param{locks},
2280                     ) or
2281                         die "Unable to load bug $bug_to_load";
2282         print {$param{debug}} "read bug $bug_to_load\n";
2283         $data{$data->{bug_num}} = $data;
2284         $new_locks += $lock_bug;
2285         $loaded_this_time{$data->{bug_num}} = 1;
2286         push @bugs_to_load,
2287             grep {not exists $data{$_}}
2288                 split / /,$data->{mergedwith};
2289     }
2290     return (\%data,$new_locks);
2291 }
2292
2293
2294 sub __calculate_merge_status{
2295     my ($data_a,$data_h,$master_bug,$merge_status) = @_;
2296     my %merge_status = %{$merge_status // {}};
2297     my %merged_bugs;
2298     my $bugs_to_merge = 0;
2299     for my $data (@{$data_a}) {
2300         # check to see if this bug is unmerged in the set
2301         if (not length $data->{mergedwith} or
2302             grep {not exists $merged_bugs{$_}} split / /,$data->{mergedwith}) {
2303             $merged_bugs{$data->{bug_num}} = 1;
2304             $bugs_to_merge = 1;
2305         }
2306         # the master_bug is the bug that every other bug is made to
2307         # look like. However, if merge is set, tags, fixed and found
2308         # are merged.
2309         if ($data->{bug_num} == $master_bug) {
2310             for (qw(package forwarded severity blocks blockedby done owner summary outlook affects)) {
2311                 $merge_status{$_} = $data->{$_}
2312             }
2313         }
2314         if (defined $merge_status) {
2315             next unless $data->{bug_num} == $master_bug;
2316         }
2317         $merge_status{tag} = {} if not exists $merge_status{tag};
2318         for my $tag (split /\s+/, $data->{keywords}) {
2319             $merge_status{tag}{$tag} = 1;
2320         }
2321         $merge_status{keywords} = join(' ',sort keys %{$merge_status{tag}});
2322         for (qw(fixed found)) {
2323             @{$merge_status{"${_}_versions"}}{@{$data->{"${_}_versions"}}} = (1) x @{$data->{"${_}_versions"}};
2324         }
2325     }
2326     # if there is a non-source qualified version with a corresponding
2327     # source qualified version, we only want to merge the source
2328     # qualified version(s)
2329     for (qw(fixed found)) {
2330         my @unqualified_versions = grep {m{/}?0:1} keys %{$merge_status{"${_}_versions"}};
2331         for my $unqualified_version (@unqualified_versions) {
2332             if (grep {m{/\Q$unqualified_version\E}} keys %{$merge_status{"${_}_versions"}}) {
2333                 delete $merge_status{"${_}_versions"}{$unqualified_version};
2334             }
2335         }
2336     }
2337     return (\%merge_status,$bugs_to_merge);
2338 }
2339
2340
2341
2342 sub __calculate_merge_changes{
2343     my ($datas,$merge_status,$param) = @_;
2344     my %changes;
2345     my @disallowed_changes;
2346     for my $data (@{$datas}) {
2347         # things that can be forced
2348         #
2349         # * func is the function to set the new value
2350         #
2351         # * key is the key of the function to set the value,
2352
2353         # * modify_value is a function which is called to modify the new
2354         # value so that the function will accept it
2355
2356         # * options is an ARRAYREF of options to pass to the function
2357
2358         # * allowed is a BOOLEAN which controls whether this setting
2359         # is allowed to be different by default.
2360         my %force_functions =
2361             (forwarded => {func => \&set_forwarded,
2362                            key  => 'forwarded',
2363                            options => [],
2364                           },
2365              severity  => {func => \&set_severity,
2366                            key  => 'severity',
2367                            options => [],
2368                           },
2369              blocks    => {func => \&set_blocks,
2370                            modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2371                            key  => 'block',
2372                            options => [],
2373                           },
2374              blockedby => {func => \&set_blocks,
2375                            modify_value => sub {defined $_[0]?[split ' ',$_[0]]:[]},
2376                            key  => 'block',
2377                            options => [],
2378                           },
2379              done      => {func => \&set_done,
2380                            key  => 'done',
2381                            options => [],
2382                           },
2383              owner     => {func => \&owner,
2384                            key  => 'owner',
2385                            options => [],
2386                           },
2387              summary   => {func => \&summary,
2388                            key  => 'summary',
2389                            options => [],
2390                           },
2391              outlook   => {func => \&outlook,
2392                            key  => 'outlook',
2393                            options => [],
2394                           },
2395              affects   => {func => \&affects,
2396                            key  => 'package',
2397                            options => [],
2398                           },
2399              package   => {func => \&set_package,
2400                            key  => 'package',
2401                            options => [],
2402                           },
2403              keywords   => {func => \&set_tag,
2404                             key  => 'tag',
2405                             modify_value => sub {defined $_[0]?[sort split /\s+/,$_[0]]:[]},
2406                             allowed => 1,
2407                            },
2408              fixed_versions => {func => \&set_fixed,
2409                                 key => 'fixed',
2410                                 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2411                                 allowed => 1,
2412                                },
2413              found_versions => {func => \&set_found,
2414                                 key   => 'found',
2415                                 modify_value => sub {(defined $_[0] and ref($_[0]) eq 'HASH')?[sort keys %{$_[0]}]:$_[0]},
2416                                 allowed => 1,
2417                                },
2418             );
2419         for my $field (qw(forwarded severity blocks blockedby done owner summary outlook affects package fixed_versions found_versions keywords)) {
2420             # if the ideal bug already has the field set properly, we
2421             # continue on.
2422             if ($field eq 'keywords'){
2423                 next if join(' ',sort split /\s+/,$data->{keywords}) eq
2424                     join(' ',sort keys %{$merge_status->{tag}});
2425             }
2426             elsif ($field =~ /^(?:fixed|found)_versions$/) {
2427                 next if join(' ', sort @{$data->{$field}}) eq
2428                     join(' ',sort keys %{$merge_status->{$field}});
2429             }
2430             elsif ($field eq 'done') {
2431                 # for done, we only care if the bug is done or not
2432                 # done, not the value it's set to.
2433                 if (defined $merge_status->{$field} and length $merge_status->{$field} and
2434                     defined $data->{$field}         and length $data->{$field}) {
2435                     next;
2436                 }
2437                 elsif ((not defined $merge_status->{$field} or not length $merge_status->{$field}) and
2438                        (not defined $data->{$field}         or not length $data->{$field})
2439                       ) {
2440                     next;
2441                 }
2442             }
2443             elsif ($merge_status->{$field} eq $data->{$field}) {
2444                 next;
2445             }
2446             my $change =
2447                 {field => $field,
2448                  bug => $data->{bug_num},
2449                  orig_value => $data->{$field},
2450                  func_value   =>
2451                  (exists $force_functions{$field}{modify_value} ?
2452                   $force_functions{$field}{modify_value}->($merge_status->{$field}):
2453                   $merge_status->{$field}),
2454                  value    => $merge_status->{$field},
2455                  function => $force_functions{$field}{func},
2456                  key      => $force_functions{$field}{key},
2457                  options  => $force_functions{$field}{options},
2458                  allowed  => exists $force_functions{$field}{allowed} ? $force_functions{$field}{allowed} : 0,
2459                 };
2460             $change->{text_value} = ref($change->{func_value}) eq 'ARRAY'?join(' ',@{$change->{func_value}}):$change->{func_value};
2461             $change->{text_orig_value} = ref($change->{orig_value}) eq 'ARRAY'?join(' ',@{$change->{orig_value}}):$change->{orig_value};
2462             if ($param->{force} or $change->{allowed}) {
2463                 if ($field ne 'package' or $change->{allowed}) {
2464                     push @{$changes{$data->{bug_num}}},$change;
2465                     next;
2466                 }
2467                 if ($param->{allow_reassign}) {
2468                     if ($param->{reassign_different_sources}) {
2469                         push @{$changes{$data->{bug_num}}},$change;
2470                         next;
2471                     }
2472                     # allow reassigning if binary_to_source returns at
2473                     # least one of the same source packages
2474                     my @merge_status_source =
2475                         binary_to_source(package => $merge_status->{package},
2476                                          source_only => 1,
2477                                         );
2478                     my @other_bug_source =
2479                         binary_to_source(package => $data->{package},
2480                                          source_only => 1,
2481                                         );
2482                     my %merge_status_sources;
2483                     @merge_status_sources{@merge_status_source} =
2484                         (1) x @merge_status_source;
2485                     if (grep {$merge_status_sources{$_}} @other_bug_source) {
2486                         push @{$changes{$data->{bug_num}}},$change;
2487                         next;
2488                     }
2489                 }
2490             }
2491             push @disallowed_changes,$change;
2492         }
2493         # blocks and blocked by are weird; we have to go through and
2494         # set blocks to the other half of the merged bugs
2495     }
2496     return (\@disallowed_changes,\%changes);
2497 }
2498
2499 =head2 affects
2500
2501      eval {
2502             affects(bug          => $ref,
2503                     transcript   => $transcript,
2504                     ($dl > 0 ? (debug => $transcript):()),
2505                     requester    => $header{from},
2506                     request_addr => $controlrequestaddr,
2507                     message      => \@log,
2508                     affected_packages => \%affected_packages,
2509                     recipients   => \%recipients,
2510                     packages     => undef,
2511                     add          => 1,
2512                     remove       => 0,
2513                    );
2514         };
2515         if ($@) {
2516             $errors++;
2517             print {$transcript} "Failed to mark $ref as affecting $packages: $@";
2518         }
2519
2520 This marks a bug as affecting packages which the bug is not actually
2521 in. This should only be used in cases where fixing the bug instantly
2522 resolves the problem in the other packages.
2523
2524 By default, the packages are set to the list of packages passed.
2525 However, if you pass add => 1 or remove => 1, the list of packages
2526 passed are added or removed from the affects list, respectively.
2527
2528 =cut
2529
2530 sub affects {
2531     my %param = validate_with(params => \@_,
2532                               spec   => {bug => {type   => SCALAR,
2533                                                  regex  => qr/^\d+$/,
2534                                                 },
2535                                          # specific options here
2536                                          package => {type => SCALAR|ARRAYREF|UNDEF,
2537                                                      default => [],
2538                                                     },
2539                                          add      => {type => BOOLEAN,
2540                                                       default => 0,
2541                                                      },
2542                                          remove   => {type => BOOLEAN,
2543                                                       default => 0,
2544                                                      },
2545                                          %common_options,
2546                                          %append_action_options,
2547                                         },
2548                              );
2549     if ($param{add} and $param{remove}) {
2550          croak "Asking to both add and remove affects is nonsensical";
2551     }
2552     if (not defined $param{package}) {
2553         $param{package} = [];
2554     }
2555     my %info =
2556         __begin_control(%param,
2557                         command  => 'affects'
2558                        );
2559     my ($debug,$transcript) =
2560         @info{qw(debug transcript)};
2561     my @data = @{$info{data}};
2562     my @bugs = @{$info{bugs}};
2563     my $action = '';
2564     for my $data (@data) {
2565         $action = '';
2566          print {$debug} "Going to change affects\n";
2567          my @packages = splitpackages($data->{affects});
2568          my %packages;
2569          @packages{@packages} = (1) x @packages;
2570          if ($param{add}) {
2571               my @added = ();
2572               for my $package (make_list($param{package})) {
2573                   next unless defined $package and length $package;
2574                   if (not $packages{$package}) {
2575                       $packages{$package} = 1;
2576                       push @added,$package;
2577                   }
2578               }
2579               if (@added) {
2580                    $action = "Added indication that $data->{bug_num} affects ".
2581                         english_join(\@added);
2582               }
2583          }
2584          elsif ($param{remove}) {
2585               my @removed = ();
2586               for my $package (make_list($param{package})) {
2587                    if ($packages{$package}) {
2588                        next unless defined $package and length $package;
2589                         delete $packages{$package};
2590                         push @removed,$package;
2591                    }
2592               }
2593               $action = "Removed indication that $data->{bug_num} affects " .
2594                    english_join(\@removed);
2595          }
2596          else {
2597               my %added_packages = ();
2598               my %removed_packages = %packages;
2599               %packages = ();
2600               for my $package (make_list($param{package})) {
2601                    next unless defined $package and length $package;
2602                    $packages{$package} = 1;
2603                    delete $removed_packages{$package};
2604                    $added_packages{$package} = 1;
2605               }
2606               if (keys %removed_packages) {
2607                   $action = "Removed indication that $data->{bug_num} affects ".
2608                       english_join([keys %removed_packages]);
2609                   $action .= "\n" if keys %added_packages;
2610               }
2611               if (keys %added_packages) {
2612                   $action .= "Added indication that $data->{bug_num} affects " .
2613                    english_join([keys %added_packages]);
2614               }
2615          }
2616         if (not length $action) {
2617             print {$transcript} "Ignoring request to set affects of bug $data->{bug_num} to the same value previously set\n";
2618             next;
2619         }
2620          my $old_data = dclone($data);
2621          $data->{affects} = join(',',keys %packages);
2622          append_action_to_log(bug => $data->{bug_num},
2623                               get_lock => 0,
2624                               command => 'affects',
2625                               new_data => $data,
2626                               old_data => $old_data,
2627                               __return_append_to_log_options(
2628                                                              %param,
2629                                                              action => $action,
2630                                                             ),
2631                              )
2632                if not exists $param{append_log} or $param{append_log};
2633           writebug($data->{bug_num},$data);
2634           print {$transcript} "$action\n";
2635      }
2636     __end_control(%info);
2637 }
2638
2639
2640 =head1 SUMMARY FUNCTIONS
2641
2642 =head2 summary
2643
2644      eval {
2645             summary(bug          => $ref,
2646                     transcript   => $transcript,
2647                     ($dl > 0 ? (debug => $transcript):()),
2648                     requester    => $header{from},
2649                     request_addr => $controlrequestaddr,
2650                     message      => \@log,
2651                     affected_packages => \%affected_packages,
2652                     recipients   => \%recipients,
2653                     summary      => undef,
2654                    );
2655         };
2656         if ($@) {
2657             $errors++;
2658             print {$transcript} "Failed to mark $ref with summary foo: $@";
2659         }
2660
2661 Handles all setting of summary fields
2662
2663 If summary is undef, unsets the summary
2664
2665 If summary is 0, sets the summary to the first paragraph contained in
2666 the message passed.
2667
2668 If summary is a positive integer, sets the summary to the message specified.
2669
2670 Otherwise, sets summary to the value passed.
2671
2672 =cut
2673
2674
2675 sub summary {
2676     # outlook and summary are exactly the same, basically
2677     return _summary('summary',@_);
2678 }
2679
2680 =head1 OUTLOOK FUNCTIONS
2681
2682 =head2 outlook
2683
2684      eval {
2685             outlook(bug          => $ref,
2686                     transcript   => $transcript,
2687                     ($dl > 0 ? (debug => $transcript):()),
2688                     requester    => $header{from},
2689                     request_addr => $controlrequestaddr,
2690                     message      => \@log,
2691                     affected_packages => \%affected_packages,
2692                     recipients   => \%recipients,
2693                     outlook      => undef,
2694                    );
2695         };
2696         if ($@) {
2697             $errors++;
2698             print {$transcript} "Failed to mark $ref with outlook foo: $@";
2699         }
2700
2701 Handles all setting of outlook fields
2702
2703 If outlook is undef, unsets the outlook
2704
2705 If outlook is 0, sets the outlook to the first paragraph contained in
2706 the message passed.
2707
2708 If outlook is a positive integer, sets the outlook to the message specified.
2709
2710 Otherwise, sets outlook to the value passed.
2711
2712 =cut
2713
2714
2715 sub outlook {
2716     return _summary('outlook',@_);
2717 }
2718
2719 sub _summary {
2720     my ($cmd,@params) = @_;
2721     my %param = validate_with(params => \@params,
2722                               spec   => {bug => {type   => SCALAR,
2723                                                  regex  => qr/^\d+$/,
2724                                                 },
2725                                          # specific options here
2726                                          $cmd , {type => SCALAR|UNDEF,
2727                                                  default => 0,
2728                                                 },
2729                                          %common_options,
2730                                          %append_action_options,
2731                                         },
2732                              );
2733     my %info =
2734         __begin_control(%param,
2735                         command  => $cmd,
2736                        );
2737     my ($debug,$transcript) =
2738         @info{qw(debug transcript)};
2739     my @data = @{$info{data}};
2740     my @bugs = @{$info{bugs}};
2741     # figure out the log that we're going to use
2742     my $summary = '';
2743     my $summary_msg = '';
2744     my $action = '';
2745     if (not defined $param{$cmd}) {
2746          # do nothing
2747          print {$debug} "Removing $cmd fields\n";
2748          $action = "Removed $cmd";
2749     }
2750     elsif ($param{$cmd} =~ /^\d+$/) {
2751          my $log = [];
2752          my @records = Debbugs::Log::read_log_records(bug_num => $param{bug});
2753          if ($param{$cmd} == 0) {
2754               $log = $param{message};
2755               $summary_msg = @records + 1;
2756          }
2757          else {
2758               if (($param{$cmd} - 1 ) > $#records) {
2759                    die "Message number '$param{$cmd}' exceeds the maximum message '$#records'";
2760               }
2761               my $record = $records[($param{$cmd} - 1 )];
2762               if ($record->{type} !~ /incoming-recv|recips/) {
2763                    die "Message number '$param{$cmd}' is a invalid message type '$record->{type}'";
2764               }
2765               $summary_msg = $param{$cmd};
2766               $log = [$record->{text}];
2767          }
2768          my $p_o = Debbugs::MIME::parse(join('',@{$log}));
2769          my $body = $p_o->{body};
2770          my $in_pseudoheaders = 0;
2771          my $paragraph = '';
2772          # walk through body until we get non-blank lines
2773          for my $line (@{$body}) {
2774               if ($line =~ /^\s*$/) {
2775                    if (length $paragraph) {
2776                         if ($paragraph =~ m/^(?:.+\n\>)+.+\n/x) {
2777                              $paragraph = '';
2778                              next;
2779                         }
2780                         last;
2781                    }
2782                    $in_pseudoheaders = 0;
2783                    next;
2784               }
2785               # skip a paragraph if it looks like it's control or
2786               # pseudo-headers
2787               if ($line =~ m{^\s*(?:Package|Source|Version|User|Tag|Severity)\:\s+\S}xi or #pseudo headers
2788                   $line =~ m{^(?:package:?|(?:no|)owner|severity|tags?|summary| #control
2789                                  \#|reopen|close|(?:not|)(?:fixed|found)|clone|
2790                                  debug|(?:not|)forwarded|priority|
2791                                  (?:un|)block|limit|(?:un|)archive|
2792                                  reassign|retitle|affects|wrongpackage
2793                                  (?:un|force|)merge|user(?:category|tags?|)
2794                              )\s+\S}xis) {
2795                    if (not length $paragraph) {
2796                         print {$debug} "Found control/pseudo-headers and skiping them\n";
2797                         $in_pseudoheaders = 1;
2798                         next;
2799                    }
2800               }
2801               next if $in_pseudoheaders;
2802               $paragraph .= $line ." \n";
2803          }
2804          print {$debug} ucfirst($cmd)." is going to be '$paragraph'\n";
2805          $summary = $paragraph;
2806          $summary =~ s/[\n\r]/ /g;
2807          if (not length $summary) {
2808               die "Unable to find $cmd message to use";
2809          }
2810          # trim off a trailing spaces
2811          $summary =~ s/\ *$//;
2812     }
2813     else {
2814         $summary = $param{$cmd};
2815     }
2816     for my $data (@data) {
2817          print {$debug} "Going to change $cmd\n";
2818          if (((not defined $summary or not length $summary) and
2819               (not defined $data->{$cmd} or not length $data->{$cmd})) or
2820              $summary eq $data->{$cmd}) {
2821              print {$transcript} "Ignoring request to change the $cmd of bug $param{bug} to the same value\n";
2822              next;
2823          }
2824          if (length $summary) {
2825               if (length $data->{$cmd}) {
2826                    $action = ucfirst($cmd)." replaced with message bug $param{bug} message $summary_msg";
2827               }
2828               else {
2829                    $action = ucfirst($cmd)." recorded from message bug $param{bug} message $summary_msg";
2830               }
2831          }
2832          my $old_data = dclone($data);
2833          $data->{$cmd} = $summary;
2834          append_action_to_log(bug => $data->{bug_num},
2835                               command => $cmd,
2836                               old_data => $old_data,
2837                               new_data => $data,
2838                               get_lock => 0,
2839                               __return_append_to_log_options(
2840                                                              %param,
2841                                                              action => $action,
2842                                                             ),
2843                              )
2844                if not exists $param{append_log} or $param{append_log};
2845           writebug($data->{bug_num},$data);
2846           print {$transcript} "$action\n";
2847      }
2848     __end_control(%info);
2849 }
2850
2851
2852
2853 =head2 clone_bug
2854
2855      eval {
2856             clone_bug(bug          => $ref,
2857                       transcript   => $transcript,
2858                       ($dl > 0 ? (debug => $transcript):()),
2859                       requester    => $header{from},
2860                       request_addr => $controlrequestaddr,
2861                       message      => \@log,
2862                       affected_packages => \%affected_packages,
2863                       recipients   => \%recipients,
2864                      );
2865         };
2866         if ($@) {
2867             $errors++;
2868             print {$transcript} "Failed to clone bug $ref bar: $@";
2869         }
2870
2871 Clones the given bug.
2872
2873 We currently don't support cloning merged bugs, but this could be
2874 handled by internally unmerging, cloning, then remerging the bugs.
2875
2876 =cut
2877
2878 sub clone_bug {
2879     my %param = validate_with(params => \@_,
2880                               spec   => {bug => {type   => SCALAR,
2881                                                  regex  => qr/^\d+$/,
2882                                                 },
2883                                          new_bugs => {type => ARRAYREF,
2884                                                      },
2885                                          new_clones => {type => HASHREF,
2886                                                         default => {},
2887                                                        },
2888                                          %common_options,
2889                                          %append_action_options,
2890                                         },
2891                              );
2892     my %info =
2893         __begin_control(%param,
2894                         command  => 'clone'
2895                        );
2896     my ($debug,$transcript) =
2897         @info{qw(debug transcript)};
2898     my @data = @{$info{data}};
2899     my @bugs = @{$info{bugs}};
2900
2901     my $action = '';
2902     for my $data (@data) {
2903         if (length($data->{mergedwith})) {
2904             die "Bug is marked as being merged with others. Use an existing clone.\n";
2905         }
2906     }
2907     if (@data != 1) {
2908         die "Not exactly one bug‽ This shouldn't happen.";
2909     }
2910     my $data = $data[0];
2911     my %clones;
2912     for my $newclone_id (@{$param{new_bugs}}) {
2913         my $new_bug_num = new_bug(copy => $data->{bug_num});
2914         $param{new_clones}{$newclone_id} = $new_bug_num;
2915         $clones{$newclone_id} = $new_bug_num;
2916     }
2917     my @new_bugs = sort values %clones;
2918     my @collapsed_ids;
2919     for my $new_bug (@new_bugs) {
2920         # no collapsed ids or the higher collapsed id is not one less
2921         # than the next highest new bug
2922         if (not @collapsed_ids or
2923             $collapsed_ids[-1][1]+1 != $new_bug) {
2924             push @collapsed_ids,[$new_bug,$new_bug];
2925         }
2926         else {
2927             $collapsed_ids[-1][1] = $new_bug;
2928         }
2929     }
2930     my @collapsed;
2931     for my $ci (@collapsed_ids) {
2932         if ($ci->[0] == $ci->[1]) {
2933             push @collapsed,$ci->[0];
2934         }
2935         else {
2936             push @collapsed,$ci->[0].'-'.$ci->[1]
2937         }
2938     }
2939     my $collapsed_str = english_join(\@collapsed);
2940     $action = "Bug $data->{bug_num} cloned as bug".(@new_bugs > 1?'s':'').' '.$collapsed_str;
2941     for my $new_bug (@new_bugs) {
2942         append_action_to_log(bug => $new_bug,
2943                              get_lock => 1,
2944                              __return_append_to_log_options(
2945                                                             %param,
2946                                                             action => $action,
2947                                                            ),
2948                             )
2949             if not exists $param{append_log} or $param{append_log};
2950     }
2951     append_action_to_log(bug => $data->{bug_num},
2952                          get_lock => 0,
2953                          __return_append_to_log_options(
2954                                                         %param,
2955                                                         action => $action,
2956                                                        ),
2957                         )
2958         if not exists $param{append_log} or $param{append_log};
2959     writebug($data->{bug_num},$data);
2960     print {$transcript} "$action\n";
2961     __end_control(%info);
2962     # bugs that this bug is blocking are also blocked by the new clone(s)
2963     for my $bug (split ' ', $data->{blocks}) {
2964         for my $new_bug (@new_bugs) {
2965             set_blocks(bug => $new_bug,
2966                        block => $bug,
2967                        hash_slice(%param,
2968                                   keys %common_options,
2969                                   keys %append_action_options),
2970                       );
2971         }
2972     }
2973     # bugs that this bug is blocked by are also blocking the new clone(s)
2974     for my $bug (split ' ', $data->{blockedby}) {
2975         for my $new_bug (@new_bugs) {
2976             set_blocks(bug => $bug,
2977                        block => $new_bug,
2978                        hash_slice(%param,
2979                                   keys %common_options,
2980                                   keys %append_action_options),
2981                       );
2982         }
2983     }
2984 }
2985
2986
2987
2988 =head1 OWNER FUNCTIONS
2989
2990 =head2 owner
2991
2992      eval {
2993             owner(bug          => $ref,
2994                   transcript   => $transcript,
2995                   ($dl > 0 ? (debug => $transcript):()),
2996                   requester    => $header{from},
2997                   request_addr => $controlrequestaddr,
2998                   message      => \@log,
2999                   recipients   => \%recipients,
3000                   owner        => undef,
3001                  );
3002         };
3003         if ($@) {
3004             $errors++;
3005             print {$transcript} "Failed to mark $ref as having an owner: $@";
3006         }
3007
3008 Handles all setting of the owner field; given an owner of undef or of
3009 no length, indicates that a bug is not owned by anyone.
3010
3011 =cut
3012
3013 sub owner {
3014      my %param = validate_with(params => \@_,
3015                                spec   => {bug => {type   => SCALAR,
3016                                                   regex  => qr/^\d+$/,
3017                                                  },
3018                                           owner => {type => SCALAR|UNDEF,
3019                                                    },
3020                                           %common_options,
3021                                           %append_action_options,
3022                                          },
3023                               );
3024      my %info =
3025          __begin_control(%param,
3026                          command  => 'owner',
3027                         );
3028      my ($debug,$transcript) =
3029         @info{qw(debug transcript)};
3030      my @data = @{$info{data}};
3031      my @bugs = @{$info{bugs}};
3032      my $action = '';
3033      for my $data (@data) {
3034           print {$debug} "Going to change owner to '".(defined $param{owner}?$param{owner}:'(going to unset it)')."'\n";
3035           print {$debug} "Owner is currently '$data->{owner}' for bug $data->{bug_num}\n";
3036           if (not defined $param{owner} or not length $param{owner}) {
3037               if (not defined $data->{owner} or not length $data->{owner}) {
3038                   print {$transcript} "Ignoring request to unset the owner of bug #$data->{bug_num} which was not set\n";
3039                   next;
3040               }
3041               $param{owner} = '';
3042               $action = "Removed annotation that $config{bug} was owned by " .
3043                   "$data->{owner}.";
3044           }
3045           else {
3046               if ($data->{owner} eq $param{owner}) {
3047                   print {$transcript} "Ignoring request to set the owner of bug #$data->{bug_num} to the same value\n";
3048                   next;
3049               }
3050               if (length $data->{owner}) {
3051                   $action = "Owner changed from $data->{owner} to $param{owner}.";
3052               }
3053               else {
3054                   $action = "Owner recorded as $param{owner}."
3055               }
3056           }
3057           my $old_data = dclone($data);
3058           $data->{owner} = $param{owner};
3059           append_action_to_log(bug => $data->{bug_num},
3060                                command => 'owner',
3061                                new_data => $data,
3062                                old_data => $old_data,
3063                                get_lock => 0,
3064                __return_append_to_log_options(
3065                                               %param,
3066                                               action => $action,
3067                                              ),
3068                               )
3069                if not exists $param{append_log} or $param{append_log};
3070           writebug($data->{bug_num},$data);
3071           print {$transcript} "$action\n";
3072      }
3073      __end_control(%info);
3074 }
3075
3076
3077 =head1 ARCHIVE FUNCTIONS
3078
3079
3080 =head2 bug_archive
3081
3082      my $error = '';
3083      eval {
3084         bug_archive(bug => $bug_num,
3085                     debug => \$debug,
3086                     transcript => \$transcript,
3087                    );
3088      };
3089      if ($@) {
3090         $errors++;
3091         transcript("Unable to archive $bug_num\n");
3092         warn $@;
3093      }
3094      transcript($transcript);
3095
3096
3097 This routine archives a bug
3098
3099 =over
3100
3101 =item bug -- bug number
3102
3103 =item check_archiveable -- check wether a bug is archiveable before
3104 archiving; defaults to 1
3105
3106 =item archive_unarchived -- whether to archive bugs which have not
3107 previously been archived; defaults to 1. [Set to 0 when used from
3108 control@]
3109
3110 =item ignore_time -- whether to ignore time constraints when archiving
3111 a bug; defaults to 0.
3112
3113 =back
3114
3115 =cut
3116
3117 sub bug_archive {
3118      my %param = validate_with(params => \@_,
3119                                spec   => {bug => {type   => SCALAR,
3120                                                   regex  => qr/^\d+$/,
3121                                                  },
3122                                           check_archiveable => {type => BOOLEAN,
3123                                                                 default => 1,
3124                                                                },
3125                                           archive_unarchived => {type => BOOLEAN,
3126                                                                  default => 1,
3127                                                                 },
3128                                           ignore_time => {type => BOOLEAN,
3129                                                           default => 0,
3130                                                          },
3131                                           %common_options,
3132                                           %append_action_options,
3133                                          },
3134                               );
3135      my %info = __begin_control(%param,
3136                                 command => 'archive',
3137                                 );
3138      my ($debug,$transcript) = @info{qw(debug transcript)};
3139      my @data = @{$info{data}};
3140      my @bugs = @{$info{bugs}};
3141      my $action = "$config{bug} archived.";
3142      if ($param{check_archiveable} and
3143          not bug_archiveable(bug=>$param{bug},
3144                              ignore_time => $param{ignore_time},
3145                             )) {
3146           print {$transcript} "Bug $param{bug} cannot be archived\n";
3147           die "Bug $param{bug} cannot be archived";
3148      }
3149      if (not $param{archive_unarchived} and
3150          not exists $data[0]{unarchived}
3151         ) {
3152           print {$transcript} "$param{bug} has not been archived previously\n";
3153           die "$param{bug} has not been archived previously";
3154      }
3155      add_recipients(recipients => $param{recipients},
3156                     data => \@data,
3157                     debug      => $debug,
3158                     transcript => $transcript,
3159                    );
3160      print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3161      for my $bug (@bugs) {
3162          if ($param{check_archiveable}) {
3163              die "Bug $bug cannot be archived (but $param{bug} can?)"
3164                  unless bug_archiveable(bug=>$bug,
3165                                         ignore_time => $param{ignore_time},
3166                                        );
3167          }
3168      }
3169      # If we get here, we can archive/remove this bug
3170      print {$debug} "$param{bug} removing\n";
3171      for my $bug (@bugs) {
3172           #print "$param{bug} removing $bug\n" if $debug;
3173           my $dir = get_hashname($bug);
3174           # First indicate that this bug is being archived
3175           append_action_to_log(bug => $bug,
3176                                get_lock => 0,
3177                                command => 'archive',
3178                                # we didn't actually change the data
3179                                # when we archived, so we don't pass
3180                                # a real new_data or old_data
3181                                new_data => {},
3182                                old_data => {},
3183                                __return_append_to_log_options(
3184                                  %param,
3185                                  action => $action,
3186                                 )
3187                               )
3188                if not exists $param{append_log} or $param{append_log};
3189           my @files_to_remove = map {s#$config{spool_dir}/db-h/$dir/##; $_} glob("$config{spool_dir}/db-h/$dir/$bug.*");
3190           if ($config{save_old_bugs}) {
3191                mkpath("$config{spool_dir}/archive/$dir");
3192                foreach my $file (@files_to_remove) {
3193                    link("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3194                        copy("$config{spool_dir}/db-h/$dir/$file", "$config{spool_dir}/archive/$dir/$file") or
3195                            # we need to bail out here if things have
3196                            # gone horribly wrong to avoid removing a
3197                            # bug altogether
3198                            die "Unable to link or copy $config{spool_dir}/db-h/$dir/$file to $config{spool_dir}/archive/$dir/$file; $!";
3199                }
3200
3201                print {$transcript} "archived $bug to archive/$dir (from $param{bug})\n";
3202           }
3203           unlink(map {"$config{spool_dir}/db-h/$dir/$_"} @files_to_remove);
3204           print {$debug} "deleted $bug (from $param{bug})\n";
3205      }
3206      bughook_archive(@bugs);
3207      __end_control(%info);
3208 }
3209
3210 =head2 bug_unarchive
3211
3212      my $error = '';
3213      eval {
3214         bug_unarchive(bug => $bug_num,
3215                       debug => \$debug,
3216                       transcript => \$transcript,
3217                      );
3218      };
3219      if ($@) {
3220         $errors++;
3221         transcript("Unable to archive bug: $bug_num");
3222      }
3223      transcript($transcript);
3224
3225 This routine unarchives a bug
3226
3227 =cut
3228
3229 sub bug_unarchive {
3230      my %param = validate_with(params => \@_,
3231                                spec   => {bug => {type   => SCALAR,
3232                                                   regex  => qr/^\d+/,
3233                                                  },
3234                                           %common_options,
3235                                           %append_action_options,
3236                                          },
3237                               );
3238
3239      my %info = __begin_control(%param,
3240                                 archived=>1,
3241                                 command=>'unarchive');
3242      my ($debug,$transcript) =
3243          @info{qw(debug transcript)};
3244      my @data = @{$info{data}};
3245      my @bugs = @{$info{bugs}};
3246      my $action = "$config{bug} unarchived.";
3247      my @files_to_remove;
3248      for my $bug (@bugs) {
3249           print {$debug} "$param{bug} removing $bug\n";
3250           my $dir = get_hashname($bug);
3251           my @files_to_copy = map {s#$config{spool_dir}/archive/$dir/##; $_} glob("$config{spool_dir}/archive/$dir/$bug.*");
3252           mkpath("archive/$dir");
3253           foreach my $file (@files_to_copy) {
3254                # die'ing here sucks
3255                link( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3256                     copy( "$config{spool_dir}/archive/$dir/$file", "$config{spool_dir}/db-h/$dir/$file" ) or
3257                          die "Unable to copy $config{spool_dir}/archive/$dir/$file to $config{spool_dir}/db-h/$dir/$file";
3258           }
3259           push @files_to_remove, map {"$config{spool_dir}/archive/$dir/$_"} @files_to_copy;
3260           print {$transcript} "Unarchived $config{bug} $bug\n";
3261      }
3262      unlink(@files_to_remove) or die "Unable to unlink bugs";
3263      # Indicate that this bug has been archived previously
3264      for my $bug (@bugs) {
3265           my $newdata = readbug($bug);
3266           my $old_data = dclone($newdata);
3267           if (not defined $newdata) {
3268                print {$transcript} "$config{bug} $bug disappeared!\n";
3269                die "Bug $bug disappeared!";
3270           }
3271           $newdata->{unarchived} = time;
3272           append_action_to_log(bug => $bug,
3273                                get_lock => 0,
3274                                command => 'unarchive',
3275                                new_data => $newdata,
3276                                old_data => $old_data,
3277                                __return_append_to_log_options(
3278                                  %param,
3279                                  action => $action,
3280                                 )
3281                               )
3282                if not exists $param{append_log} or $param{append_log};
3283           writebug($bug,$newdata);
3284      }
3285      __end_control(%info);
3286 }
3287
3288 =head2 append_action_to_log
3289
3290      append_action_to_log
3291
3292 This should probably be moved to Debbugs::Log; have to think that out
3293 some more.
3294
3295 =cut
3296
3297 sub append_action_to_log{
3298      my %param = validate_with(params => \@_,
3299                                spec   => {bug => {type   => SCALAR,
3300                                                   regex  => qr/^\d+/,
3301                                                  },
3302                                           new_data => {type => HASHREF,
3303                                                        optional => 1,
3304                                                       },
3305                                           old_data => {type => HASHREF,
3306                                                        optional => 1,
3307                                                       },
3308                                           command  => {type => SCALAR,
3309                                                        optional => 1,
3310                                                       },
3311                                           action => {type => SCALAR,
3312                                                     },
3313                                           requester => {type => SCALAR,
3314                                                         default => '',
3315                                                        },
3316                                           request_addr => {type => SCALAR,
3317                                                            default => '',
3318                                                           },
3319                                           location => {type => SCALAR,
3320                                                        optional => 1,
3321                                                       },
3322                                           message  => {type => SCALAR|ARRAYREF,
3323                                                        default => '',
3324                                                       },
3325                                           recips   => {type => SCALAR|ARRAYREF,
3326                                                        optional => 1
3327                                                       },
3328                                           desc       => {type => SCALAR,
3329                                                          default => '',
3330                                                         },
3331                                           get_lock   => {type => BOOLEAN,
3332                                                          default => 1,
3333                                                         },
3334                                           locks      => {type => HASHREF,
3335                                                          optional => 1,
3336                                                         },
3337                                           # we don't use
3338                                           # append_action_options here
3339                                           # because some of these
3340                                           # options aren't actually
3341                                           # optional, even though the
3342                                           # original function doesn't
3343                                           # require them
3344                                          },
3345                               );
3346      # Fix this to use $param{location}
3347      my $log_location = buglog($param{bug});
3348      die "Unable to find .log for $param{bug}"
3349           if not defined $log_location;
3350      if ($param{get_lock}) {
3351           filelock("lock/$param{bug}",exists $param{locks}?$param{locks}:());
3352           $locks++;
3353      }
3354      my @records;
3355      my $logfh = IO::File->new(">>$log_location") or
3356          die "Unable to open $log_location for appending: $!";
3357      # determine difference between old and new
3358      my $data_diff = '';
3359      if (exists $param{old_data} and exists $param{new_data}) {
3360          my $old_data = dclone($param{old_data});
3361          my $new_data = dclone($param{new_data});
3362          for my $key (keys %{$old_data}) {
3363              if (not exists $Debbugs::Status::fields{$key}) {
3364                  delete $old_data->{$key};
3365                  next;
3366              }
3367              next unless exists $new_data->{$key};
3368              next unless defined $new_data->{$key};
3369              if (not defined $old_data->{$key}) {
3370                  delete $old_data->{$key};
3371                  next;
3372              }
3373              if (ref($new_data->{$key}) and
3374                  ref($old_data->{$key}) and
3375                  ref($new_data->{$key}) eq ref($old_data->{$key})) {
3376                 local $Storable::canonical = 1;
3377                 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3378                     delete $new_data->{$key};
3379                     delete $old_data->{$key};
3380                 }
3381              }
3382              elsif ($new_data->{$key} eq $old_data->{$key}) {
3383                  delete $new_data->{$key};
3384                  delete $old_data->{$key};
3385              }
3386          }
3387          for my $key (keys %{$new_data}) {
3388              if (not exists $Debbugs::Status::fields{$key}) {
3389                  delete $new_data->{$key};
3390                  next;
3391              }
3392              next unless exists $old_data->{$key};
3393              next unless defined $old_data->{$key};
3394              if (not defined $new_data->{$key} or
3395                  not exists $Debbugs::Status::fields{$key}) {
3396                  delete $new_data->{$key};
3397                  next;
3398              }
3399              if (ref($new_data->{$key}) and
3400                  ref($old_data->{$key}) and
3401                  ref($new_data->{$key}) eq ref($old_data->{$key})) {
3402                 local $Storable::canonical = 1;
3403                 if (nfreeze($new_data->{$key}) eq nfreeze($old_data->{$key})) {
3404                     delete $new_data->{$key};
3405                     delete $old_data->{$key};
3406                 }
3407              }
3408              elsif ($new_data->{$key} eq $old_data->{$key}) {
3409                  delete $new_data->{$key};
3410                  delete $old_data->{$key};
3411              }
3412          }
3413          $data_diff .= "<!-- new_data:\n";
3414          my %nd;
3415          for my $key (keys %{$new_data}) {
3416              if (not exists $Debbugs::Status::fields{$key}) {
3417                  warn "No such field $key";
3418                  next;
3419              }
3420              $nd{$key} = $new_data->{$key};
3421              # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $new_data->{$key}")."\n";
3422          }
3423          $data_diff .= html_escape(Data::Dumper->Dump([encode_utf8_structure(\%nd)],[qw(new_data)]));
3424          $data_diff .= "-->\n";
3425          $data_diff .= "<!-- old_data:\n";
3426          my %od;
3427          for my $key (keys %{$old_data}) {
3428              if (not exists $Debbugs::Status::fields{$key}) {
3429                  warn "No such field $key";
3430                  next;
3431              }
3432              $od{$key} = $old_data->{$key};
3433              # $data_diff .= html_escape("$Debbugs::Status::fields{$key}: $old_data->{$key}")."\n";
3434          }
3435          $data_diff .= html_escape(Data::Dumper->Dump([encode_utf8_structure(\%od)],[qw(old_data)]));
3436          $data_diff .= "-->\n";
3437      }
3438      my $msg = join('',
3439                     (exists $param{command} ?
3440                      "<!-- command:".html_escape(encode_utf8($param{command}))." -->\n":""
3441                     ),
3442                     (length $param{requester} ?
3443                      "<!-- requester: ".html_escape(encode_utf8($param{requester}))." -->\n":""
3444                     ),
3445                     (length $param{request_addr} ?
3446                      "<!-- request_addr: ".html_escape(encode_utf8($param{request_addr}))." -->\n":""
3447                     ),
3448                     "<!-- time:".time()." -->\n",
3449                     $data_diff,
3450                     "<strong>".html_escape(encode_utf8($param{action}))."</strong>\n");
3451      if (length $param{requester}) {
3452           $msg .= "Request was from <code>".html_escape(encode_utf8($param{requester}))."</code>\n";
3453      }
3454      if (length $param{request_addr}) {
3455           $msg .= "to <code>".html_escape(encode_utf8($param{request_addr}))."</code>";
3456      }
3457      if (length $param{desc}) {
3458           $msg .= ":<br>\n".encode_utf8($param{desc})."\n";
3459      }
3460      else {
3461           $msg .= ".\n";
3462      }
3463      push @records, {type => 'html',
3464                      text => $msg,
3465                     };
3466      $msg = '';
3467      if ((ref($param{message}) and @{$param{message}}) or length($param{message})) {
3468          push @records, {type => exists $param{recips}?'recips':'incoming-recv',
3469                          exists $param{recips}?(recips => [make_list($param{recips})]):(),
3470                          text => join('',make_list($param{message})),
3471                         };
3472      }
3473      write_log_records(logfh=>$logfh,
3474                        records => \@records,
3475                       );
3476      close $logfh or die "Unable to close $log_location: $!";
3477      if ($param{get_lock}) {
3478           unfilelock(exists $param{locks}?$param{locks}:());
3479           $locks--;
3480      }
3481
3482
3483 }
3484
3485
3486 =head1 PRIVATE FUNCTIONS
3487
3488 =head2 __handle_affected_packages
3489
3490      __handle_affected_packages(affected_packages => {},
3491                                 data => [@data],
3492                                )
3493
3494
3495
3496 =cut
3497
3498 sub __handle_affected_packages{
3499      my %param = validate_with(params => \@_,
3500                                spec   => {%common_options,
3501                                           data => {type => ARRAYREF|HASHREF
3502                                                   },
3503                                          },
3504                                allow_extra => 1,
3505                               );
3506      for my $data (make_list($param{data})) {
3507           next unless exists $data->{package} and defined $data->{package};
3508           my @packages = split /\s*,\s*/,$data->{package};
3509           @{$param{affected_packages}}{@packages} = (1) x @packages;
3510       }
3511 }
3512
3513 =head2 __handle_debug_transcript
3514
3515      my ($debug,$transcript) = __handle_debug_transcript(%param);
3516
3517 Returns a debug and transcript filehandle
3518
3519
3520 =cut
3521
3522 sub __handle_debug_transcript{
3523      my %param = validate_with(params => \@_,
3524                                spec   => {%common_options},
3525                                allow_extra => 1,
3526                               );
3527      my $debug = globify_scalar(exists $param{debug}?$param{debug}:undef);
3528      my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3529      return ($debug,$transcript);
3530 }
3531
3532 =head2 __bug_info
3533
3534      __bug_info($data)
3535
3536 Produces a small bit of bug information to kick out to the transcript
3537
3538 =cut
3539
3540 sub __bug_info{
3541      my $return = '';
3542      for my $data (@_) {
3543          next unless defined $data and exists $data->{bug_num};
3544           $return .= "Bug #".($data->{bug_num}||'').
3545               ((defined $data->{done} and length $data->{done})?
3546                 " {Done: $data->{done}}":''
3547                ).
3548                " [".($data->{package}||'(no package)'). "] ".
3549                     ($data->{subject}||'(no subject)')."\n";
3550      }
3551      return $return;
3552 }
3553
3554
3555 =head2 __internal_request
3556
3557      __internal_request()
3558      __internal_request($level)
3559
3560 Returns true if the caller of the function calling __internal_request
3561 belongs to __PACKAGE__
3562
3563 This allows us to be magical, and don't bother to print bug info if
3564 the second caller is from this package, amongst other things.
3565
3566 An optional level is allowed, which increments the number of levels to
3567 check by the given value. [This is basically for use by internal
3568 functions like __begin_control which are always called by
3569 C<__PACKAGE__>.
3570
3571 =cut
3572
3573 sub __internal_request{
3574     my ($l) = @_;
3575     $l = 0 if not defined $l;
3576     if (defined((caller(1+$l))[0]) and (caller(1+$l))[0] eq __PACKAGE__) {
3577         return 1;
3578     }
3579     return 0;
3580 }
3581
3582 sub __return_append_to_log_options{
3583      my %param = @_;
3584      my $action = $param{action} if exists $param{action};
3585      if (not exists $param{requester}) {
3586           $param{requester} = $config{control_internal_requester};
3587      }
3588      if (not exists $param{request_addr}) {
3589           $param{request_addr} = $config{control_internal_request_addr};
3590      }
3591      if (not exists $param{message}) {
3592           my $date = rfc822_date();
3593           $param{message} = fill_in_template(template  => 'mail/fake_control_message',
3594                                              variables => {request_addr => $param{request_addr},
3595                                                            requester    => $param{requester},
3596                                                            date         => $date,
3597                                                            action       => $action
3598                                                           },
3599                                             );
3600      }
3601      if (not defined $action) {
3602           carp "Undefined action!";
3603           $action = "unknown action";
3604      }
3605      return (action => $action,
3606              hash_slice(%param,keys %append_action_options),
3607             );
3608 }
3609
3610 =head2 __begin_control
3611
3612      my %info = __begin_control(%param,
3613                                 archived=>1,
3614                                 command=>'unarchive');
3615      my ($debug,$transcript) = @info{qw(debug transcript)};
3616      my @data = @{$info{data}};
3617      my @bugs = @{$info{bugs}};
3618
3619
3620 Starts the process of modifying a bug; handles all of the generic
3621 things that almost every control request needs
3622
3623 Returns a hash containing
3624
3625 =over
3626
3627 =item new_locks -- number of new locks taken out by this call
3628
3629 =item debug -- the debug file handle
3630
3631 =item transcript -- the transcript file handle
3632
3633 =item data -- an arrayref containing the data of the bugs
3634 corresponding to this request
3635
3636 =item bugs -- an arrayref containing the bug numbers of the bugs
3637 corresponding to this request
3638
3639 =back
3640
3641 =cut
3642
3643 our $lockhash;
3644
3645 sub __begin_control {
3646     my %param = validate_with(params => \@_,
3647                               spec   => {bug => {type   => SCALAR,
3648                                                  regex  => qr/^\d+/,
3649                                                 },
3650                                          archived => {type => BOOLEAN,
3651                                                       default => 0,
3652                                                      },
3653                                          command  => {type => SCALAR,
3654                                                       optional => 1,
3655                                                      },
3656                                          %common_options,
3657                                         },
3658                               allow_extra => 1,
3659                              );
3660     my $new_locks;
3661     my ($debug,$transcript) = __handle_debug_transcript(@_);
3662     print {$debug} "considering bug $param{bug} for ".(exists $param{command}?$param{command}:scalar caller())."\n";
3663 #    print {$debug} Data::Dumper->Dump([[caller(1)],\%param],[qw(caller param)])."\n";
3664     $lockhash = $param{locks} if exists $param{locks};
3665     my @data = ();
3666     my $old_die = $SIG{__DIE__};
3667     $SIG{__DIE__} = *sig_die{CODE};
3668
3669     ($new_locks, @data) =
3670         lock_read_all_merged_bugs(bug => $param{bug},
3671                                   $param{archived}?(location => 'archive'):(),
3672                                   exists $param{locks} ? (locks => $param{locks}):(),
3673                                  );
3674     $locks += $new_locks;
3675     if (not @data) {
3676         die "Unable to read any bugs successfully.";
3677     }
3678     if (not $param{archived}) {
3679         for my $data (@data) {
3680             if ($data->{archived}) {
3681                 die "Not altering archived bugs; see unarchive.";
3682             }
3683         }
3684     }
3685     if (not check_limit(data => \@data,
3686                           exists $param{limit}?(limit => $param{limit}):(),
3687                           transcript => $transcript,
3688                          )) {
3689         die "limit failed for bugs: ".join(', ',map {$_->{bug_num}} @data);
3690     }
3691
3692     __handle_affected_packages(%param,data => \@data);
3693     print {$transcript} __bug_info(@data) if $param{show_bug_info} and not __internal_request(1);
3694     print {$debug} "$param{bug} read $locks locks\n";
3695     if (not @data or not defined $data[0]) {
3696         print {$transcript} "No bug found for $param{bug}\n";
3697         die "No bug found for $param{bug}";
3698     }
3699
3700     add_recipients(data => \@data,
3701                    recipients => $param{recipients},
3702                    (exists $param{command}?(actions_taken => {$param{command} => 1}):()),
3703                    debug      => $debug,
3704                    (__internal_request()?(transcript => $transcript):()),
3705                   );
3706
3707     print {$debug} "$param{bug} read done\n";
3708     my @bugs = map {(defined $_ and exists $_->{bug_num} and defined $_->{bug_num})?$_->{bug_num}:()} @data;
3709     print {$debug} "$param{bug} bugs ".join(' ',@bugs)."\n";
3710     return (data       => \@data,
3711             bugs       => \@bugs,
3712             old_die    => $old_die,
3713             new_locks  => $new_locks,
3714             debug      => $debug,
3715             transcript => $transcript,
3716             param      => \%param,
3717             exists $param{locks}?(locks => $param{locks}):(),
3718            );
3719 }
3720
3721 =head2 __end_control
3722
3723      __end_control(%info);
3724
3725 Handles tearing down from a control request
3726
3727 =cut
3728
3729 sub __end_control {
3730     my %info = @_;
3731     if (exists $info{new_locks} and $info{new_locks} > 0) {
3732         print {$info{debug}} "For bug $info{param}{bug} unlocking $locks locks\n";
3733         for (1..$info{new_locks}) {
3734             unfilelock(exists $info{locks}?$info{locks}:());
3735             $locks--;
3736         }
3737     }
3738     $SIG{__DIE__} = $info{old_die};
3739     if (exists $info{param}{affected_bugs}) {
3740         @{$info{param}{affected_bugs}}{@{$info{bugs}}} = (1) x @{$info{bugs}};
3741     }
3742     add_recipients(recipients => $info{param}{recipients},
3743                    (exists $info{param}{command}?(actions_taken => {$info{param}{command} , 1}):()),
3744                    data       => $info{data},
3745                    debug      => $info{debug},
3746                    transcript => $info{transcript},
3747                   );
3748     __handle_affected_packages(%{$info{param}},data=>$info{data});
3749 }
3750
3751
3752 =head2 check_limit
3753
3754      check_limit(data => \@data, limit => $param{limit});
3755
3756
3757 Checks to make sure that bugs match any limits; each entry of @data
3758 much satisfy the limit.
3759
3760 Returns true if there are no entries in data, or there are no keys in
3761 limit; returns false (0) if there are any entries which do not match.
3762
3763 The limit hashref elements can contain an arrayref of scalars to
3764 match; regexes are also acccepted. At least one of the entries in each
3765 element needs to match the corresponding field in all data for the
3766 limit to succeed.
3767
3768 =cut
3769
3770
3771 sub check_limit{
3772     my %param = validate_with(params => \@_,
3773                               spec   => {data  => {type => ARRAYREF|HASHREF,
3774                                                   },
3775                                          limit => {type => HASHREF|UNDEF,
3776                                                   },
3777                                          transcript  => {type => SCALARREF|HANDLE,
3778                                                          optional => 1,
3779                                                         },
3780                                         },
3781                              );
3782     my @data = make_list($param{data});
3783     if (not @data or
3784         not defined $param{limit} or
3785         not keys %{$param{limit}}) {
3786         return 1;
3787     }
3788     my $transcript = globify_scalar(exists $param{transcript}?$param{transcript}:undef);
3789     my $going_to_fail = 0;
3790     for my $data (@data) {
3791         $data = split_status_fields(get_bug_status(bug => $data->{bug_num},
3792                                                    status => dclone($data),
3793                                                   ));
3794         for my $field (keys %{$param{limit}}) {
3795             next unless exists $param{limit}{$field};
3796             my $match = 0;
3797             my @data_fields = make_list($data->{$field});
3798 LIMIT:      for my $limit (make_list($param{limit}{$field})) {
3799                 if (not ref $limit) {
3800                     for my $data_field (@data_fields) {
3801                         if ($data_field eq $limit) {
3802                             $match = 1;
3803                             last LIMIT;
3804                         }
3805                     }
3806                 }
3807                 elsif (ref($limit) eq 'Regexp') {
3808                     for my $data_field (@data_fields) {
3809                         if ($data_field =~ $limit) {
3810                             $match = 1;
3811                             last LIMIT;
3812                         }
3813                     }
3814                 }
3815                 else {
3816                     warn "Unknown type of reference: '".ref($limit)."' in key '$field'";
3817                 }
3818             }
3819             if (not $match) {
3820                 $going_to_fail = 1;
3821                 print {$transcript} qq($field: ).join(', ',map{qq("$_")} make_list($data->{$field})).
3822                     "' does not match at least one of ".
3823                     join(', ',map {ref($_)?'(regex)':qq("$_")} make_list($param{limit}{$field}))."\n";
3824             }
3825         }
3826     }
3827     return $going_to_fail?0:1;
3828 }
3829
3830
3831 =head2 die
3832
3833      sig_die "foo"
3834
3835 We override die to specially handle unlocking files in the cases where
3836 we are called via eval. [If we're not called via eval, it doesn't
3837 matter.]
3838
3839 =cut
3840
3841 sub sig_die{
3842     if ($^S) { # in eval
3843         if ($locks) {
3844             for (1..$locks) { unfilelock(defined $lockhash?$lockhash:()); }
3845             $locks = 0;
3846         }
3847     }
3848 }
3849
3850
3851 # =head2 __message_body_template
3852 #
3853 #      message_body_template('mail/ack',{ref=>'foo'});
3854 #
3855 # Creates a message body using a template
3856 #
3857 # =cut
3858
3859 sub __message_body_template{
3860      my ($template,$extra_var) = @_;
3861      $extra_var ||={};
3862      my $hole_var = {'&bugurl' =>
3863                      sub{"$_[0]: ".
3864                              'http://'.$config{cgi_domain}.'/'.
3865                                  Debbugs::CGI::bug_links(bug => $_[0],
3866                                                          links_only => 1,
3867                                                         );
3868                      }
3869                     };
3870
3871      my $body = fill_in_template(template => $template,
3872                                  variables => {config => \%config,
3873                                                %{$extra_var},
3874                                               },
3875                                  hole_var => $hole_var,
3876                                 );
3877      return fill_in_template(template => 'mail/message_body',
3878                              variables => {config => \%config,
3879                                            %{$extra_var},
3880                                            body => $body,
3881                                           },
3882                              hole_var => $hole_var,
3883                             );
3884 }
3885
3886 sub __all_undef_or_equal {
3887     my @values = @_;
3888     return 1 if @values == 1 or @values == 0;
3889     my $not_def = grep {not defined $_} @values;
3890     if ($not_def == @values) {
3891         return 1;
3892     }
3893     if ($not_def > 0 and $not_def != @values) {
3894         return 0;
3895     }
3896     my $first_val = shift @values;
3897     for my $val (@values) {
3898         if ($first_val ne $val) {
3899             return 0;
3900         }
3901     }
3902     return 1;
3903 }
3904
3905
3906 1;
3907
3908 __END__