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