Debbugs/Control.pm

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