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