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