Debbugs/Control.pm

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