Debbugs/Control.pm

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