Debbugs/Control.pm

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