Debbugs/Control.pm

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