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