Debbugs/Control.pm

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