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